" ;# next newline writes inDT
set inPRE 0
newline
}
PP {
nest decr
nest incr
newPara
}
RE {
nest decr
}
RS {
nest incr
}
SE {
global noFillCount textState inPRE file
font R
puts -nonewline $file
set inPRE 0
set noFillCount 0
nest reset
newPara
text "See the "
font B
set temp $textState
set textState REF
text options
set textState $temp
font R
text " manual entry for detailed descriptions of the above options."
}
SH {
SHmacro $args
}
SO {
global noFillCount inPRE file
SHmacro "STANDARD OPTIONS"
setTabs {4c 8c 12c}
set noFillCount 1000000
puts -nonewline $file
set inPRE 1
font B
}
so {
if {$args != "man.macros"} {
puts stderr "Unknown macro: .$name [join $args " "]"
}
}
sp { ;# needs work
if {$args == ""} {
set count 1
} else {
set count [lindex $args 0]
}
while {$count > 0} {
lineBreak
incr count -1
}
}
ta {
setTabs $args
}
TH {
THmacro $args
}
TP {
TPmacro $args
}
UL { ;# underline
global file
puts -nonewline $file ""
text [lindex $args 0]
puts -nonewline $file ""
if {[llength $args] == 2} {
text [lindex $args 1]
}
}
VE {
# global file
# puts -nonewline $file ""
}
VS {
# global file
# if {[llength $args] > 0} {
# puts -nonewline $file "
"
# }
# puts -nonewline $file ""
}
default {
puts stderr "Unknown macro: .$name [join $args " "]"
}
}
# global nestStk; puts "$name [format "%-20s" $args] $nestStk"
# flush stdout; flush stderr
}
# font --
#
# This procedure is invoked to handle font changes in the text
# being output.
#
# Arguments:
# type - Type of font: R, I, B, or S.
proc font type {
global textState
switch $type {
P -
R {
endFont
if {$textState == "REF"} {
set textState INSERT
}
}
B {
beginFont Code
if {$textState == "INSERT"} {
set textState REF
}
}
I {
beginFont Emphasis
}
S {
}
default {
puts stderr "Unknown font: $type"
}
}
}
# formattedText --
#
# Insert a text string that may also have \fB-style font changes
# and a few other backslash sequences in it.
#
# Arguments:
# text - Text to insert.
proc formattedText text {
# puts "formattedText: $text"
while {$text != ""} {
set index [string first \\ $text]
if {$index < 0} {
text $text
return
}
text [string range $text 0 [expr $index-1]]
set c [string index $text [expr $index+1]]
switch -- $c {
f {
font [string index $text [expr $index+2]]
set text [string range $text [expr $index+3] end]
}
e {
text \\
set text [string range $text [expr $index+2] end]
}
- {
dash
set text [string range $text [expr $index+2] end]
}
| {
set text [string range $text [expr $index+2] end]
}
default {
puts stderr "Unknown sequence: \\$c"
set text [string range $text [expr $index+2] end]
}
}
}
}
# dash --
#
# This procedure is invoked to handle dash characters ("\-" in
# troff). It outputs a special dash character.
#
# Arguments:
# None.
proc dash {} {
global textState charCnt
if {$textState == "NAME"} {
set textState 0
}
incr charCnt
text "-"
}
# tab --
#
# This procedure is invoked to handle tabs in the troff input.
# Right now it does nothing.
#
# Arguments:
# None.
proc tab {} {
global inPRE charCnt tabString
# ? charCnt
if {$inPRE == 1} {
set pos [expr $charCnt % [string length $tabString] ]
set spaces [string first "1" [string range $tabString $pos end] ]
text [format "%*s" [incr spaces] " "]
} else {
# puts "tab: found tab outside of block"
}
}
# setTabs --
#
# This procedure handles the ".ta" macro, which sets tab stops.
#
# Arguments:
# tabList - List of tab stops, each consisting of a number
# followed by "i" (inch) or "c" (cm).
proc setTabs {tabList} {
global file breakPending tabString
# puts "setTabs: --$tabList--"
set last 0
set tabString {}
set charsPerInch 14.
set numTabs [llength $tabList]
foreach arg $tabList {
if {[scan $arg "%f%s" distance units] != 2} {
puts stderr "bad distance \"$arg\""
return 0
}
switch -- $units {
c {
set distance [expr $distance * $charsPerInch / 2.54 ]
}
i {
set distance [expr $distance * $charsPerInch]
}
default {
puts stderr "bad units in distance \"$arg\""
continue
}
}
# ? distance
lappend tabString [format "%*s1" [expr round($distance-$last-1)] " "]
set last $distance
}
set tabString [join $tabString {}]
# puts "setTabs: --$tabString--"
}
# lineBreak --
#
# Generates a line break in the HTML output.
#
# Arguments:
# None.
proc lineBreak {} {
global file inPRE
puts $file "
"
}
# newline --
#
# This procedure is invoked to handle newlines in the troff input.
# It outputs either a space character or a newline character, depending
# on fill mode.
#
# Arguments:
# None.
proc newline {} {
global noFillCount file inDT inPRE charCnt
if {$inDT != {} } {
puts $file "\n$inDT"
set inDT {}
} elseif {$noFillCount == 0 || $inPRE == 1} {
puts $file {}
} else {
lineBreak
incr noFillCount -1
}
set charCnt 0
}
# char --
#
# This procedure is called to handle a special character.
#
# Arguments:
# name - Special character named in troff \x or \(xx construct.
proc char name {
global file charCnt
incr charCnt
# puts "char: $name"
switch -exact $name {
\\0 { ;# \0
puts -nonewline $file " "
}
\\\\ { ;# \
puts -nonewline $file "\\"
}
\\(+- { ;# +/-
puts -nonewline $file "±"
}
\\% {} ;# \%
\\| { ;# \|
}
default {
puts stderr "Unknown character: $name"
}
}
}
# macro2 --
#
# This procedure handles macros that are invoked with a leading "'"
# character instead of space. Right now it just generates an
# error diagnostic.
#
# Arguments:
# name - The name of the macro (without the ".").
# args - Any additional arguments to the macro.
proc macro2 {name args} {
puts stderr "Unknown macro: '$name [join $args " "]"
}
# SHmacro --
#
# Subsection head; handles the .SH macro.
#
# Arguments:
# name - Section name.
proc SHmacro argList {
global file noFillCount textState charCnt
set args [join $argList " "]
if {[llength $argList] < 1} {
puts stderr "Bad .SH macro: .$name $args"
}
set noFillCount 0
nest reset
puts -nonewline $file ""
text $args
puts $file "
"
# ? args textState
# control what the text proc does with text
switch $args {
NAME {set textState NAME}
DESCRIPTION {set textState INSERT}
INTRODUCTION {set textState INSERT}
"WIDGET-SPECIFIC OPTIONS" {set textState INSERT}
"SEE ALSO" {set textState SEE}
KEYWORDS {set textState 0}
}
set charCnt 0
}
# IPmacro --
#
# This procedure is invoked to handle ".IP" macros, which may take any
# of the following forms:
#
# .IP [1] Translate to a "1Step" paragraph.
# .IP [x] (x > 1) Translate to a "Step" paragraph.
# .IP Translate to a "Bullet" paragraph.
# .IP text count Translate to a FirstBody paragraph with special
# indent and tab stop based on "count", and tab after
# "text".
#
# Arguments:
# argList - List of arguments to the .IP macro.
#
# HTML limitations: 'count' in '.IP text count' is ignored.
proc IPmacro argList {
global file
setTabs 0.5i
set length [llength $argList]
if {$length == 0} {
nest para UL LI
return
}
if {$length == 1} {
nest para OL LI
return
}
if {$length > 1} {
nest para DL DT
formattedText [lindex $argList 0]
puts $file "\n"
return
}
puts stderr "Bad .IP macro: .IP [join $argList " "]"
}
# TPmacro --
#
# This procedure is invoked to handle ".TP" macros, which may take any
# of the following forms:
#
# .TP x Translate to an indented paragraph with the
# specified indent (in 100 twip units).
# .TP Translate to an indented paragraph with
# default indent.
#
# Arguments:
# argList - List of arguments to the .IP macro.
#
# HTML limitations: 'x' in '.TP x' is ignored.
proc TPmacro {argList} {
global inDT
nest para DL DT
set inDT "\n" ;# next newline writes inDT
setTabs 0.5i
}
# THmacro --
#
# This procedure handles the .TH macro. It generates the non-scrolling
# header section for a given man page, and enters information into the
# table of contents. The .TH macro has the following form:
#
# .TH name section date footer header
#
# Arguments:
# argList - List of arguments to the .TH macro.
proc THmacro {argList} {
global file
if {[llength $argList] != 5} {
set args [join $argList " "]
puts stderr "Bad .TH macro: .$name $args"
}
set name [lindex $argList 0] ;# Tcl_UpVar
set page [lindex $argList 1] ;# 3
set vers [lindex $argList 2] ;# 7.4
set lib [lindex $argList 3] ;# Tcl
set pname [lindex $argList 4] ;# {Tcl Library Procedures}
puts -nonewline $file ""
text "$lib - $name ($page)"
puts $file "\n"
puts -nonewline $file ""
text $pname
puts $file "
\n"
}
# newPara --
#
# This procedure sets the left and hanging indents for a line.
# Indents are specified in units of inches or centimeters, and are
# relative to the current nesting level and left margin.
#
# Arguments:
# None
proc newPara {} {
global file nestStk
if {[lindex $nestStk end] != "NEW" } {
nest decr
}
puts -nonewline $file ""
}
# nest --
#
# This procedure takes care of inserting the tags associated with the
# IP, TP, RS, RE, LP and PP macros. Only 'nest para' takes arguments.
#
# Arguments:
# op - operation: para, incr, decr, reset, init
# listStart - begin list tag: OL, UL, DL.
# listItem - item tag: LI, LI, DT.
proc nest {op {listStart "NEW"} {listItem {} } } {
global file nestStk inDT charCnt
# puts "nest: $op $listStart $listItem"
switch $op {
para {
set top [lindex $nestStk end]
if {$top == "NEW" } {
set nestStk [lreplace $nestStk end end $listStart]
puts $file "<$listStart>"
} elseif {$top != $listStart} {
puts stderr "nest para: bad stack"
exit 1
}
puts $file "\n<$listItem>"
set charCnt 0
}
incr {
lappend nestStk NEW
}
decr {
if {[llength $nestStk] == 0} {
puts stderr "nest error: nest length is zero"
set nestStk NEW
}
set tag [lindex $nestStk end]
if {$tag != "NEW"} {
puts $file ""
}
set nestStk [lreplace $nestStk end end]
}
reset {
while {[llength $nestStk] > 0} {
nest decr
}
set nestStk NEW
}
init {
set nestStk NEW
set inDT {}
}
}
set charCnt 0
}
# do --
#
# This is the toplevel procedure that translates a man page
# to Frame. It runs the man2tcl program to turn the man page
# into a script, then it evals that script.
#
# Arguments:
# fileName - Name of the file to translate.
proc do fileName {
global file self html_dir package footer
set self "[file tail $fileName].html"
set file [open "$html_dir/$package/$self" w]
puts " Pass 2 -- $fileName"
flush stdout
initGlobals
if [catch {eval [exec man2tcl [glob $fileName]]} msg] {
global errorInfo
puts stderr $msg
puts "in"
puts stderr $errorInfo
exit 1
}
nest reset
puts $file $footer
puts $file ""
close $file
}
tcl8.4.20/tools/Makefile.in 0000644 0036047 0045461 00000002715 11737050674 014131 0 ustar dgp 771div # This makefile is used to convert Tcl manual pages into various
# alternate formats:
#
# Windows help file: 1. Build the winhelp target on Unix
# 2. Build the helpfile target on Windows
#
# HTML: 1. Build the html target on Unix
TCL = tcl@TCL_VERSION@
TK = tk@TCL_VERSION@
VER = @TCL_WIN_VERSION@
TCL_BIN_DIR = @TCL_BIN_DIR@
TCL_SOURCE = @TCL_SRC_DIR@
TK_SOURCE = $(TCL_SOURCE)/../$(TK)
PRO_SOURCE = $(TCL_SOURCE)/../pro
ITCL_SOURCE = $(TCL_SOURCE)/../itcl3.1.0
TCL_DOCS = $(TCL_SOURCE)/doc/*.[13n]
TK_DOCS = $(TK_SOURCE)/doc/*.[13n]
PRO_DOCS = \
$(PRO_SOURCE)/doc/man/procheck.1 \
$(PRO_SOURCE)/doc/man/prodebug.1 \
$(PRO_SOURCE)/doc/man/prodebug.n \
$(PRO_SOURCE)/doc/man/prolicense.1
ITCL_DOCS = \
$(ITCL_SOURCE)/itcl/doc/*.[13n] \
$(ITCL_SOURCE)/itk/doc/*.[13n]
# $(ITCL_SOURCE)/iwidgets3.0.0/doc/*.[13n]
COREDOCS = $(TCL_DOCS) $(TK_DOCS)
#PRODOCS = $(COREDOCS) $(PRO_DOCS) $(ITCL_DOCS)
PRODOCS = $(COREDOCS) $(PRO_DOCS)
TCLSH = $(TCL_BIN_DIR)/tclsh
CC = @CC@
#
# Targets
#
all: core
pro:
$(MAKE) DOCS="$(PRODOCS)" VER="" rtf
core:
$(MAKE) DOCS="$(COREDOCS)" rtf
rtf: $(TCL_SOURCE)/tools/man2help.tcl man2tcl $(DOCS)
LD_LIBRARY_PATH=$(TCL_BIN_DIR) \
TCL_LIBRARY=$(TCL_SOURCE)/library \
$(TCLSH) $(TCL_SOURCE)/tools/man2help.tcl tcl "$(VER)" $(DOCS)
winhelp: tcl.rtf
man2tcl: $(TCL_SOURCE)/tools/man2tcl.c
$(CC) $(CFLAGS) -o man2tcl $(TCL_SOURCE)/tools/man2tcl.c
clean:
-rm -f man2tcl *.o *.cnt *.rtf
helpfile:
hcw /c /e tcl.hpj
tcl8.4.20/tools/configure 0000755 0036047 0045461 00000066767 11737050674 014014 0 ustar dgp 771div #! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated automatically using autoconf version 2.13
# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
#
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
# Defaults:
ac_help=
ac_default_prefix=/usr/local
# Any additions from configure.in:
ac_help="$ac_help
--with-tcl=DIR use Tcl $DEF_VER binaries from DIR"
# Initialize some variables set by options.
# The variables have the same names as the options, with
# dashes changed to underlines.
build=NONE
cache_file=./config.cache
exec_prefix=NONE
host=NONE
no_create=
nonopt=NONE
no_recursion=
prefix=NONE
program_prefix=NONE
program_suffix=NONE
program_transform_name=s,x,x,
silent=
site=
srcdir=
target=NONE
verbose=
x_includes=NONE
x_libraries=NONE
bindir='${exec_prefix}/bin'
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
datadir='${prefix}/share'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
libdir='${exec_prefix}/lib'
includedir='${prefix}/include'
oldincludedir='/usr/include'
infodir='${prefix}/info'
mandir='${prefix}/man'
# Initialize some other variables.
subdirs=
MFLAGS= MAKEFLAGS=
SHELL=${CONFIG_SHELL-/bin/sh}
# Maximum number of lines to put in a shell here document.
ac_max_here_lines=12
ac_prev=
for ac_option
do
# If the previous option needs an argument, assign it.
if test -n "$ac_prev"; then
eval "$ac_prev=\$ac_option"
ac_prev=
continue
fi
case "$ac_option" in
-*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
*) ac_optarg= ;;
esac
# Accept the important Cygnus configure options, so we can diagnose typos.
case "$ac_option" in
-bindir | --bindir | --bindi | --bind | --bin | --bi)
ac_prev=bindir ;;
-bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
bindir="$ac_optarg" ;;
-build | --build | --buil | --bui | --bu)
ac_prev=build ;;
-build=* | --build=* | --buil=* | --bui=* | --bu=*)
build="$ac_optarg" ;;
-cache-file | --cache-file | --cache-fil | --cache-fi \
| --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
ac_prev=cache_file ;;
-cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
| --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
cache_file="$ac_optarg" ;;
-datadir | --datadir | --datadi | --datad | --data | --dat | --da)
ac_prev=datadir ;;
-datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
| --da=*)
datadir="$ac_optarg" ;;
-disable-* | --disable-*)
ac_feature=`echo $ac_option|sed -e 's/-*disable-//'`
# Reject names that are not valid shell variable names.
if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then
{ echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
fi
ac_feature=`echo $ac_feature| sed 's/-/_/g'`
eval "enable_${ac_feature}=no" ;;
-enable-* | --enable-*)
ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'`
# Reject names that are not valid shell variable names.
if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then
{ echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
fi
ac_feature=`echo $ac_feature| sed 's/-/_/g'`
case "$ac_option" in
*=*) ;;
*) ac_optarg=yes ;;
esac
eval "enable_${ac_feature}='$ac_optarg'" ;;
-exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
| --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
| --exec | --exe | --ex)
ac_prev=exec_prefix ;;
-exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
| --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
| --exec=* | --exe=* | --ex=*)
exec_prefix="$ac_optarg" ;;
-gas | --gas | --ga | --g)
# Obsolete; use --with-gas.
with_gas=yes ;;
-help | --help | --hel | --he)
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat << EOF
Usage: configure [options] [host]
Options: [defaults in brackets after descriptions]
Configuration:
--cache-file=FILE cache test results in FILE
--help print this message
--no-create do not create output files
--quiet, --silent do not print \`checking...' messages
--version print the version of autoconf that created configure
Directory and file names:
--prefix=PREFIX install architecture-independent files in PREFIX
[$ac_default_prefix]
--exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
[same as prefix]
--bindir=DIR user executables in DIR [EPREFIX/bin]
--sbindir=DIR system admin executables in DIR [EPREFIX/sbin]
--libexecdir=DIR program executables in DIR [EPREFIX/libexec]
--datadir=DIR read-only architecture-independent data in DIR
[PREFIX/share]
--sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc]
--sharedstatedir=DIR modifiable architecture-independent data in DIR
[PREFIX/com]
--localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var]
--libdir=DIR object code libraries in DIR [EPREFIX/lib]
--includedir=DIR C header files in DIR [PREFIX/include]
--oldincludedir=DIR C header files for non-gcc in DIR [/usr/include]
--infodir=DIR info documentation in DIR [PREFIX/info]
--mandir=DIR man documentation in DIR [PREFIX/man]
--srcdir=DIR find the sources in DIR [configure dir or ..]
--program-prefix=PREFIX prepend PREFIX to installed program names
--program-suffix=SUFFIX append SUFFIX to installed program names
--program-transform-name=PROGRAM
run sed PROGRAM on installed program names
EOF
cat << EOF
Host type:
--build=BUILD configure for building on BUILD [BUILD=HOST]
--host=HOST configure for HOST [guessed]
--target=TARGET configure for TARGET [TARGET=HOST]
Features and packages:
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
--x-includes=DIR X include files are in DIR
--x-libraries=DIR X library files are in DIR
EOF
if test -n "$ac_help"; then
echo "--enable and --with options recognized:$ac_help"
fi
exit 0 ;;
-host | --host | --hos | --ho)
ac_prev=host ;;
-host=* | --host=* | --hos=* | --ho=*)
host="$ac_optarg" ;;
-includedir | --includedir | --includedi | --included | --include \
| --includ | --inclu | --incl | --inc)
ac_prev=includedir ;;
-includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
| --includ=* | --inclu=* | --incl=* | --inc=*)
includedir="$ac_optarg" ;;
-infodir | --infodir | --infodi | --infod | --info | --inf)
ac_prev=infodir ;;
-infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
infodir="$ac_optarg" ;;
-libdir | --libdir | --libdi | --libd)
ac_prev=libdir ;;
-libdir=* | --libdir=* | --libdi=* | --libd=*)
libdir="$ac_optarg" ;;
-libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
| --libexe | --libex | --libe)
ac_prev=libexecdir ;;
-libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
| --libexe=* | --libex=* | --libe=*)
libexecdir="$ac_optarg" ;;
-localstatedir | --localstatedir | --localstatedi | --localstated \
| --localstate | --localstat | --localsta | --localst \
| --locals | --local | --loca | --loc | --lo)
ac_prev=localstatedir ;;
-localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
| --localstate=* | --localstat=* | --localsta=* | --localst=* \
| --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
localstatedir="$ac_optarg" ;;
-mandir | --mandir | --mandi | --mand | --man | --ma | --m)
ac_prev=mandir ;;
-mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
mandir="$ac_optarg" ;;
-nfp | --nfp | --nf)
# Obsolete; use --without-fp.
with_fp=no ;;
-no-create | --no-create | --no-creat | --no-crea | --no-cre \
| --no-cr | --no-c)
no_create=yes ;;
-no-recursion | --no-recursion | --no-recursio | --no-recursi \
| --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
no_recursion=yes ;;
-oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
| --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
| --oldin | --oldi | --old | --ol | --o)
ac_prev=oldincludedir ;;
-oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
| --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
| --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
oldincludedir="$ac_optarg" ;;
-prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
ac_prev=prefix ;;
-prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
prefix="$ac_optarg" ;;
-program-prefix | --program-prefix | --program-prefi | --program-pref \
| --program-pre | --program-pr | --program-p)
ac_prev=program_prefix ;;
-program-prefix=* | --program-prefix=* | --program-prefi=* \
| --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
program_prefix="$ac_optarg" ;;
-program-suffix | --program-suffix | --program-suffi | --program-suff \
| --program-suf | --program-su | --program-s)
ac_prev=program_suffix ;;
-program-suffix=* | --program-suffix=* | --program-suffi=* \
| --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
program_suffix="$ac_optarg" ;;
-program-transform-name | --program-transform-name \
| --program-transform-nam | --program-transform-na \
| --program-transform-n | --program-transform- \
| --program-transform | --program-transfor \
| --program-transfo | --program-transf \
| --program-trans | --program-tran \
| --progr-tra | --program-tr | --program-t)
ac_prev=program_transform_name ;;
-program-transform-name=* | --program-transform-name=* \
| --program-transform-nam=* | --program-transform-na=* \
| --program-transform-n=* | --program-transform-=* \
| --program-transform=* | --program-transfor=* \
| --program-transfo=* | --program-transf=* \
| --program-trans=* | --program-tran=* \
| --progr-tra=* | --program-tr=* | --program-t=*)
program_transform_name="$ac_optarg" ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
-sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
| --sbi=* | --sb=*)
sbindir="$ac_optarg" ;;
-sharedstatedir | --sharedstatedir | --sharedstatedi \
| --sharedstated | --sharedstate | --sharedstat | --sharedsta \
| --sharedst | --shareds | --shared | --share | --shar \
| --sha | --sh)
ac_prev=sharedstatedir ;;
-sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
| --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
| --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
| --sha=* | --sh=*)
sharedstatedir="$ac_optarg" ;;
-site | --site | --sit)
ac_prev=site ;;
-site=* | --site=* | --sit=*)
site="$ac_optarg" ;;
-srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
ac_prev=srcdir ;;
-srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
srcdir="$ac_optarg" ;;
-sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
| --syscon | --sysco | --sysc | --sys | --sy)
ac_prev=sysconfdir ;;
-sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
| --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
sysconfdir="$ac_optarg" ;;
-target | --target | --targe | --targ | --tar | --ta | --t)
ac_prev=target ;;
-target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
target="$ac_optarg" ;;
-v | -verbose | --verbose | --verbos | --verbo | --verb)
verbose=yes ;;
-version | --version | --versio | --versi | --vers)
echo "configure generated by autoconf version 2.13"
exit 0 ;;
-with-* | --with-*)
ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'`
# Reject names that are not valid shell variable names.
if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then
{ echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
fi
ac_package=`echo $ac_package| sed 's/-/_/g'`
case "$ac_option" in
*=*) ;;
*) ac_optarg=yes ;;
esac
eval "with_${ac_package}='$ac_optarg'" ;;
-without-* | --without-*)
ac_package=`echo $ac_option|sed -e 's/-*without-//'`
# Reject names that are not valid shell variable names.
if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then
{ echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
fi
ac_package=`echo $ac_package| sed 's/-/_/g'`
eval "with_${ac_package}=no" ;;
--x)
# Obsolete; use --with-x.
with_x=yes ;;
-x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
| --x-incl | --x-inc | --x-in | --x-i)
ac_prev=x_includes ;;
-x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
| --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
x_includes="$ac_optarg" ;;
-x-libraries | --x-libraries | --x-librarie | --x-librari \
| --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
ac_prev=x_libraries ;;
-x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
| --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
x_libraries="$ac_optarg" ;;
-*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; }
;;
*)
if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then
echo "configure: warning: $ac_option: invalid host type" 1>&2
fi
if test "x$nonopt" != xNONE; then
{ echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; }
fi
nonopt="$ac_option"
;;
esac
done
if test -n "$ac_prev"; then
{ echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; }
fi
trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
# File descriptor usage:
# 0 standard input
# 1 file creation
# 2 errors and warnings
# 3 some systems may open it to /dev/tty
# 4 used on the Kubota Titan
# 6 checking for... messages and results
# 5 compiler messages saved in config.log
if test "$silent" = yes; then
exec 6>/dev/null
else
exec 6>&1
fi
exec 5>./config.log
echo "\
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
" 1>&5
# Strip out --no-create and --no-recursion so they do not pile up.
# Also quote any args containing shell metacharacters.
ac_configure_args=
for ac_arg
do
case "$ac_arg" in
-no-create | --no-create | --no-creat | --no-crea | --no-cre \
| --no-cr | --no-c) ;;
-no-recursion | --no-recursion | --no-recursio | --no-recursi \
| --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;;
*" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*)
ac_configure_args="$ac_configure_args '$ac_arg'" ;;
*) ac_configure_args="$ac_configure_args $ac_arg" ;;
esac
done
# NLS nuisances.
# Only set these to C if already set. These must not be set unconditionally
# because not all systems understand e.g. LANG=C (notably SCO).
# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'!
# Non-C LC_CTYPE values break the ctype check.
if test "${LANG+set}" = set; then LANG=C; export LANG; fi
if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi
if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi
# confdefs.h avoids OS command line length limits that DEFS can exceed.
rm -rf conftest* confdefs.h
# AIX cpp loses on an empty file, so make sure it contains at least a newline.
echo > confdefs.h
# A filename unique to this package, relative to the directory that
# configure is in, which we can look for to find out if srcdir is correct.
ac_unique_file=man2tcl.c
# Find the source files, if location was not specified.
if test -z "$srcdir"; then
ac_srcdir_defaulted=yes
# Try the directory containing this script, then its parent.
ac_prog=$0
ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'`
test "x$ac_confdir" = "x$ac_prog" && ac_confdir=.
srcdir=$ac_confdir
if test ! -r $srcdir/$ac_unique_file; then
srcdir=..
fi
else
ac_srcdir_defaulted=no
fi
if test ! -r $srcdir/$ac_unique_file; then
if test "$ac_srcdir_defaulted" = yes; then
{ echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; }
else
{ echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; }
fi
fi
srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'`
# Prefer explicitly selected file to automatically selected ones.
if test -z "$CONFIG_SITE"; then
if test "x$prefix" != xNONE; then
CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
else
CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
fi
fi
for ac_site_file in $CONFIG_SITE; do
if test -r "$ac_site_file"; then
echo "loading site script $ac_site_file"
. "$ac_site_file"
fi
done
if test -r "$cache_file"; then
echo "loading cache $cache_file"
. $cache_file
else
echo "creating cache $cache_file"
> $cache_file
fi
ac_ext=c
# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
ac_cpp='$CPP $CPPFLAGS'
ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
cross_compiling=$ac_cv_prog_cc_cross
ac_exeext=
ac_objext=o
if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
# Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then
ac_n= ac_c='
' ac_t=' '
else
ac_n=-n ac_c= ac_t=
fi
else
ac_n= ac_c='\c' ac_t=
fi
# Recover information that Tcl computed with its configure script.
#--------------------------------------------------------------------
# See if there was a command-line option for where Tcl is; if
# not, assume that its top-level directory is a sibling of ours.
#--------------------------------------------------------------------
DEF_VER=8.4
# Check whether --with-tcl or --without-tcl was given.
if test "${with_tcl+set}" = set; then
withval="$with_tcl"
TCL_BIN_DIR=$withval
else
TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`
fi
if test ! -d $TCL_BIN_DIR; then
{ echo "configure: error: Tcl directory $TCL_BIN_DIR doesn't exist" 1>&2; exit 1; }
fi
if test ! -f $TCL_BIN_DIR/tclConfig.sh; then
{ echo "configure: error: There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?" 1>&2; exit 1; }
fi
. $TCL_BIN_DIR/tclConfig.sh
TCL_WIN_VERSION=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
CC=$TCL_CC
trap '' 1 2 15
cat > confcache <<\EOF
# This file is a shell script that caches the results of configure
# tests run on this system so they can be shared between configure
# scripts and configure runs. It is not useful on other systems.
# If it contains results you don't want to keep, you may remove or edit it.
#
# By default, configure uses ./config.cache as the cache file,
# creating it if it does not exist already. You can give configure
# the --cache-file=FILE option to use a different cache file; that is
# what configure does when it calls configure scripts in
# subdirectories, so they share the cache.
# Giving --cache-file=/dev/null disables caching, for debugging configure.
# config.status only pays attention to the cache file if you give it the
# --recheck option to rerun configure.
#
EOF
# The following way of writing the cache mishandles newlines in values,
# but we know of no workaround that is simple, portable, and efficient.
# So, don't put newlines in cache variables' values.
# Ultrix sh set writes to stderr and can't be redirected directly,
# and sets the high bit in the cache file unless we assign to the vars.
(set) 2>&1 |
case `(ac_space=' '; set | grep ac_space) 2>&1` in
*ac_space=\ *)
# `set' does not quote correctly, so add quotes (double-quote substitution
# turns \\\\ into \\, and sed turns \\ into \).
sed -n \
-e "s/'/'\\\\''/g" \
-e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p"
;;
*)
# `set' quotes correctly as required by POSIX, so do not add quotes.
sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p'
;;
esac >> confcache
if cmp -s $cache_file confcache; then
:
else
if test -w $cache_file; then
echo "updating cache $cache_file"
cat confcache > $cache_file
else
echo "not updating unwritable cache $cache_file"
fi
fi
rm -f confcache
trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
test "x$prefix" = xNONE && prefix=$ac_default_prefix
# Let make expand exec_prefix.
test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
# Any assignment to VPATH causes Sun make to only execute
# the first set of double-colon rules, so remove it if not needed.
# If there is a colon in the path, we need to keep it.
if test "x$srcdir" = x.; then
ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d'
fi
trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15
# Transform confdefs.h into DEFS.
# Protect against shell expansion while executing Makefile rules.
# Protect against Makefile macro expansion.
cat > conftest.defs <<\EOF
s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g
s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g
s%\[%\\&%g
s%\]%\\&%g
s%\$%$$%g
EOF
DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '`
rm -f conftest.defs
# Without the "./", some shells look in PATH for config.status.
: ${CONFIG_STATUS=./config.status}
echo creating $CONFIG_STATUS
rm -f $CONFIG_STATUS
cat > $CONFIG_STATUS </dev/null | sed 1q`:
#
# $0 $ac_configure_args
#
# Compiler output produced by configure, useful for debugging
# configure, is in ./config.log if it exists.
ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]"
for ac_option
do
case "\$ac_option" in
-recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
-version | --version | --versio | --versi | --vers | --ver | --ve | --v)
echo "$CONFIG_STATUS generated by autoconf version 2.13"
exit 0 ;;
-help | --help | --hel | --he | --h)
echo "\$ac_cs_usage"; exit 0 ;;
*) echo "\$ac_cs_usage"; exit 1 ;;
esac
done
ac_given_srcdir=$srcdir
trap 'rm -fr `echo "Makefile tcl.hpj" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
EOF
cat >> $CONFIG_STATUS < conftest.subs <<\\CEOF
$ac_vpsub
$extrasub
s%@SHELL@%$SHELL%g
s%@CFLAGS@%$CFLAGS%g
s%@CPPFLAGS@%$CPPFLAGS%g
s%@CXXFLAGS@%$CXXFLAGS%g
s%@FFLAGS@%$FFLAGS%g
s%@DEFS@%$DEFS%g
s%@LDFLAGS@%$LDFLAGS%g
s%@LIBS@%$LIBS%g
s%@exec_prefix@%$exec_prefix%g
s%@prefix@%$prefix%g
s%@program_transform_name@%$program_transform_name%g
s%@bindir@%$bindir%g
s%@sbindir@%$sbindir%g
s%@libexecdir@%$libexecdir%g
s%@datadir@%$datadir%g
s%@sysconfdir@%$sysconfdir%g
s%@sharedstatedir@%$sharedstatedir%g
s%@localstatedir@%$localstatedir%g
s%@libdir@%$libdir%g
s%@includedir@%$includedir%g
s%@oldincludedir@%$oldincludedir%g
s%@infodir@%$infodir%g
s%@mandir@%$mandir%g
s%@TCL_WIN_VERSION@%$TCL_WIN_VERSION%g
s%@CC@%$CC%g
s%@TCL_VERSION@%$TCL_VERSION%g
s%@TCL_PATCH_LEVEL@%$TCL_PATCH_LEVEL%g
s%@TCL_SRC_DIR@%$TCL_SRC_DIR%g
s%@TCL_BIN_DIR@%$TCL_BIN_DIR%g
CEOF
EOF
cat >> $CONFIG_STATUS <<\EOF
# Split the substitutions into bite-sized pieces for seds with
# small command number limits, like on Digital OSF/1 and HP-UX.
ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script.
ac_file=1 # Number of current file.
ac_beg=1 # First line for current file.
ac_end=$ac_max_sed_cmds # Line after last line for current file.
ac_more_lines=:
ac_sed_cmds=""
while $ac_more_lines; do
if test $ac_beg -gt 1; then
sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file
else
sed "${ac_end}q" conftest.subs > conftest.s$ac_file
fi
if test ! -s conftest.s$ac_file; then
ac_more_lines=false
rm -f conftest.s$ac_file
else
if test -z "$ac_sed_cmds"; then
ac_sed_cmds="sed -f conftest.s$ac_file"
else
ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file"
fi
ac_file=`expr $ac_file + 1`
ac_beg=$ac_end
ac_end=`expr $ac_end + $ac_max_sed_cmds`
fi
done
if test -z "$ac_sed_cmds"; then
ac_sed_cmds=cat
fi
EOF
cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF
for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
# Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
case "$ac_file" in
*:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'`
ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
*) ac_file_in="${ac_file}.in" ;;
esac
# Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories.
# Remove last slash and all that follows it. Not all systems have dirname.
ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
# The file is in a subdirectory.
test ! -d "$ac_dir" && mkdir "$ac_dir"
ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`"
# A "../" for each directory in $ac_dir_suffix.
ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'`
else
ac_dir_suffix= ac_dots=
fi
case "$ac_given_srcdir" in
.) srcdir=.
if test -z "$ac_dots"; then top_srcdir=.
else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;;
/*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;;
*) # Relative path.
srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix"
top_srcdir="$ac_dots$ac_given_srcdir" ;;
esac
echo creating "$ac_file"
rm -f "$ac_file"
configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
case "$ac_file" in
*Makefile*) ac_comsub="1i\\
# $configure_input" ;;
*) ac_comsub= ;;
esac
ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
sed -e "$ac_comsub
s%@configure_input@%$configure_input%g
s%@srcdir@%$srcdir%g
s%@top_srcdir@%$top_srcdir%g
" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file
fi; done
rm -f conftest.s*
EOF
cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF
exit 0
EOF
chmod +x $CONFIG_STATUS
rm -fr confdefs* $ac_clean_files
test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
tcl8.4.20/tools/man2tcl.c 0000644 0036047 0045461 00000020502 11737050675 013563 0 ustar dgp 771div /*
* man2tcl.c --
*
* This file contains a program that turns a man page of the
* form used for Tcl and Tk into a Tcl script that invokes
* a Tcl command for each construct in the man page. The
* script can then be eval'ed to translate the manual entry
* into some other format such as MIF or HTML.
*
* Usage:
*
* man2tcl ?fileName?
*
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
static char sccsid[] = "@(#) man2tcl.c 1.3 95/08/12 17:34:08";
#include
#include
#include
#ifndef NO_ERRNO_H
#include
#endif
/*
* Imported things that aren't defined in header files:
*/
/*
* Some define errno to be something complex and
* thread-aware; in that case we definitely do not want to declare
* errno ourselves!
*/
#ifndef errno
extern int errno;
#endif
/*
* Current line number, used for error messages.
*/
static int lineNumber;
/*
* The variable below is set to 1 if an error occurs anywhere
* while reading in the file.
*/
static int status;
/*
* The variable below is set to 1 if output should be generated.
* If it's 0, it means we're doing a pre-pass to make sure that
* the file can be properly parsed.
*/
static int writeOutput;
/*
* Prototypes for procedures defined in this file:
*/
static void DoMacro(char *line);
static void DoText(char *line);
static void QuoteText(char *string, int count);
/*
*----------------------------------------------------------------------
*
* main --
*
* This procedure is the main program, which does all of the work
* of the program.
*
* Results:
* None: exits with a 0 return status to indicate success, or
* 1 to indicate that there were problems in the translation.
*
* Side effects:
* A Tcl script is output to standard output. Error messages may
* be output on standard error.
*
*----------------------------------------------------------------------
*/
int
main(argc, argv)
int argc; /* Number of command-line arguments. */
char **argv; /* Values of command-line arguments. */
{
FILE *f;
#define MAX_LINE_SIZE 1000
char line[MAX_LINE_SIZE];
char *p;
/*
* Find the file to read, and open it if it isn't stdin.
*/
if (argc == 1) {
f = stdin;
} else if (argc == 2) {
f = fopen(argv[1], "r");
if (f == NULL) {
fprintf(stderr, "Couldn't read \"%s\": %s\n", argv[1],
strerror(errno));
exit(1);
}
} else {
fprintf(stderr, "Usage: %s ?fileName?\n", argv[0]);
}
/*
* Make two passes over the file. In the first pass, just check
* to make sure we can handle everything. If there are problems,
* generate output and stop. If everything is OK, make a second
* pass to actually generate output.
*/
for (writeOutput = 0; writeOutput < 2; writeOutput++) {
lineNumber = 0;
status = 0;
while (fgets(line, MAX_LINE_SIZE, f) != NULL) {
for (p = line; *p != 0; p++) {
if (*p == '\n') {
*p = 0;
break;
}
}
lineNumber++;
if ((line[0] == '\'') && (line[1] == '\\') && (line[2] == '\"')) {
/*
* This line is a comment. Ignore it.
*/
continue;
}
if (strlen(line) >= MAX_LINE_SIZE -1) {
fprintf(stderr, "Too long line. Max is %d chars.\n",
MAX_LINE_SIZE - 1);
exit(1);
}
if ((line[0] == '.') || (line[0] == '\'')) {
/*
* This line is a macro invocation.
*/
DoMacro(line);
} else {
/*
* This line is text, possibly with formatting characters
* embedded in it.
*/
DoText(line);
}
}
if (status != 0) {
break;
}
fseek(f, 0, SEEK_SET);
}
exit(status);
}
/*
*----------------------------------------------------------------------
*
* DoMacro --
*
* This procedure is called to handle a macro invocation.
* It parses the arguments to the macro and generates a
* Tcl command to handle the invocation.
*
* Results:
* None.
*
* Side effects:
* A Tcl command is written to stdout.
*
*----------------------------------------------------------------------
*/
static void
DoMacro(line)
char *line; /* The line of text that contains the
* macro invocation. */
{
char *p, *end;
/*
* If there is no macro name, then just skip the whole line.
*/
if ((line[1] == 0) || (isspace(line[1]))) {
return;
}
if (writeOutput) {
printf("macro");
}
if (*line != '.') {
if (writeOutput) {
printf("2");
}
}
/*
* Parse the arguments to the macro (including the name), in order.
*/
p = line+1;
while (1) {
if (writeOutput) {
putc(' ', stdout);
}
if (*p == '"') {
/*
* The argument is delimited by quotes.
*/
for (end = p+1; *end != '"'; end++) {
if (*end == 0) {
fprintf(stderr,
"Unclosed quote in macro call on line %d.\n",
lineNumber);
status = 1;
break;
}
}
QuoteText(p+1, (end-(p+1)));
} else {
for (end = p+1; (*end != 0) && !isspace(*end); end++) {
/* Empty loop body. */
}
QuoteText(p, end-p);
}
if (*end == 0) {
break;
}
p = end+1;
while (isspace(*p)) {
/*
* Skip empty space before next argument.
*/
p++;
}
if (*p == 0) {
break;
}
}
if (writeOutput) {
putc('\n', stdout);
}
}
/*
*----------------------------------------------------------------------
*
* DoText --
*
* This procedure is called to handle a line of troff text.
* It parses the text, generating Tcl commands for text and
* for formatting stuff such as font changes.
*
* Results:
* None.
*
* Side effects:
* Tcl commands are written to stdout.
*
*----------------------------------------------------------------------
*/
static void
DoText(line)
char *line; /* The line of text. */
{
char *p, *end;
/*
* Divide the line up into pieces consisting of backslash sequences,
* tabs, and other text.
*/
p = line;
while (*p != 0) {
if (*p == '\t') {
if (writeOutput) {
printf("tab\n");
}
p++;
} else if (*p != '\\') {
/*
* Ordinary text.
*/
for (end = p+1; (*end != '\\') && (*end != 0); end++) {
/* Empty loop body. */
}
if (writeOutput) {
printf("text ");
}
QuoteText(p, end-p);
if (writeOutput) {
putc('\n', stdout);
}
p = end;
} else {
/*
* A backslash sequence. There are particular ones
* that we understand; output an error message for
* anything else and just ignore the backslash.
*/
p++;
if (*p == 'f') {
/*
* Font change.
*/
if (writeOutput) {
printf("font %c\n", p[1]);
}
p += 2;
} else if (*p == '-') {
if (writeOutput) {
printf("dash\n");
}
p++;
} else if (*p == 'e') {
if (writeOutput) {
printf("text \\\\\n");
}
p++;
} else if (*p == '.') {
if (writeOutput) {
printf("text .\n");
}
p++;
} else if (*p == '&') {
p++;
} else if (*p == '(') {
if ((p[1] == 0) || (p[2] == 0)) {
fprintf(stderr, "Bad \\( sequence on line %d.\n",
lineNumber);
status = 1;
} else {
if (writeOutput) {
printf("char {\\(%c%c}\n", p[1], p[2]);
}
p += 3;
}
} else if (*p != 0) {
if (writeOutput) {
printf("char {\\%c}\n", *p);
}
p++;
}
}
}
if (writeOutput) {
printf("newline\n");
}
}
/*
*----------------------------------------------------------------------
*
* QuoteText --
*
* Copy the "string" argument to stdout, adding quote characters
* around any special Tcl characters so that they'll just be treated
* as ordinary text.
*
* Results:
* None.
*
* Side effects:
* Text is written to stdout.
*
*----------------------------------------------------------------------
*/
static void
QuoteText(string, count)
char *string; /* The line of text. */
int count; /* Number of characters to write from string. */
{
if (count == 0) {
if (writeOutput) {
printf("{}");
}
return;
}
for ( ; count > 0; string++, count--) {
if ((*string == '$') || (*string == '[') || (*string == '{')
|| (*string == ' ') || (*string == ';') || (*string == '\\')
|| (*string == '"') || (*string == '\t')) {
if (writeOutput) {
putc('\\', stdout);
}
}
if (writeOutput) {
putc(*string, stdout);
}
}
}
tcl8.4.20/tools/cvtEOL.tcl 0000644 0036047 0045461 00000001560 11737050674 013721 0 ustar dgp 771div # cvtEOL.tcl --
#
# This file contains a script to parse a Tcl/Tk distribution and
# convert the EOL from \n to \r on all text files.
#
# Copyright (c) 1996-1997 by Sun Microsystems, Inc.
#
# Convert files in the distribution to Mac style
#
set distDir [lindex $argv 0]
set dirs {unix mac generic win library compat tests unix/dltest \
library/demos library/demos/images bitmaps xlib xlib/X11 .}
set files {*.c *.y *.h *.r *.tcl *.test *.rc *.bc *.vc *.bmp *.html \
*.in *.notes *.terms all defs \
README ToDo changes tclIndex configure install-sh mkLinks \
square widget rmt ixset hello browse rolodex tcolor timer}
foreach x $dirs {
if [catch {cd $distDir/$x}] continue
puts "Working on $x..."
foreach y [eval glob $files] {
exec chmod 666 $y
exec cp $y $y.tmp
exec tr \012 \015 < $y.tmp > $y
exec chmod 444 $y
exec rm $y.tmp
}
}
tcl8.4.20/tools/man2help.tcl 0000644 0036047 0045461 00000006264 11737050675 014302 0 ustar dgp 771div # man2help.tcl --
#
# This file defines procedures that work in conjunction with the
# man2tcl program to generate a Windows help file from Tcl manual
# entries.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
#
# PASS 1
#
set man2tclprog [file join [file dirname [info script]] man2tcl.exe]
proc generateContents {basename version files} {
global curID topics
set curID 0
foreach f $files {
puts "Pass 1 -- $f"
flush stdout
doFile $f
}
set fd [open [file join [file dirname [info script]] $basename$version.cnt] w]
fconfigure $fd -translation crlf
puts $fd ":Base $basename$version.hlp"
foreach package [getPackages] {
foreach section [getSections $package] {
if {![info exists lastSection]} {
set lastSection {}
}
if {[string compare $lastSection $section]} {
puts $fd "1 $section"
}
set lastSection $section
set lastTopic {}
foreach topic [getTopics $package $section] {
if {[string compare $lastTopic $topic]} {
set id $topics($package,$section,$topic)
puts $fd "2 $topic=$id"
set lastTopic $topic
}
}
}
}
close $fd
}
#
# PASS 2
#
proc generateHelp {basename files} {
global curID topics keywords file id_keywords
set curID 0
foreach key [array names keywords] {
foreach id $keywords($key) {
lappend id_keywords($id) $key
}
}
set file [open [file join [file dirname [info script]] $basename.rtf] w]
fconfigure $file -translation crlf
puts $file "\{\\rtf1\\ansi \\deff0\\deflang1033\{\\fonttbl\{\\f0\\froman\\fcharset0\\fprq2 Times New Roman\;\}\{\\f1\\fmodern\\fcharset0\\fprq1 Courier New\;\}\}"
foreach f $files {
puts "Pass 2 -- $f"
flush stdout
initGlobals
doFile $f
pageBreak
}
puts $file "\}"
close $file
}
# doFile --
#
# Given a file as argument, translate the file to a tcl script and
# evaluate it.
#
# Arguments:
# file - Name of file to translate.
proc doFile {file} {
global man2tclprog
if {[catch {eval [exec $man2tclprog [glob $file]]} msg]} {
global errorInfo
puts stderr $msg
puts "in"
puts $errorInfo
exit 1
}
}
# doDir --
#
# Given a directory as argument, translate all the man pages in
# that directory.
#
# Arguments:
# dir - Name of the directory.
proc doDir dir {
puts "Generating man pages for $dir..."
foreach f [lsort [glob -directory $dir "*.\[13n\]"]] {
doFile $f
}
}
# process command line arguments
if {$argc < 3} {
puts stderr "usage: $argv0 \[options\] projectName version manFiles..."
exit 1
}
set arg 0
if {![string compare [lindex $argv $arg] "-bitmap"]} {
set bitmap [lindex $argv [incr arg]]
incr arg
}
set baseName [lindex $argv $arg]
set version [lindex $argv [incr arg]]
set files {}
foreach i [lrange $argv [incr arg] end] {
set i [file join $i]
if {[file isdir $i]} {
foreach f [lsort [glob -directory $i "*.\[13n\]"]] {
lappend files $f
}
} elseif {[file exists $i]} {
lappend files $i
}
}
source [file join [file dirname [info script]] index.tcl]
generateContents $baseName $version $files
source [file join [file dirname [info script]] man2help2.tcl]
generateHelp $baseName $files
tcl8.4.20/tools/tcl.wse.in 0000644 0036047 0045461 00000211517 12153151143 013757 0 ustar dgp 771div Document Type: WSE
item: Global
Version=6.01
Title=Tcl 8.4 for Windows Installation
Flags=00010100
Languages=65 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
Japanese Font Name=MS Gothic
Japanese Font Size=10
Start Gradient=0 0 255
End Gradient=0 0 0
Windows Flags=00000000000000010010110000001000
Log Pathname=%MAINDIR%\INSTALL.LOG
Message Font=MS Sans Serif
Font Size=8
Disk Label=tcl8.4.20
Disk Filename=setup
Patch Flags=0000000000000001
Patch Threshold=85
Patch Memory=4000
Variable Name1=_SYS_
Variable Default1=C:\WINDOWS\SYSTEM
Variable Flags1=00001000
Variable Name2=_ODBC16_
Variable Default2=C:\WINDOWS\SYSTEM
Variable Flags2=00001000
Variable Name3=_WISE_
Variable Default3=${__WISE__}
Variable Flags3=00001000
end
item: Open/Close INSTALL.LOG
Flags=00000001
end
item: Check if File/Dir Exists
Pathname=%SYS%
Flags=10000100
end
item: Set Variable
Variable=SYS
Value=%WIN%
end
item: End Block
end
item: Set Variable
Variable=VER
Value=8.4
end
item: Set Variable
Variable=PATCHLEVEL
Value=${__TCL_PATCH_LEVEL__}
end
item: Set Variable
Variable=APPTITLE
Value=Tcl/Tk %PATCHLEVEL% for Windows
end
item: Set Variable
Variable=URL
Value=http://www.tcl.tk/
end
item: Set Variable
Variable=GROUP
Value=Tcl
end
item: Set Variable
Variable=DISABLED
Value=!
end
item: Set Variable
Variable=MAINDIR
Value=Tcl
end
item: Check Configuration
Flags=10111011
end
item: Get Registry Key Value
Variable=PROGRAM_FILES
Key=SOFTWARE\Microsoft\Windows\CurrentVersion
Default=C:\Program Files
Value Name=ProgramFilesDir
Flags=00000100
end
item: Set Variable
Variable=MAINDIR
Value=%PROGRAM_FILES%\%MAINDIR%
end
item: Set Variable
Variable=EXPLORER
Value=1
end
item: Else Statement
end
item: Set Variable
Variable=MAINDIR
Value=C:\%MAINDIR%
end
item: End Block
end
item: Set Variable
Variable=BACKUP
Value=%MAINDIR%\BACKUP
end
item: Set Variable
Variable=DOBACKUP
Value=B
end
item: Set Variable
Variable=BRANDING
Value=0
end
remarked item: If/While Statement
Variable=BRANDING
Value=1
end
remarked item: Read INI Value
Variable=NAME
Pathname=%INST%\CUSTDATA.INI
Section=Registration
Item=Name
end
remarked item: Read INI Value
Variable=COMPANY
Pathname=%INST%\CUSTDATA.INI
Section=Registration
Item=Company
end
remarked item: If/While Statement
Variable=NAME
end
remarked item: Set Variable
Variable=DOBRAND
Value=1
end
remarked item: End Block
end
remarked item: End Block
end
item: Set Variable
Variable=TYPE
Value=C
end
item: Set Variable
Variable=COMPONENTS
Value=ABC
end
item: Wizard Block
Direction Variable=DIRECTION
Display Variable=DISPLAY
X Position=0
Y Position=0
Filler Color=8421440
Flags=00000001
end
item: Custom Dialog Set
Name=Splash
Display Variable=DISPLAY
item: Dialog
Title=%APPTITLE% Installation
Title French=Bienvenue
Title German=Willkommen
Title Portuguese=Bem-vindo
Title Spanish=Bienvenido
Title Italian=Benvenuto
Title Danish=Velkommen
Title Dutch=Welkom
Title Norwegian=Velkommen
Title Swedish=VУЏТПТНlkommen
Width=273
Height=250
Font Name=Helv
Font Size=8
item: Push Button
Rectangle=166 214 208 228
Variable=DIRECTION
Value=N
Create Flags=01010000000000010000000000000001
Text=&Next >
end
item: Push Button
Rectangle=212 214 254 228
Action=3
Create Flags=01010000000000010000000000000000
Text=Cancel
end
item: Static
Rectangle=0 0 268 233
Action=2
Enabled Color=00000000000000001111111111111111
Create Flags=01010000000000000000000000001011
Pathname=${__TCLBASEDIR__}\tools\white.bmp
end
item: Static
Rectangle=5 5 268 215
Destination Dialog=1
Action=2
Enabled Color=00000000000000001111111111111111
Create Flags=01010000000000000000000000001011
Pathname=${__TCLBASEDIR__}\tools\tclSplash.bmp
end
end
end
item: End Block
end
item: Wizard Block
Direction Variable=DIRECTION
Display Variable=DISPLAY
Bitmap Pathname=%_WISE_%\DIALOGS\TEMPLATE\WIZARD.BMP
X Position=9
Y Position=10
Filler Color=8421440
Dialog=Welcome
Dialog=Select Destination Directory
Dialog=Select Installation Type
Dialog=Select Components
Dialog=Select Program Manager Group
Variable=
Variable=
Variable=
Variable=TYPE
Variable=EXPLORER
Value=
Value=
Value=
Value=C
Value=1
Compare=0
Compare=0
Compare=0
Compare=1
Compare=0
Flags=00000011
end
item: Custom Dialog Set
Name=Welcome
Display Variable=DISPLAY
item: Dialog
Title=%APPTITLE% Installation
Title French=Installation de %APPTITLE%
Title German=Installation von %APPTITLE%
Title Spanish=InstalaciУЏТПТНn de %APPTITLE%
Title Italian=Installazione di %APPTITLE%
Width=271
Height=224
Font Name=Helv
Font Size=8
item: Static
Rectangle=86 8 258 42
Create Flags=01010000000000000000000000000000
Flags=0000000000000001
Name=Times New Roman
Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
Text=Welcome!
Text French=Bienvenue !
Text German=Willkommen!
Text Spanish=УЏТПТНBienvenido!
Text Italian=Benvenuti!
end
item: Push Button
Rectangle=150 187 195 202
Variable=DIRECTION
Value=N
Create Flags=01010000000000010000000000000001
Text=&Next >
Text French=&Suite >
Text German=&Weiter >
Text Spanish=&Siguiente >
Text Italian=&Avanti >
end
item: Push Button
Rectangle=105 187 150 202
Variable=DISABLED
Value=!
Create Flags=01010000000000010000000000000000
Text=< &Back
Text French=< &Retour
Text German=< &ZurУЏТПТНck
Text Spanish=< &AtrУЏТПТНs
Text Italian=< &Indietro
end
item: Push Button
Rectangle=211 187 256 202
Action=3
Create Flags=01010000000000010000000000000000
Text=&Cancel
Text French=&Annuler
Text German=&Abbrechen
Text Spanish=&Cancelar
Text Italian=&Annulla
end
item: Static
Rectangle=85 41 255 130
Create Flags=01010000000000000000000000000000
Text=This installation program will install %APPTITLE%.
Text=
Text=Press the Next button to start the installation. You can press the Exit Setup button now if you do not want to install %APPTITLE% at this time.
Text=
Text=It is strongly recommended that you exit all Windows programs before running this installation program.
Text French=Ce programme d'installation va installer %APPTITLE%.
Text French=
Text French=Cliquez sur le bouton Suite pour dУЏТПТНmarrer l'installation. Vous pouvez cliquer sur le bouton Quitter l'installation si vous ne voulez pas installer %APPTITLE% tout de suite.
Text German=Mit diesem Installationsprogramm wird %APPTITLE% installiert.
Text German=
Text German=Klicken Sie auf "Weiter", um mit der Installation zu beginnen. Klicken Sie auf "Abbrechen", um die Installation von %APPTITLE% abzubrechen.
Text Spanish=Este programa de instalaciУЏТПТНn instalarУЏТПТН %APPTITLE%.
Text Spanish=
Text Spanish=Presione el botУЏТПТНn Siguiente para iniciar la instalaciУЏТПТНn. Puede presionar el botУЏТПТНn Salir de instalaciУЏТПТНn si no desea instalar %APPTITLE% en este momento.
Text Italian=Questo programma installerУЏТПТН %APPTITLE%.
Text Italian=
Text Italian=Per avvviare l'installazione premere il pulsante Avanti. Se non si desidera installare %APPTITLE% ora, premere il pulsante Esci dall'installazione.
end
item: Static
Rectangle=8 180 256 181
Action=3
Create Flags=01010000000000000000000000000111
end
end
end
item: Custom Dialog Set
Name=Select Destination Directory
Display Variable=DISPLAY
item: Dialog
Title=%APPTITLE% Installation
Title French=Installation de %APPTITLE%
Title German=Installation von %APPTITLE%
Title Spanish=InstalaciУЏТПТНn de %APPTITLE%
Title Italian=Installazione di %APPTITLE%
Width=271
Height=224
Font Name=Helv
Font Size=8
item: Push Button
Rectangle=150 187 195 202
Variable=DIRECTION
Value=N
Create Flags=01010000000000010000000000000001
Text=&Next >
Text French=&Suite >
Text German=&Weiter >
Text Spanish=&Siguiente >
Text Italian=&Avanti >
end
item: Push Button
Rectangle=105 187 150 202
Variable=DIRECTION
Value=B
Create Flags=01010000000000010000000000000000
Flags=0000000000000001
Text=< &Back
Text French=< &Retour
Text German=< &ZurУЏТПТНck
Text Spanish=< &AtrУЏТПТНs
Text Italian=< &Indietro
end
item: Push Button
Rectangle=211 187 256 202
Action=3
Create Flags=01010000000000010000000000000000
Text=&Cancel
Text French=&Annuler
Text German=&Abbrechen
Text Spanish=&Cancelar
Text Italian=&Annulla
end
item: Static
Rectangle=8 180 256 181
Action=3
Create Flags=01010000000000000000000000000111
end
item: Static
Rectangle=86 8 258 42
Create Flags=01010000000000000000000000000000
Flags=0000000000000001
Name=Times New Roman
Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
Text=Select Destination Directory
Text French=SУЏТПТНlectionner le rУЏТПТНpertoire de destination
Text German=Zielverzeichnis wУЏТПТНhlen
Text Spanish=Seleccione el directorio de destino
Text Italian=Selezionare Directory di destinazione
end
item: Static
Rectangle=86 39 256 114
Create Flags=01010000000000000000000000000000
Text=Please select the directory where the %APPTITLE% files are to be installed.
Text=
Text=To install in the default directory below, click Next.
Text=
Text=To install in a different directory, click Browse and select another directory.
Text French=Veuillez sУЏТПТНlectionner le rУЏТПТНpertoire dans lequel les fichiers %APPTITLE% doivent УЏТПТНtre installУЏТПТНs.
Text German=Geben Sie an, in welchem Verzeichnis die %APPTITLE%-Dateien installiert werden sollen.
Text Spanish=Por favor seleccione el directorio donde desee instalar los archivos de %APPTITLE%.
Text Italian=Selezionare la directory dove verranno installati i file %APPTITLE%.
end
item: Static
Rectangle=86 130 256 157
Action=1
Create Flags=01010000000000000000000000000111
end
item: Push Button
Rectangle=205 138 250 153
Variable=MAINDIR_SAVE
Value=%MAINDIR%
Destination Dialog=1
Action=2
Create Flags=01010000000000010000000000000000
Text=Browse
Text French=Parcourir
Text German=Durchsuchen
Text Spanish=Buscar
Text Italian=Sfoglie
end
item: Static
Rectangle=91 140 198 151
Create Flags=01010000000000000000000000000000
Text=%MAINDIR%
Text French=%MAINDIR%
Text German=%MAINDIR%
Text Spanish=%MAINDIR%
Text Italian=%MAINDIR%
end
end
item: Dialog
Title=Select Destination Directory
Title French=SУЏТПТНlectionner le rУЏТПТНpertoire de destination
Title German=Zielverzeichnis wУЏТПТНhlen
Title Spanish=Seleccione el directorio de destino
Title Italian=Selezionare Directory di destinazione
Width=221
Height=173
Font Name=Helv
Font Size=8
item: Listbox
Rectangle=5 5 163 149
Variable=MAINDIR
Create Flags=01010000100000010000000101000000
Flags=0000110000100010
Text=%MAINDIR%
Text French=%MAINDIR%
Text German=%MAINDIR%
Text Spanish=%MAINDIR%
Text Italian=%MAINDIR%
end
item: Push Button
Rectangle=167 6 212 21
Create Flags=01010000000000010000000000000001
Text=OK
Text French=OK
Text German=OK
Text Spanish=Aceptar
Text Italian=OK
end
item: Push Button
Rectangle=167 25 212 40
Variable=MAINDIR
Value=%MAINDIR_SAVE%
Create Flags=01010000000000010000000000000000
Flags=0000000000000001
Text=Cancel
Text French=Annuler
Text German=Abbrechen
Text Spanish=Cancelar
Text Italian=Annulla
end
end
end
remarked item: Custom Dialog Set
Name=Select Installation Type
Display Variable=DISPLAY
item: Dialog
Title=%APPTITLE% Installation
Title French=Installation de %APPTITLE%
Title German=Installation von %APPTITLE%
Title Spanish=InstalaciУЏТПТНn de %APPTITLE%
Title Italian=Installazione di %APPTITLE%
Width=271
Height=224
Font Name=Helv
Font Size=8
item: Push Button
Rectangle=150 187 195 202
Variable=DIRECTION
Value=N
Create Flags=01010000000000010000000000000001
Text=&Next >
Text French=&Suite >
Text German=&Weiter >
Text Spanish=&Siguiente >
Text Italian=&Avanti >
end
item: Push Button
Rectangle=105 187 150 202
Variable=DIRECTION
Value=B
Create Flags=01010000000000010000000000000000
Text=< &Back
Text French=< &Retour
Text German=< &ZurУЏТПТНck
Text Spanish=< &AtrУЏТПТНs
Text Italian=< &Indietro
end
item: Push Button
Rectangle=211 187 256 202
Action=3
Create Flags=01010000000000010000000000000000
Text=&Cancel
Text French=&Annuler
Text German=&Abbrechen
Text Spanish=&Cancelar
Text Italian=&Annulla
end
item: Static
Rectangle=8 180 256 181
Action=3
Create Flags=01010000000000000000000000000111
end
item: Static
Rectangle=86 8 258 42
Create Flags=01010000000000000000000000000000
Flags=0000000000000001
Name=Times New Roman
Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
Text=Select Installation Type
Text French=SУЏТПТНlectionner les composants
Text German=Komponenten auswУЏТПТНhlen
Text Spanish=Seleccione componentes
Text Italian=Selezionare i componenti
end
item: Static
Rectangle=194 162 242 172
Variable=COMPONENTS
Value=MAINDIR
Create Flags=01010000000000000000000000000010
end
item: Static
Rectangle=194 153 242 162
Variable=COMPONENTS
Create Flags=01010000000000000000000000000010
end
item: Static
Rectangle=107 153 196 164
Create Flags=01010000000000000000000000000000
Text=Disk Space Required:
Text French=Espace disque requis :
Text German=Notwendiger Speicherplatz:
Text Spanish=Espacio requerido en el disco:
Text Italian=Spazio su disco necessario:
end
item: Static
Rectangle=107 162 196 172
Create Flags=01010000000000000000000000000000
Text=Disk Space Remaining:
Text French=Espace disque disponible :
Text German=Verbleibender Speicherplatz:
Text Spanish=Espacio en disco disponible:
Text Italian=Spazio su disco disponibile:
end
item: Static
Rectangle=86 145 256 175
Action=1
Create Flags=01010000000000000000000000000111
end
item: Static
Rectangle=86 42 256 61
Create Flags=01010000000000000000000000000000
Text=Choose which type of installation to perform by selecting one of the buttons below.
Text French=Choisissez les composants que vous voulez installer en cochant les cases ci-dessous.
Text German=WУЏТПТНhlen Sie die zu installierenden Komponenten, indem Sie in die entsprechenden KУЏТПТНstchen klicken.
Text Spanish=Elija los componentes que desee instalar marcando los cuadros de abajo.
Text Italian=Scegliere quali componenti installare selezionando le caselle sottostanti.
end
item: Radio Button
Rectangle=86 74 256 128
Variable=TYPE
Create Flags=01010000000000010000000000001001
Text=&Full Installation (Recommended)
Text=&Minimal Installation
Text=C&ustom Installation
Text=
end
end
end
item: Custom Dialog Set
Name=Select Components
Display Variable=DISPLAY
item: Dialog
Title=%APPTITLE% Installation
Title French=Installation de %APPTITLE%
Title German=Installation von %APPTITLE%
Title Spanish=InstalaciУЏТПТНn de %APPTITLE%
Title Italian=Installazione di %APPTITLE%
Width=271
Height=224
Font Name=Helv
Font Size=8
item: Push Button
Rectangle=150 187 195 202
Variable=DIRECTION
Value=N
Create Flags=01010000000000010000000000000001
Text=&Next >
Text French=&Suite >
Text German=&Weiter >
Text Spanish=&Siguiente >
Text Italian=&Avanti >
end
item: Push Button
Rectangle=105 187 150 202
Variable=DIRECTION
Value=B
Create Flags=01010000000000010000000000000000
Text=< &Back
Text French=< &Retour
Text German=< &ZurУЏТПТНck
Text Spanish=< &AtrУЏТПТНs
Text Italian=< &Indietro
end
item: Push Button
Rectangle=211 187 256 202
Action=3
Create Flags=01010000000000010000000000000000
Text=&Cancel
Text French=&Annuler
Text German=&Abbrechen
Text Spanish=&Cancelar
Text Italian=&Annulla
end
item: Static
Rectangle=8 180 256 181
Action=3
Create Flags=01010000000000000000000000000111
end
item: Static
Rectangle=86 8 258 42
Create Flags=01010000000000000000000000000000
Flags=0000000000000001
Name=Times New Roman
Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
Text=Select Components
Text French=SУЏТПТНlectionner les composants
Text German=Komponenten auswУЏТПТНhlen
Text Spanish=Seleccione componentes
Text Italian=Selezionare i componenti
end
item: Checkbox
Rectangle=86 75 256 129
Variable=COMPONENTS
Create Flags=01010000000000010000000000000011
Flags=0000000000000110
Text=Tcl Run-Time Files
Text=Example Scripts
Text=Help Files
Text=Header and Library Files
Text=
Text French=Tcl Run-Time Files
Text French=Example Scripts
Text French=Help Files
Text French=Header and Library Files
Text French=
Text German=Tcl Run-Time Files
Text German=Example Scripts
Text German=Help Files
Text German=Header and Library Files
Text German=
Text Spanish=Tcl Run-Time Files
Text Spanish=Example Scripts
Text Spanish=Help Files
Text Spanish=Header and Library Files
Text Spanish=
Text Italian=Tcl Run-Time Files
Text Italian=Example Scripts
Text Italian=Help Files
Text Italian=Header and Library Files
Text Italian=
end
item: Static
Rectangle=194 162 242 172
Variable=COMPONENTS
Value=MAINDIR
Create Flags=01010000000000000000000000000010
end
item: Static
Rectangle=194 153 242 162
Variable=COMPONENTS
Create Flags=01010000000000000000000000000010
end
item: Static
Rectangle=107 153 196 164
Create Flags=01010000000000000000000000000000
Text=Disk Space Required:
Text French=Espace disque requis :
Text German=Notwendiger Speicherplatz:
Text Spanish=Espacio requerido en el disco:
Text Italian=Spazio su disco necessario:
end
item: Static
Rectangle=107 162 196 172
Create Flags=01010000000000000000000000000000
Text=Disk Space Remaining:
Text French=Espace disque disponible :
Text German=Verbleibender Speicherplatz:
Text Spanish=Espacio en disco disponible:
Text Italian=Spazio su disco disponibile:
end
item: Static
Rectangle=86 145 256 175
Action=1
Create Flags=01010000000000000000000000000111
end
item: Static
Rectangle=86 42 256 61
Create Flags=01010000000000000000000000000000
Text=Choose which components to install by checking the boxes below.
Text French=Choisissez les composants que vous voulez installer en cochant les cases ci-dessous.
Text German=WУЏТПТНhlen Sie die zu installierenden Komponenten, indem Sie in die entsprechenden KУЏТПТНstchen klicken.
Text Spanish=Elija los componentes que desee instalar marcando los cuadros de abajo.
Text Italian=Scegliere quali componenti installare selezionando le caselle sottostanti.
end
end
end
item: Custom Dialog Set
Name=Select Program Manager Group
Display Variable=DISPLAY
item: Dialog
Title=%APPTITLE% Installation
Title French=Installation de %APPTITLE%
Title German=Installation von %APPTITLE%
Title Spanish=InstalaciУЏТПТНn de %APPTITLE%
Title Italian=Installazione di %APPTITLE%
Width=271
Height=224
Font Name=Helv
Font Size=8
item: Push Button
Rectangle=150 187 195 202
Variable=DIRECTION
Value=N
Create Flags=01010000000000010000000000000001
Text=&Next >
Text French=&Suite >
Text German=&Weiter >
Text Spanish=&Siguiente >
Text Italian=&Avanti >
end
item: Push Button
Rectangle=105 187 150 202
Variable=DIRECTION
Value=B
Create Flags=01010000000000010000000000000000
Flags=0000000000000001
Text=< &Back
Text French=< &Retour
Text German=< &ZurУЏТПТНck
Text Spanish=< &AtrУЏТПТНs
Text Italian=< &Indietro
end
item: Push Button
Rectangle=211 187 256 202
Action=3
Create Flags=01010000000000010000000000000000
Text=&Cancel
Text French=&Annuler
Text German=&Abbrechen
Text Spanish=&Cancelar
Text Italian=&Annulla
end
item: Static
Rectangle=8 180 256 181
Action=3
Create Flags=01010000000000000000000000000111
end
item: Static
Rectangle=86 8 258 42
Create Flags=01010000000000000000000000000000
Flags=0000000000000001
Name=Times New Roman
Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
Text=Select ProgMan Group
Text French=SУЏТПТНlectionner le groupe du Gestionnaire de programme
Text German=Bestimmung der Programm-Managergruppe
Text Spanish=Seleccione grupo del Administrador de programas
Text Italian=Selezionare il gruppo ProgMan
end
item: Static
Rectangle=86 44 256 68
Create Flags=01010000000000000000000000000000
Text=Enter the name of the Program Manager group to add the %APPTITLE% icons to:
Text French=Entrez le nom du groupe du Gestionnaire de programme dans lequel vous souhaitez ajouter les icУЏТПТНnes de %APPTITLE% :
Text German=Geben Sie den Namen der Programmgruppe ein, der das Symbol %APPTITLE% hinzugefУЏТПТНgt werden soll:
Text Spanish=Escriba el nombre del grupo del Administrador de programas en el que desea agregar los iconos de %APPTITLE%:
Text Italian=Inserire il nome del gruppo Program Manager per aggiungere le icone %APPTITLE% a:
end
item: Combobox
Rectangle=86 69 256 175
Variable=GROUP
Create Flags=01010000000000010000001000000001
Flags=0000000000000001
Text=%GROUP%
Text French=%GROUP%
Text German=%GROUP%
Text Spanish=%GROUP%
Text Italian=%GROUP%
end
end
end
item: Custom Dialog Set
Name=Start Installation
Display Variable=DISPLAY
item: Dialog
Title=%APPTITLE% Installation
Title French=Installation de %APPTITLE%
Title German=Installation von %APPTITLE%
Title Spanish=InstalaciУЏТПТНn de %APPTITLE%
Title Italian=Installazione di %APPTITLE%
Width=271
Height=224
Font Name=Helv
Font Size=8
item: Push Button
Rectangle=150 187 195 202
Variable=DIRECTION
Value=N
Create Flags=01010000000000010000000000000001
Text=&Next >
Text French=&Suite >
Text German=&Weiter >
Text Spanish=&Siguiente >
Text Italian=&Avanti >
end
item: Push Button
Rectangle=105 187 150 202
Variable=DIRECTION
Value=B
Create Flags=01010000000000010000000000000000
Text=< &Back
Text French=< &Retour
Text German=< &ZurУЏТПТНck
Text Spanish=< &AtrУЏТПТНs
Text Italian=< &Indietro
end
item: Push Button
Rectangle=211 187 256 202
Action=3
Create Flags=01010000000000010000000000000000
Text=&Cancel
Text French=&Annuler
Text German=&Abbrechen
Text Spanish=&Cancelar
Text Italian=&Annulla
end
item: Static
Rectangle=8 180 256 181
Action=3
Create Flags=01010000000000000000000000000111
end
item: Static
Rectangle=86 8 258 42
Create Flags=01010000000000000000000000000000
Flags=0000000000000001
Name=Times New Roman
Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
Text=Ready to Install!
Text French=PrУЏТПТНt УЏТПТН installer !
Text German=Installationsbereit!
Text Spanish=УЏТПТНPreparado para la instalaciУЏТПТНn!
Text Italian=Pronto per l'installazione!
end
item: Static
Rectangle=86 42 256 102
Create Flags=01010000000000000000000000000000
Text=You are now ready to install %APPTITLE%.
Text=
Text=Press the Next button to begin the installation or the Back button to reenter the installation information.
Text French=Vous УЏТПТНtes maintenant prУЏТПТНt УЏТПТН installer les fichiers %APPTITLE%.
Text French=
Text French=Cliquez sur le bouton Suite pour commencer l'installation ou sur le bouton Retour pour entrer les informations d'installation УЏТПТН nouveau.
Text German=Sie kУЏТПТНnnen %APPTITLE% nun installieren.
Text German=
Text German=Klicken Sie auf "Weiter", um mit der Installation zu beginnen. Klicken Sie auf "ZurУЏТПТНck", um die Installationsinformationen neu einzugeben.
Text Spanish=Ya estУЏТПТН listo para instalar %APPTITLE%.
Text Spanish=
Text Spanish=Presione el botУЏТПТНn Siguiente para comenzar la instalaciУЏТПТНn o presione AtrУЏТПТНs para volver a ingresar la informaciУЏТПТНn para la instalaciУЏТПТНn.
Text Italian=Ora УЏТПТН possibile installare %APPTITLE%.
Text Italian=
Text Italian=Premere il pulsante Avanti per avviare l'installazione o il pulsante Indietro per reinserire le informazioni di installazione.
end
end
end
item: If/While Statement
Variable=DISPLAY
Value=Select Destination Directory
end
item: Set Variable
Variable=BACKUP
Value=%MAINDIR%\BACKUP
end
item: End Block
end
item: End Block
end
item: If/While Statement
Variable=TYPE
Value=B
end
item: Set Variable
Variable=COMPONENTS
Value=A
end
item: End Block
end
item: If/While Statement
Variable=DOBACKUP
Value=A
end
item: Set Variable
Variable=BACKUPDIR
Value=%BACKUP%
end
item: End Block
end
remarked item: If/While Statement
Variable=BRANDING
Value=1
end
remarked item: If/While Statement
Variable=DOBRAND
Value=1
end
remarked item: Edit INI File
Pathname=%INST%\CUSTDATA.INI
Settings=[Registration]
Settings=NAME=%NAME%
Settings=COMPANY=%COMPANY%
Settings=
end
remarked item: End Block
end
remarked item: End Block
end
item: Set Variable
Variable=MAINDIRSHORT
Value=%MAINDIR%
Flags=00010100
end
item: Open/Close INSTALL.LOG
end
item: Check Disk Space
Component=COMPONENTS
end
item: Install File
Source=${__TCLBASEDIR__}\license.txt
Destination=%MAINDIR%\license.txt
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\win\Readme.txt
Destination=%MAINDIR%\Readme.txt
Flags=0000000000000010
end
item: If/While Statement
Variable=COMPONENTS
Value=D
Flags=00001010
end
item: Install File
Source=${__TKBASEDIR__}\win\release\tk84.lib
Destination=%MAINDIR%\lib\tk84.lib
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\win\release\tkstub84.lib
Destination=%MAINDIR%\lib\tkstub84.lib
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\win\release\tcl84.lib
Destination=%MAINDIR%\lib\tcl84.lib
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\win\release\tclstub84.lib
Destination=%MAINDIR%\lib\tclstub84.lib
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\xlib\X11\Xutil.h
Destination=%MAINDIR%\include\X11\Xutil.h
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\xlib\X11\Xlib.h
Destination=%MAINDIR%\include\X11\Xlib.h
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\xlib\X11\Xfuncproto.h
Destination=%MAINDIR%\include\X11\Xfuncproto.h
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\xlib\X11\Xatom.h
Destination=%MAINDIR%\include\X11\Xatom.h
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\xlib\X11\X.h
Destination=%MAINDIR%\include\X11\X.h
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\xlib\X11\keysymdef.h
Destination=%MAINDIR%\include\X11\keysymdef.h
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\xlib\X11\keysym.h
Destination=%MAINDIR%\include\X11\keysym.h
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\xlib\X11\cursorfont.h
Destination=%MAINDIR%\include\X11\cursorfont.h
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\generic\tk.h
Destination=%MAINDIR%\include\tk.h
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\generic\tkDecls.h
Destination=%MAINDIR%\include\tkDecls.h
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\generic\tkPlatDecls.h
Destination=%MAINDIR%\include\tkPlatDecls.h
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\generic\tkIntXlibDecls.h
Destination=%MAINDIR%\include\tkIntXlibDecls.h
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\generic\tcl.h
Destination=%MAINDIR%\include\tcl.h
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\generic\tclDecls.h
Destination=%MAINDIR%\include\tclDecls.h
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\generic\tclPlatDecls.h
Destination=%MAINDIR%\include\tclPlatDecls.h
Flags=0000000000000010
end
item: End Block
end
item: If/While Statement
Variable=COMPONENTS
Value=A
Flags=00001010
end
item: Install File
Source=${__TCLBASEDIR__}\library\msgcat\pkgIndex.tcl
Destination=%MAINDIR%\lib\tcl%VER%\msgcat1.2\pkgIndex.tcl
Flags=0000000010000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\msgcat\msgcat.tcl
Destination=%MAINDIR%\lib\tcl%VER%\msgcat1.2\msgcat.tcl
Flags=0000000010000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\tcltest\pkgIndex.tcl
Destination=%MAINDIR%\lib\tcl%VER%\tcltest2.0\pkgIndex.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\tcltest\tcltest.tcl
Destination=%MAINDIR%\lib\tcl%VER%\tcltest2.0\tcltest.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\symbol.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\symbol.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\shiftjis.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\shiftjis.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macUkraine.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macUkraine.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macTurkish.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macTurkish.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macThai.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macThai.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macRomania.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macRomania.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macRoman.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macRoman.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macJapan.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macJapan.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macIceland.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macIceland.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macGreek.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macGreek.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macDingbats.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macDingbats.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macCyrillic.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macCyrillic.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macCroatian.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macCroatian.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\macCentEuro.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\macCentEuro.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\ksc5601.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\ksc5601.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\koi8-r.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\koi8-r.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\jis0212.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\jis0212.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\jis0208.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\jis0208.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\jis0201.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\jis0201.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-15.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-15.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-9.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-9.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-8.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-8.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-7.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-7.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-6.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-6.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-5.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-5.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-4.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-4.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-3.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-3.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-2.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-2.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso8859-1.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-1.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso2022.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso2022.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso2022-kr.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso2022-kr.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\iso2022-jp.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso2022-jp.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\gb2312.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\gb2312.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\gb1988.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\gb1988.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\gb12345.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\gb12345.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\euc-cn.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\euc-cn.enc
Flags=0000000010000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\euc-jp.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\euc-jp.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\euc-kr.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\euc-kr.enc
Flags=0000000010000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\dingbats.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\dingbats.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp950.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp950.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp949.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp949.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp936.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp936.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp932.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp932.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp874.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp874.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp869.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp869.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp866.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp866.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp865.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp865.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp864.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp864.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp863.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp863.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp862.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp862.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp861.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp861.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp860.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp860.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp857.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp857.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp855.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp855.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp852.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp852.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp850.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp850.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp775.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp775.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp737.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp737.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp437.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp437.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp1258.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1258.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp1257.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1257.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp1256.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1256.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp1255.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1255.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp1254.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1254.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp1253.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1253.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp1252.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1252.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp1251.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1251.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\cp1250.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1250.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\ascii.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\ascii.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\encoding\big5.enc
Destination=%MAINDIR%\lib\tcl%VER%\encoding\big5.enc
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\opt\pkgIndex.tcl
Destination=%MAINDIR%\lib\tcl%VER%\opt0.4\pkgIndex.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\opt\optparse.tcl
Destination=%MAINDIR%\lib\tcl%VER%\opt0.4\optparse.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\http\pkgIndex.tcl
Destination=%MAINDIR%\lib\tcl%VER%\http2.5\pkgIndex.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\http\http.tcl
Destination=%MAINDIR%\lib\tcl%VER%\http2.5\http.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\msgbox.tcl
Destination=%MAINDIR%\lib\tk%VER%\msgbox.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\optMenu.tcl
Destination=%MAINDIR%\lib\tk%VER%\optMenu.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\clrpick.tcl
Destination=%MAINDIR%\lib\tk%VER%\clrpick.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\entry.tcl
Destination=%MAINDIR%\lib\tk%VER%\entry.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\spinbox.tcl
Destination=%MAINDIR%\lib\tk%VER%\spinbox.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\comdlg.tcl
Destination=%MAINDIR%\lib\tk%VER%\comdlg.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\bgerror.tcl
Destination=%MAINDIR%\lib\tk%VER%\bgerror.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\obsolete.tcl
Destination=%MAINDIR%\lib\tk%VER%\obsolete.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\button.tcl
Destination=%MAINDIR%\lib\tk%VER%\button.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\xmfbox.tcl
Destination=%MAINDIR%\lib\tk%VER%\xmfbox.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\console.tcl
Destination=%MAINDIR%\lib\tk%VER%\console.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\listbox.tcl
Destination=%MAINDIR%\lib\tk%VER%\listbox.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\menu.tcl
Destination=%MAINDIR%\lib\tk%VER%\menu.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\dialog.tcl
Destination=%MAINDIR%\lib\tk%VER%\dialog.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\focus.tcl
Destination=%MAINDIR%\lib\tk%VER%\focus.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\palette.tcl
Destination=%MAINDIR%\lib\tk%VER%\palette.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\tkfbox.tcl
Destination=%MAINDIR%\lib\tk%VER%\tkfbox.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\tk.tcl
Destination=%MAINDIR%\lib\tk%VER%\tk.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\text.tcl
Destination=%MAINDIR%\lib\tk%VER%\text.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\tearoff.tcl
Destination=%MAINDIR%\lib\tk%VER%\tearoff.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\tclIndex
Destination=%MAINDIR%\lib\tk%VER%\tclIndex
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\scrlbar.tcl
Destination=%MAINDIR%\lib\tk%VER%\scrlbar.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\scale.tcl
Destination=%MAINDIR%\lib\tk%VER%\scale.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\safetk.tcl
Destination=%MAINDIR%\lib\tk%VER%\safetk.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\http1.0\pkgIndex.tcl
Destination=%MAINDIR%\lib\tcl%VER%\http1.0\pkgIndex.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\http1.0\http.tcl
Destination=%MAINDIR%\lib\tcl%VER%\http1.0\http.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\reg\pkgIndex.tcl
Destination=%MAINDIR%\lib\tcl%VER%\reg1.2\pkgIndex.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\win\release\tclreg12.dll
Destination=%MAINDIR%\lib\tcl%VER%\reg1.2\tclreg10.dll
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\dde\pkgIndex.tcl
Destination=%MAINDIR%\lib\tcl%VER%\dde1.3\pkgIndex.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\win\release\tcldde13.dll
Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\tcldde13.dll
Flags=0000000000000010
end
item: Install File
Source=C:\WINNT\SYSTEM32\Msvcrt.dll
Destination=%MAINDIR%\bin\msvcrt.dll
Flags=0010001000000011
end
item: Install File
Source=${__TKBASEDIR__}\win\release\wish84.exe
Destination=%MAINDIR%\bin\wish84.exe
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\win\release\tclsh84.exe
Destination=%MAINDIR%\bin\tclsh84.exe
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\win\release\tclpip84.dll
Destination=%MAINDIR%\bin\tclpip84.dll
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\win\release\tcl84.dll
Destination=%MAINDIR%\bin\tcl84.dll
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\win\release\tk84.dll
Destination=%MAINDIR%\bin\tk84.dll
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\auto.tcl
Destination=%MAINDIR%\lib\tcl%VER%\auto.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\history.tcl
Destination=%MAINDIR%\lib\tcl%VER%\history.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\init.tcl
Destination=%MAINDIR%\lib\tcl%VER%\init.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\package.tcl
Destination=%MAINDIR%\lib\tcl%VER%\package.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\parray.tcl
Destination=%MAINDIR%\lib\tcl%VER%\parray.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\safe.tcl
Destination=%MAINDIR%\lib\tcl%VER%\safe.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\tclIndex
Destination=%MAINDIR%\lib\tcl%VER%\tclIndex
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\word.tcl
Destination=%MAINDIR%\lib\tcl%VER%\word.tcl
Flags=0000000000000010
end
item: End Block
end
item: If/While Statement
Variable=COMPONENTS
Value=B
Flags=00001010
end
item: Install File
Source=${__TKBASEDIR__}\library\images\tai-ku.gif
Destination=%MAINDIR%\lib\tk%VER%\images\tai-ku.gif
Flags=0000000010000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\images\teapot.ppm
Destination=%MAINDIR%\lib\tk%VER%\demos\images\teapot.ppm
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\images\tcllogo.gif
Destination=%MAINDIR%\lib\tk%VER%\demos\images\tcllogo.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\images\pattern.bmp
Destination=%MAINDIR%\lib\tk%VER%\demos\images\pattern.bmp
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\images\noletter.bmp
Destination=%MAINDIR%\lib\tk%VER%\demos\images\noletter.bmp
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\images\letters.bmp
Destination=%MAINDIR%\lib\tk%VER%\demos\images\letters.bmp
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\images\gray25.bmp
Destination=%MAINDIR%\lib\tk%VER%\demos\images\gray25.bmp
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\images\flagup.bmp
Destination=%MAINDIR%\lib\tk%VER%\demos\images\flagup.bmp
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\images\flagdown.bmp
Destination=%MAINDIR%\lib\tk%VER%\demos\images\flagdown.bmp
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\images\face.bmp
Destination=%MAINDIR%\lib\tk%VER%\demos\images\face.bmp
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\images\earthris.gif
Destination=%MAINDIR%\lib\tk%VER%\demos\images\earthris.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\images\earth.gif
Destination=%MAINDIR%\lib\tk%VER%\demos\images\earth.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\vscale.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\vscale.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\twind.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\twind.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\text.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\text.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\style.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\style.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\states.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\states.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\search.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\search.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\sayings.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\sayings.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\ruler.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\ruler.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\radio.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\radio.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\puzzle.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\puzzle.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\plot.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\plot.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\msgbox.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\msgbox.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\menubu.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\menubu.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\menu.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\menu.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\label.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\label.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\items.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\items.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\image2.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\image2.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\image1.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\image1.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\icon.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\icon.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\hscale.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\hscale.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\form.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\form.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\ixset
Destination=%MAINDIR%\lib\tk%VER%\demos\ixset.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\rolodex
Destination=%MAINDIR%\lib\tk%VER%\demos\rolodex.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\square
Destination=%MAINDIR%\lib\tk%VER%\demos\square.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\Readme
Destination=%MAINDIR%\lib\tk%VER%\demos\Readme
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\hello
Destination=%MAINDIR%\lib\tk%VER%\demos\hello.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\tclIndex
Destination=%MAINDIR%\lib\tk%VER%\demos\tclIndex
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\browse
Destination=%MAINDIR%\lib\tk%VER%\demos\browse.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\timer
Destination=%MAINDIR%\lib\tk%VER%\demos\timer.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\widget
Destination=%MAINDIR%\lib\tk%VER%\demos\widget.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\tcolor
Destination=%MAINDIR%\lib\tk%VER%\demos\tcolor.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\rmt
Destination=%MAINDIR%\lib\tk%VER%\demos\rmt.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\floor.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\floor.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\filebox.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\filebox.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\images\pwrdLogo75.gif
Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo75.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\images\pwrdLogo200.gif
Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo200.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\images\pwrdLogo175.gif
Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo175.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\images\pwrdLogo150.gif
Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo150.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\images\pwrdLogo100.gif
Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo100.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\images\logoMed.gif
Destination=%MAINDIR%\lib\tk%VER%\images\logoMed.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\images\logoLarge.gif
Destination=%MAINDIR%\lib\tk%VER%\images\logoLarge.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\images\logo64.gif
Destination=%MAINDIR%\lib\tk%VER%\images\logo64.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\images\logo100.gif
Destination=%MAINDIR%\lib\tk%VER%\images\logo100.gif
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\images\Readme
Destination=%MAINDIR%\lib\tk%VER%\images\Readme
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\arrow.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\arrow.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\bind.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\bind.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\bitmap.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\bitmap.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\button.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\button.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\check.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\check.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\clrpick.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\clrpick.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\colors.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\colors.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\cscroll.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\cscroll.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\ctext.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\ctext.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\dialog1.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\dialog1.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\dialog2.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\dialog2.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\entry1.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\entry1.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\demos\entry2.tcl
Destination=%MAINDIR%\lib\tk%VER%\demos\entry2.tcl
Flags=0000000000000010
end
item: End Block
end
item: If/While Statement
Variable=COMPONENTS
Value=C
Flags=00001010
end
item: Install File
Source=${__TCLBASEDIR__}\tools\tcl84.cnt
Destination=%MAINDIR%\doc\tcl84.cnt
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\tools\tcl84.hlp
Destination=%MAINDIR%\doc\tcl84.hlp
Flags=0000000000000010
end
item: End Block
end
item: Set Variable
Variable=MAINDIR
Value=%MAINDIR%
Flags=00010100
end
item: Include Script
Pathname=\\pop\tools\1.2\win32-ix86\wise\INCLUDE\uninstal.wse
end
item: Check Configuration
Flags=10111011
end
item: Get Registry Key Value
Variable=GROUPDIR
Key=Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders
Default=%WIN%\Start Menu\Programs
Value Name=Programs
Flags=00000010
end
item: Set Variable
Variable=GROUP
Value=%GROUPDIR%\%GROUP%
end
item: If/While Statement
Variable=COMPONENTS
Value=A
Flags=00001010
end
item: Create Shortcut
Source=%MAINDIR%\bin\wish84.exe
Destination=%GROUP%\Wish.lnk
Working Directory=%MAINDIR%
end
item: End Block
end
item: If/While Statement
Variable=COMPONENTS
Value=A
Flags=00001010
end
item: Create Shortcut
Source=%MAINDIR%\bin\tclsh84.exe
Destination=%GROUP%\Tclsh.lnk
Working Directory=%MAINDIR%
Key Type=1536
Flags=00000001
end
item: End Block
end
item: If/While Statement
Variable=COMPONENTS
Value=C
Flags=00001010
end
item: Create Shortcut
Source=%MAINDIR%\doc\tcl84.hlp
Destination=%GROUP%\Tcl Help.lnk
Working Directory=%MAINDIR%
end
item: End Block
end
item: Create Shortcut
Source=%MAINDIR%\Readme.txt
Destination=%GROUP%\Readme.lnk
Working Directory=%MAINDIR%
end
item: If/While Statement
Variable=COMPONENTS
Value=B
Flags=00001010
end
item: Create Shortcut
Source=%MAINDIR%\lib\tk%VER%\demos\widget.tcl
Destination=%GROUP%\Widget Tour.lnk
Working Directory=%MAINDIR%
Key Type=1536
Flags=00000001
end
item: End Block
end
item: Else Statement
end
item: If/While Statement
Variable=COMPONENTS
Value=B
Flags=00001010
end
item: Add ProgMan Icon
Group=%GROUP%
Icon Name=Widget Tour
Command Line=%MAINDIR%\lib\tk%VER%\demos\widget.tcl
Icon Pathname=%MAINDIR%\bin\wish84.exe
Default Directory=%MAINDIR%
end
item: End Block
end
item: If/While Statement
Variable=COMPONENTS
Value=C
Flags=00001010
end
item: Add ProgMan Icon
Group=%GROUP%
Icon Name=Tcl Help
Command Line=%MAINDIR%\doc\tcl84.hlp
Default Directory=%MAINDIR%
end
item: End Block
end
item: Add ProgMan Icon
Group=%GROUP%
Icon Name=Readme
Command Line=%MAINDIR%\Readme.txt
Default Directory=%MAINDIR%
end
item: If/While Statement
Variable=COMPONENTS
Value=A
Flags=00001010
end
item: Add ProgMan Icon
Group=%GROUP%
Icon Name=Wish
Command Line=%MAINDIR%\bin\wish84.exe
Default Directory=%MAINDIR%
end
item: End Block
end
item: If/While Statement
Variable=COMPONENTS
Value=A
Flags=00001010
end
item: Add ProgMan Icon
Group=%GROUP%
Icon Name=Tclsh
Command Line=%MAINDIR%\bin\tclsh84.exe
Default Directory=%MAINDIR%
end
item: End Block
end
item: End Block
end
item: Self-Register OCXs/DLLs
Description=Updating System Configuration, Please Wait...
end
item: Edit Registry
Total Keys=1
Key=SOFTWARE\Scriptics\Tcl\%VER%
New Value=%MAINDIR%
Value Name=Root
Root=2
end
item: Edit Registry
Total Keys=1
Key=TclScript\DefaultIcon
New Value=%MAINDIR%\bin\tk84.dll
end
item: Edit Registry
Total Keys=1
Key=.tcl
New Value=TclScript
end
item: Edit Registry
Total Keys=1
Key=TclScript
New Value=TclScript
end
item: Edit Registry
Total Keys=1
Key=TclScript\shell\open\command
New Value=%MAINDIRSHORT%\bin\wish84.exe "%%1" %%*
end
item: Edit Registry
Total Keys=1
Key=TclScript\shell\edit
New Value=&Edit
end
item: Edit Registry
Total Keys=1
Key=TclScript\shell\edit\command
New Value=notepad "%%1"
end
item: Add Directory to Path
Directory=%MAINDIR%\bin
end
item: Check Configuration
Flags=10111011
end
item: Set Variable
Variable=TO_SCRIPTICS
Value=A
end
item: Else Statement
end
item: Set Variable
Variable=TO_SCRIPTICS
end
item: End Block
end
item: Wizard Block
Direction Variable=DIRECTION
Display Variable=DISPLAY
Bitmap Pathname=%_WISE_%\DIALOGS\TEMPLATE\WIZARD.BMP
X Position=9
Y Position=10
Filler Color=8421440
Flags=00000011
end
item: Custom Dialog Set
Name=Finished
Display Variable=DISPLAY
item: Dialog
Title=%APPTITLE% Installation
Title French=Installation de %APPTITLE%
Title German=Installation von %APPTITLE%
Title Spanish=InstalaciУЏТПТНn de %APPTITLE%
Title Italian=Installazione di %APPTITLE%
Width=271
Height=224
Font Name=Helv
Font Size=8
item: Push Button
Rectangle=150 187 195 202
Variable=DIRECTION
Value=N
Create Flags=01010000000000010000000000000001
Text=&Finish
Text French=&Fin
Text German=&Weiter
Text Spanish=&Terminar
Text Italian=&Fine
end
item: Push Button
Rectangle=105 187 150 202
Variable=DISABLED
Value=!
Create Flags=01010000000000010000000000000000
Text=< &Back
Text French=< &Retour
Text German=< &ZurУЏТПТНck
Text Spanish=< &AtrУЏТПТНs
Text Italian=< &Indietro
end
item: Push Button
Rectangle=211 187 256 202
Variable=DISABLED
Value=!
Action=3
Create Flags=01010000000000010000000000000000
Text=&Cancel
Text French=&Annuler
Text German=&Abbrechen
Text Spanish=&Cancelar
Text Italian=&Annulla
end
item: Static
Rectangle=8 180 256 181
Action=3
Create Flags=01010000000000000000000000000111
end
item: Static
Rectangle=86 8 258 42
Create Flags=01010000000000000000000000000000
Flags=0000000000000001
Name=Times New Roman
Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
Text=Installation Completed!
Text French=Installation terminУЏТПТНe !
Text German=Die Installation ist abgeschlossen!
Text Spanish=УЏТПТНInstalaciУЏТПТНn terminada!
Text Italian=Installazione completata!
end
item: Static
Rectangle=86 42 256 153
Create Flags=01010000000000000000000000000000
Text=%APPTITLE% has been successfully installed.
Text=
Text=Click the Finish button to exit this installation.
Text=
Text=You can learn more about Tcl/Tk %VER%, including release notes, updates, tutorials, and more at %URL%. Check the box below to start your web browser and go there now.
Text=
Text=The installer may ask you to reboot your computer, this is to update your PATH and is not necessary to do immediately.
Text French=%APPTITLE% est maintenant installУЏТПТН.
Text French=
Text French=Cliquez sur le bouton Fin pour quitter l'installation.
Text German=%APPTITLE% wurde erfolgreich installiert.
Text German=
Text German=Klicken Sie auf "Weiter", um die Installation zu beenden.
Text Spanish=%APPTITLE% se ha instalado con УЏТПТНxito.
Text Spanish=
Text Spanish=Presione el botУЏТПТНn Terminar para salir de esta instalaciУЏТПТНn.
Text Italian=L'installazione %APPTITLE% УЏТПТН stata portata a termine con successo.
Text Italian=
Text Italian=Premere il pulsante Fine per uscire dall'installazione.
end
item: Checkbox
Rectangle=88 143 245 157
Variable=TO_SCRIPTICS
Enabled Color=00000000000000001111111111111111
Create Flags=01010000000000010000000000000011
Text=Show me important information about
Text=
end
item: Static
Rectangle=99 156 245 170
Enabled Color=00000000000000001111111111111111
Create Flags=01010000000000000000000000000000
Text=Tcl/Tk %VER% and TclPro
end
end
end
item: End Block
end
item: Check Configuration
Flags=10111011
end
item: If/While Statement
Variable=TO_SCRIPTICS
Value=A
Flags=00000010
end
item: Execute Program
Command Line=%URL%
end
item: End Block
end
item: Execute Program
Pathname=explorer
Command Line=%GROUP%
end
item: End Block
end
tcl8.4.20/tools/uniParse.tcl 0000644 0036047 0045461 00000024616 11737050675 014363 0 ustar dgp 771div # uniParse.tcl --
#
# This program parses the UnicodeData file and generates the
# corresponding tclUniData.c file with compressed character
# data tables. The input to this program should be the latest
# UnicodeData file from:
# ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData.txt
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
namespace eval uni {
set shift 5; # number of bits of data within a page
# This value can be adjusted to find the
# best split to minimize table size
variable pMap; # map from page to page index, each entry is
# an index into the pages table, indexed by
# page number
variable pages; # map from page index to page info, each
# entry is a list of indices into the groups
# table, the list is indexed by the offset
variable groups; # list of character info values, indexed by
# group number, initialized with the
# unassigned character group
variable categories {
Cn Lu Ll Lt Lm Lo Mn Me Mc Nd Nl No Zs Zl Zp
Cc Cf Co Cs Pc Pd Ps Pe Pi Pf Po Sm Sc Sk So
}; # Ordered list of character categories, must
# match the enumeration in the header file.
}
proc uni::getValue {items index} {
variable categories
# Extract character info
set category [lindex $items 2]
if {[scan [lindex $items 12] %x toupper] == 1} {
set toupper [expr {$index - $toupper}]
} else {
set toupper 0
}
if {[scan [lindex $items 13] %x tolower] == 1} {
set tolower [expr {$tolower - $index}]
} else {
set tolower 0
}
if {[scan [lindex $items 14] %x totitle] == 1} {
set totitle [expr {$index - $totitle}]
} elseif {$tolower} {
set totitle 0
} else {
set totitle $toupper
}
set categoryIndex [lsearch -exact $categories $category]
if {$categoryIndex < 0} {
error "Unexpected character category: $index($category)"
}
return [list $categoryIndex $toupper $tolower $totitle]
}
proc uni::getGroup {value} {
variable groups
set gIndex [lsearch -exact $groups $value]
if {$gIndex == -1} {
set gIndex [llength $groups]
lappend groups $value
}
return $gIndex
}
proc uni::addPage {info} {
variable pMap
variable pages
variable shift
set pIndex [lsearch -exact $pages $info]
if {$pIndex == -1} {
set pIndex [llength $pages]
lappend pages $info
}
lappend pMap [expr {$pIndex << $shift}]
return
}
proc uni::buildTables {data} {
variable shift
variable pMap {}
variable pages {}
variable groups {{0 0 0 0}}
variable next 0
set info {} ;# temporary page info
set mask [expr {(1 << $shift) - 1}]
foreach line [split $data \n] {
if {$line eq ""} {
if {!($next & $mask)} {
# next character is already on page boundary
continue
}
# fill remaining page
set line [format %X [expr {($next-1)|$mask}]]
append line ";;Cn;0;ON;;;;;N;;;;;\n"
}
set items [split $line \;]
scan [lindex $items 0] %x index
if {$index > 0x2ffff} then {
# Ignore non-BMP characters, as long as Tcl doesn't support them
continue
}
set index [format %d $index]
set gIndex [getGroup [getValue $items $index]]
# Since the input table omits unassigned characters, these will
# show up as gaps in the index sequence. There are a few special cases
# where the gaps correspond to a uniform block of assigned characters.
# These are indicated as such in the character name.
# Enter all unassigned characters up to the current character.
if {($index > $next) \
&& ![regexp "Last>$" [lindex $items 1]]} {
for {} {$next < $index} {incr next} {
lappend info 0
if {($next & $mask) == $mask} {
addPage $info
set info {}
}
}
}
# Enter all assigned characters up to the current character
for {set i $next} {$i <= $index} {incr i} {
# Add the group index to the info for the current page
lappend info $gIndex
# If this is the last entry in the page, add the page
if {($i & $mask) == $mask} {
addPage $info
set info {}
}
}
set next [expr {$index + 1}]
}
return
}
proc uni::main {} {
global argc argv0 argv
variable pMap
variable pages
variable groups
variable shift
variable next
if {$argc != 2} {
puts stderr "\nusage: $argv0 \n"
exit 1
}
set f [open [lindex $argv 0] r]
set data [read $f]
close $f
buildTables $data
puts "X = [llength $pMap] Y= [llength $pages] A= [llength $groups]"
set size [expr {[llength $pMap]*2 + ([llength $pages]<<$shift)}]
puts "shift = $shift, space = $size"
set f [open [file join [lindex $argv 1] tclUniData.c] w]
fconfigure $f -translation lf
puts $f "/*
* tclUniData.c --
*
* Declarations of Unicode character information tables. This file is
* automatically generated by the tools/uniParse.tcl script. Do not
* modify this file by hand.
*
* Copyright (c) 1998 by Scriptics Corporation.
* All rights reserved.
*/
/*
* A 16-bit Unicode character is split into two parts in order to index
* into the following tables. The lower OFFSET_BITS comprise an offset
* into a page of characters. The upper bits comprise the page number.
*/
#define OFFSET_BITS $shift
/*
* The pageMap is indexed by page number and returns an alternate page number
* that identifies a unique page of characters. Many Unicode characters map
* to the same alternate page number.
*/
static CONST unsigned short pageMap\[\] = {"
set line " "
set last [expr {[llength $pMap] - 1}]
for {set i 0} {$i <= $last} {incr i} {
if {$i == [expr {0x10000 >> $shift}]} {
set line [string trimright $line " \t,"]
puts $f $line
set lastpage [expr {[lindex $line end] >> $shift}]
puts stdout "lastpage: $lastpage"
puts $f "#if TCL_UTF_MAX > 3"
set line " ,"
}
append line [lindex $pMap $i]
if {$i != $last} {
append line ", "
}
if {[string length $line] > 70} {
puts $f [string trimright $line]
set line " "
}
}
puts $f $line
puts $f "#endif /* TCL_UTF_MAX > 3 */"
puts $f "};
/*
* The groupMap is indexed by combining the alternate page number with
* the page offset and returns a group number that identifies a unique
* set of character attributes.
*/
static CONST unsigned char groupMap\[\] = {"
set line " "
set lasti [expr {[llength $pages] - 1}]
for {set i 0} {$i <= $lasti} {incr i} {
set page [lindex $pages $i]
set lastj [expr {[llength $page] - 1}]
if {$i == ($lastpage + 1)} {
puts $f [string trimright $line " \t,"]
puts $f "#if TCL_UTF_MAX > 3"
set line " ,"
}
for {set j 0} {$j <= $lastj} {incr j} {
append line [lindex $page $j]
if {$j != $lastj || $i != $lasti} {
append line ", "
}
if {[string length $line] > 70} {
puts $f [string trimright $line]
set line " "
}
}
}
puts $f $line
puts $f "#endif /* TCL_UTF_MAX > 3 */"
puts $f "};
/*
* Each group represents a unique set of character attributes. The attributes
* are encoded into a 32-bit value as follows:
*
* Bits 0-4 Character category: see the constants listed below.
*
* Bits 5-7 Case delta type: 000 = identity
* 010 = add delta for lower
* 011 = add delta for lower, add 1 for title
* 100 = subtract delta for title/upper
* 101 = sub delta for upper, sub 1 for title
* 110 = sub delta for upper, add delta for lower
*
* Bits 8-31 Case delta: delta for case conversions. This should be the
* highest field so we can easily sign extend.
*/
static CONST int groups\[\] = {"
set line " "
set last [expr {[llength $groups] - 1}]
for {set i 0} {$i <= $last} {incr i} {
foreach {type toupper tolower totitle} [lindex $groups $i] {}
# Compute the case conversion type and delta
if {$totitle} {
if {$totitle == $toupper} {
# subtract delta for title or upper
set case 4
set delta $toupper
if {$tolower} {
error "New case conversion type needed: $toupper $tolower $totitle"
}
} elseif {$toupper} {
# subtract delta for upper, subtract 1 for title
set case 5
set delta $toupper
if {($totitle != 1) || $tolower} {
error "New case conversion type needed: $toupper $tolower $totitle"
}
} else {
# add delta for lower, add 1 for title
set case 3
set delta $tolower
if {$totitle != -1} {
error "New case conversion type needed: $toupper $tolower $totitle"
}
}
} elseif {$toupper} {
# subtract delta for upper, add delta for lower
set case 6
set delta $toupper
if {$tolower != $toupper} {
error "New case conversion type needed: $toupper $tolower $totitle"
}
} elseif {$tolower} {
# add delta for lower
set case 2
set delta $tolower
} else {
# noop
set case 0
set delta 0
}
append line [expr {($delta << 8) | ($case << 5) | $type}]
if {$i != $last} {
append line ", "
}
if {[string length $line] > 65} {
puts $f [string trimright $line]
set line " "
}
}
puts $f $line
puts -nonewline $f "};
#if TCL_UTF_MAX > 3
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1fffff) >= [format 0x%x $next])
#else
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1f0000) != 0)
#endif
/*
* The following constants are used to determine the category of a
* Unicode character.
*/
enum {
UNASSIGNED,
UPPERCASE_LETTER,
LOWERCASE_LETTER,
TITLECASE_LETTER,
MODIFIER_LETTER,
OTHER_LETTER,
NON_SPACING_MARK,
ENCLOSING_MARK,
COMBINING_SPACING_MARK,
DECIMAL_DIGIT_NUMBER,
LETTER_NUMBER,
OTHER_NUMBER,
SPACE_SEPARATOR,
LINE_SEPARATOR,
PARAGRAPH_SEPARATOR,
CONTROL,
FORMAT,
PRIVATE_USE,
SURROGATE,
CONNECTOR_PUNCTUATION,
DASH_PUNCTUATION,
OPEN_PUNCTUATION,
CLOSE_PUNCTUATION,
INITIAL_QUOTE_PUNCTUATION,
FINAL_QUOTE_PUNCTUATION,
OTHER_PUNCTUATION,
MATH_SYMBOL,
CURRENCY_SYMBOL,
MODIFIER_SYMBOL,
OTHER_SYMBOL
};
/*
* The following macros extract the fields of the character info. The
* GetDelta() macro is complicated because we can't rely on the C compiler
* to do sign extension on right shifts.
*/
#define GetCaseType(info) (((info) & 0xe0) >> 5)
#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1f)
#define GetDelta(info) ((info) >> 8)
/*
* This macro extracts the information about a character from the
* Unicode character tables.
*/
#define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0xffff) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
"
close $f
}
uni::main
return
tcl8.4.20/tools/man2help2.tcl 0000644 0036047 0045461 00000046743 11737050675 014372 0 ustar dgp 771div # man2help2.tcl --
#
# This file defines procedures that are used during the second pass of
# the man page conversion. It converts the man format input to rtf
# form suitable for use by the Windows help compiler.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Global variables used by these scripts:
#
# state - state variable that controls action of text proc.
#
# topics - array indexed by (package,section,topic) with value
# of topic ID.
#
# keywords - array indexed by keyword string with value of topic ID.
#
# curID - current topic ID, starts at 0 and is incremented for
# each new topic file.
#
# curPkg - current package name (e.g. Tcl).
#
# curSect - current section title (e.g. "Tcl Built-In Commands").
#
# initGlobals --
#
# This procedure is invoked to set the initial values of all of the
# global variables, before processing a man page.
#
# Arguments:
# None.
proc initGlobals {} {
uplevel \#0 unset state
global state chars
set state(paragraphPending) 0
set state(breakPending) 0
set state(firstIndent) 0
set state(leftIndent) 0
set state(inTP) 0
set state(paragraph) 0
set state(textState) 0
set state(curFont) ""
set state(startCode) "{\\b "
set state(startEmphasis) "{\\i "
set state(endCode) "}"
set state(endEmphasis) "}"
set state(noFill) 0
set state(charCnt) 0
set state(offset) [getTwips 0.5i]
set state(leftMargin) [getTwips 0.5i]
set state(nestingLevel) 0
set state(intl) 0
set state(sb) 0
setTabs 0.5i
# set up international character table
array set chars {
o^ F4
}
}
# beginFont --
#
# Arranges for future text to use a special font, rather than
# the default paragraph font.
#
# Arguments:
# font - Name of new font to use.
proc beginFont {font} {
global file state
textSetup
if {[string equal $state(curFont) $font]} {
return
}
endFont
puts -nonewline $file $state(start$font)
set state(curFont) $font
}
# endFont --
#
# Reverts to the default font for the paragraph type.
#
# Arguments:
# None.
proc endFont {} {
global state file
if {[string compare $state(curFont) ""]} {
puts -nonewline $file $state(end$state(curFont))
set state(curFont) ""
}
}
# textSetup --
#
# This procedure is called the first time that text is output for a
# paragraph. It outputs the header information for the paragraph.
#
# Arguments:
# None.
proc textSetup {} {
global file state
if $state(breakPending) {
puts $file "\\line"
}
if $state(paragraphPending) {
puts $file [format "\\par\n\\pard\\fi%.0f\\li%.0f" \
$state(firstIndent) $state(leftIndent)]
foreach tab $state(tabs) {
puts $file [format "\\tx%.0f" $tab]
}
set state(tabs) {}
if {$state(sb)} {
puts $file "\\sb$state(sb)"
set state(sb) 0
}
}
set state(breakPending) 0
set state(paragraphPending) 0
}
# text --
#
# This procedure adds text to the current state(paragraph). If this is
# the first text in the state(paragraph) then header information for the
# state(paragraph) is output before the text.
#
# Arguments:
# string - Text to output in the state(paragraph).
proc text {string} {
global file state chars
textSetup
set string [string map [list \
"\\" "\\\\" \
"\{" "\\\{" \
"\}" "\\\}" \
"\t" {\tab } \
'' "\\rdblquote " \
`` "\\ldblquote " \
] $string]
# Check if this is the beginning of an international character string.
# If so, look up the sequence in the chars table and substitute the
# appropriate hex value.
if {$state(intl)} {
if {[regexp {^'([^']*)'} $string dummy ch]} {
if {[info exists chars($ch)]} {
regsub {^'[^']*'} $string "\\\\'$chars($ch)" string
} else {
puts stderr "Unknown international character '$ch'"
}
}
set state(intl) 0
}
switch $state(textState) {
REF {
if {$state(inTP) == 0} {
set string [insertRef $string]
}
}
SEE {
global topics curPkg curSect
foreach i [split $string] {
if {![regexp -nocase {^[a-z_0-9]+} [string trim $i] i ]} {
continue
}
if {![catch {set ref $topics($curPkg,$curSect,$i)} ]} {
regsub $i $string [link $i $ref] string
}
}
}
KEY {
return
}
}
puts -nonewline $file "$string"
}
# insertRef --
#
# This procedure looks for a string in the cross reference table and
# generates a hot-link to the appropriate topic. Tries to find the
# nearest reference in the manual.
#
# Arguments:
# string - Text to output in the state(paragraph).
proc insertRef {string} {
global NAME_file curPkg curSect topics curID
set path {}
set string [string trim $string]
set ref {}
if {[info exists topics($curPkg,$curSect,$string)]} {
set ref $topics($curPkg,$curSect,$string)
} else {
set sites [array names topics "$curPkg,*,$string"]
set count [llength $sites]
if {$count > 0} {
set ref $topics([lindex $sites 0])
} else {
set sites [array names topics "*,*,$string"]
set count [llength $sites]
if {$count > 0} {
set ref $topics([lindex $sites 0])
}
}
}
if {($ref != {}) && ($ref != $curID)} {
set string [link $string $ref]
}
return $string
}
# macro --
#
# This procedure is invoked to process macro invocations that start
# with "." (instead of ').
#
# Arguments:
# name - The name of the macro (without the ".").
# args - Any additional arguments to the macro.
proc macro {name args} {
global state file
switch $name {
AP {
if {[llength $args] != 3 && [llength $args] != 2} {
puts stderr "Bad .AP macro: .$name [join $args " "]"
}
newPara 3.75i -3.75i
setTabs {1.25i 2.5i 3.75i}
font B
text [lindex $args 0]
tab
font I
text [lindex $args 1]
tab
font R
if {[llength $args] == 3} {
text "([lindex $args 2])"
}
tab
}
AS {
# next page and previous page
}
br {
lineBreak
}
BS {}
BE {}
CE {
puts -nonewline $::file "\\f0\\fs20 "
set state(noFill) 0
set state(breakPending) 0
newPara ""
set state(leftIndent) [expr {$state(leftIndent) - $state(offset)}]
set state(sb) 80
}
CS {
# code section
set state(noFill) 1
newPara ""
set state(leftIndent) [expr {$state(leftIndent) + $state(offset)}]
set state(sb) 80
puts -nonewline $::file "\\f1\\fs18 "
}
DE {
set state(noFill) 0
decrNestingLevel
newPara 0i
}
DS {
set state(noFill) 1
incrNestingLevel
newPara 0i
}
fi {
set state(noFill) 0
}
IP {
IPmacro $args
}
LP {
newPara 0i
set state(sb) 80
}
ne {
}
nf {
set state(noFill) 1
}
OP {
if {[llength $args] != 3} {
puts stderr "Bad .OP macro: .$name [join $args " "]"
}
set state(nestingLevel) 0
newPara 0i
set state(sb) 120
setTabs 4c
text "Command-Line Name:"
tab
font B
set x [lindex $args 0]
regsub -all {\\-} $x - x
text $x
lineBreak
font R
text "Database Name:"
tab
font B
text [lindex $args 1]
lineBreak
font R
text "Database Class:"
tab
font B
text [lindex $args 2]
font R
set state(inTP) 0
newPara 0.5i
set state(sb) 80
}
PP {
newPara 0i
set state(sb) 120
}
RE {
decrNestingLevel
}
RS {
incrNestingLevel
}
SE {
font R
set state(noFill) 0
set state(nestingLevel) 0
newPara 0i
text "See the "
font B
set temp $state(textState)
set state(textState) REF
text options
set state(textState) $temp
font R
text " manual entry for detailed descriptions of the above options."
}
SH {
SHmacro $args
}
SO {
SHmacro "STANDARD OPTIONS"
set state(nestingLevel) 0
newPara 0i
setTabs {4c 8c 12c}
font B
set state(noFill) 1
}
so {
if {$args != "man.macros"} {
puts stderr "Unknown macro: .$name [join $args " "]"
}
}
sp { ;# needs work
if {$args == ""} {
set count 1
} else {
set count [lindex $args 0]
}
while {$count > 0} {
lineBreak
incr count -1
}
}
ta {
setTabs $args
}
TH {
THmacro $args
}
TP {
TPmacro $args
}
UL { ;# underline
puts -nonewline $file "{\\ul "
text [lindex $args 0]
puts -nonewline $file "}"
if {[llength $args] == 2} {
text [lindex $args 1]
}
}
VE {}
VS {}
default {
puts stderr "Unknown macro: .$name [join $args " "]"
}
}
}
# link --
#
# This procedure returns the string for a hot link to a different
# context location.
#
# Arguments:
# label - String to display in hot-spot.
# id - Context string to jump to.
proc link {label id} {
return "{\\uldb $label}{\\v $id}"
}
# font --
#
# This procedure is invoked to handle font changes in the text
# being output.
#
# Arguments:
# type - Type of font: R, I, B, or S.
proc font {type} {
global state
switch $type {
P -
R {
endFont
if {$state(textState) == "REF"} {
set state(textState) INSERT
}
}
C -
B {
beginFont Code
if {$state(textState) == "INSERT"} {
set state(textState) REF
}
}
I {
beginFont Emphasis
}
S {
}
default {
puts stderr "Unknown font: $type"
}
}
}
# formattedText --
#
# Insert a text string that may also have \fB-style font changes
# and a few other backslash sequences in it.
#
# Arguments:
# text - Text to insert.
proc formattedText {text} {
global chars
while {$text != ""} {
set index [string first \\ $text]
if {$index < 0} {
text $text
return
}
text [string range $text 0 [expr {$index-1}]]
set c [string index $text [expr {$index+1}]]
switch -- $c {
f {
font [string index $text [expr {$index+2}]]
set text [string range $text [expr {$index+3}] end]
}
e {
text "\\"
set text [string range $text [expr {$index+2}] end]
}
- {
dash
set text [string range $text [expr {$index+2}] end]
}
| {
set text [string range $text [expr {$index+2}] end]
}
o {
text "\\'"
regexp {'([^']*)'(.*)} $text all ch text
text $chars($ch)
}
default {
puts stderr "Unknown sequence: \\$c"
set text [string range $text [expr {$index+2}] end]
}
}
}
}
# dash --
#
# This procedure is invoked to handle dash characters ("\-" in
# troff). It outputs a special dash character.
#
# Arguments:
# None.
proc dash {} {
global state
if {[string equal $state(textState) "NAME"]} {
set state(textState) 0
}
text "-"
}
# tab --
#
# This procedure is invoked to handle tabs in the troff input.
# Right now it does nothing.
#
# Arguments:
# None.
proc tab {} {
global file
textSetup
puts -nonewline $file "\\tab "
}
# setTabs --
#
# This procedure handles the ".ta" macro, which sets tab stops.
#
# Arguments:
# tabList - List of tab stops, each consisting of a number
# followed by "i" (inch) or "c" (cm).
proc setTabs {tabList} {
global file state
set state(tabs) {}
foreach arg $tabList {
set distance [expr {$state(leftMargin) \
+ ($state(offset) * $state(nestingLevel)) + [getTwips $arg]}]
lappend state(tabs) [expr {round($distance)}]
}
}
# lineBreak --
#
# Generates a line break in the HTML output.
#
# Arguments:
# None.
proc lineBreak {} {
global state
textSetup
set state(breakPending) 1
}
# newline --
#
# This procedure is invoked to handle newlines in the troff input.
# It outputs either a space character or a newline character, depending
# on fill mode.
#
# Arguments:
# None.
proc newline {} {
global state
if {$state(inTP)} {
set state(inTP) 0
lineBreak
} elseif {$state(noFill)} {
lineBreak
} else {
text " "
}
}
# pageBreak --
#
# This procedure is invoked to generate a page break.
#
# Arguments:
# None.
proc pageBreak {} {
global file curVer
if {[string equal $curVer ""]} {
puts $file {\page}
} else {
puts $file {\par}
puts $file {\pard\sb400\qc}
puts $file "Last change: $curVer\\page"
}
}
# char --
#
# This procedure is called to handle a special character.
#
# Arguments:
# name - Special character named in troff \x or \(xx construct.
proc char {name} {
global file state
switch -exact $name {
\\o {
set state(intl) 1
}
\\\ {
textSetup
puts -nonewline $file " "
}
\\0 {
textSetup
puts -nonewline $file " \\emspace "
}
\\\\ {
textSetup
puts -nonewline $file "\\\\"
}
\\(+- {
textSetup
puts -nonewline $file "\\'b1 "
}
\\% -
\\| {
}
\\(bu {
textSetup
puts -nonewline $file "З"
}
default {
puts stderr "Unknown character: $name"
}
}
}
# macro2 --
#
# This procedure handles macros that are invoked with a leading "'"
# character instead of space. Right now it just generates an
# error diagnostic.
#
# Arguments:
# name - The name of the macro (without the ".").
# args - Any additional arguments to the macro.
proc macro2 {name args} {
puts stderr "Unknown macro: '$name [join $args " "]"
}
# SHmacro --
#
# Subsection head; handles the .SH macro.
#
# Arguments:
# name - Section name.
proc SHmacro {argList} {
global file state
set args [join $argList " "]
if {[llength $argList] < 1} {
puts stderr "Bad .SH macro: .SH $args"
}
# control what the text proc does with text
switch $args {
NAME {set state(textState) NAME}
DESCRIPTION {set state(textState) INSERT}
INTRODUCTION {set state(textState) INSERT}
"WIDGET-SPECIFIC OPTIONS" {set state(textState) INSERT}
"SEE ALSO" {set state(textState) SEE}
KEYWORDS {set state(textState) KEY; return}
}
if {$state(breakPending) != -1} {
set state(breakPending) 1
} else {
set state(breakPending) 0
}
set state(noFill) 0
nextPara 0i
font B
text $args
font R
nextPara .5i
}
# IPmacro --
#
# This procedure is invoked to handle ".IP" macros, which may take any
# of the following forms:
#
# .IP [1] Translate to a "1Step" state(paragraph).
# .IP [x] (x > 1) Translate to a "Step" state(paragraph).
# .IP Translate to a "Bullet" state(paragraph).
# .IP text count Translate to a FirstBody state(paragraph) with special
# indent and tab stop based on "count", and tab after
# "text".
#
# Arguments:
# argList - List of arguments to the .IP macro.
#
# HTML limitations: 'count' in '.IP text count' is ignored.
proc IPmacro {argList} {
global file state
set length [llength $argList]
if {$length == 0} {
newPara 0.5i
return
}
if {$length == 1} {
newPara 0.5i -0.5i
set state(sb) 80
setTabs 0.5i
formattedText [lindex $argList 0]
tab
return
}
if {$length == 2} {
set count [lindex $argList 1]
set tab [expr $count * 0.1]i
newPara $tab -$tab
set state(sb) 80
setTabs $tab
formattedText [lindex $argList 0]
tab
return
}
puts stderr "Bad .IP macro: .IP [join $argList " "]"
}
# TPmacro --
#
# This procedure is invoked to handle ".TP" macros, which may take any
# of the following forms:
#
# .TP x Translate to an state(indent)ed state(paragraph) with the
# specified state(indent) (in 100 twip units).
# .TP Translate to an state(indent)ed state(paragraph) with
# default state(indent).
#
# Arguments:
# argList - List of arguments to the .IP macro.
#
# HTML limitations: 'x' in '.TP x' is ignored.
proc TPmacro {argList} {
global state
set length [llength $argList]
if {$length == 0} {
set val 0.5i
} else {
set val [expr {([lindex $argList 0] * 100.0)/1440}]i
}
newPara $val -$val
setTabs $val
set state(inTP) 1
set state(sb) 120
}
# THmacro --
#
# This procedure handles the .TH macro. It generates the non-scrolling
# header section for a given man page, and enters information into the
# table of contents. The .TH macro has the following form:
#
# .TH name section date footer header
#
# Arguments:
# argList - List of arguments to the .TH macro.
proc THmacro {argList} {
global file curPkg curSect curID id_keywords state curVer bitmap
if {[llength $argList] != 5} {
set args [join $argList " "]
puts stderr "Bad .TH macro: .TH $args"
}
incr curID
set name [lindex $argList 0] ;# Tcl_UpVar
set page [lindex $argList 1] ;# 3
set curVer [lindex $argList 2] ;# 7.4
set curPkg [lindex $argList 3] ;# Tcl
set curSect [lindex $argList 4] ;# {Tcl Library Procedures}
regsub -all {\\ } $curSect { } curSect ;# Clean up for [incr\ Tcl]
puts $file "#{\\footnote $curID}" ;# Context string
puts $file "\${\\footnote $name}" ;# Topic title
set browse "${curSect}${name}"
regsub -all {[ _-]} $browse {} browse
puts $file "+{\\footnote $browse}" ;# Browse sequence
# Suppress duplicates
foreach i $id_keywords($curID) {
set keys($i) 1
}
foreach i [array names keys] {
set i [string trim $i]
if {[string length $i] > 0} {
puts $file "K{\\footnote $i}" ;# Keyword strings
}
}
unset keys
puts $file "\\pard\\tx3000\\sb100\\sa100\\fs24\\keepn"
font B
text $name
tab
text $curSect
font R
if {[info exists bitmap]} {
# a right justified bitmap
puts $file "\\\{bmrt $bitmap\\\}"
}
puts $file "\\fs20"
set state(breakPending) -1
}
# nextPara --
#
# Set the indents for a new paragraph, and start a paragraph break
#
# Arguments:
# leftIndent - The new left margin for body lines.
# firstIndent - The offset from the left margin for the first line.
proc nextPara {leftIndent {firstIndent 0i}} {
global state
set state(leftIndent) [getTwips $leftIndent]
set state(firstIndent) [getTwips $firstIndent]
set state(paragraphPending) 1
}
# newPara --
#
# This procedure sets the left and hanging state(indent)s for a line.
# State(Indent)s are specified in units of inches or centimeters, and are
# relative to the current nesting level and left margin.
#
# Arguments:
# leftState(Indent) - The new left margin for lines after the first.
# firstState(Indent) - The new left margin for the first line of a state(paragraph).
proc newPara {leftIndent {firstIndent 0i}} {
global state file
if $state(paragraph) {
puts -nonewline $file "\\line\n"
}
if {$leftIndent != ""} {
set state(leftIndent) [expr {$state(leftMargin) \
+ ($state(offset) * $state(nestingLevel)) \
+ [getTwips $leftIndent]}]
}
set state(firstIndent) [getTwips $firstIndent]
set state(paragraphPending) 1
}
# getTwips --
#
# This procedure converts a distance in inches or centimeters into
# twips (1/1440 of an inch).
#
# Arguments:
# arg - A number followed by "i" or "c"
proc getTwips {arg} {
if {[scan $arg "%f%s" distance units] != 2} {
puts stderr "bad distance \"$arg\""
return 0
}
switch -- $units {
c {
set distance [expr {$distance * 567}]
}
i {
set distance [expr {$distance * 1440}]
}
default {
puts stderr "bad units in distance \"$arg\""
continue
}
}
return $distance
}
# incrNestingLevel --
#
# This procedure does the work of the .RS macro, which increments
# the number of state(indent)ations that affect things like .PP.
#
# Arguments:
# None.
proc incrNestingLevel {} {
global state
incr state(nestingLevel)
set oldp $state(paragraph)
set state(paragraph) 0
newPara 0i
set state(paragraph) $oldp
}
# decrNestingLevel --
#
# This procedure does the work of the .RE macro, which decrements
# the number of indentations that affect things like .PP.
#
# Arguments:
# None.
proc decrNestingLevel {} {
global state
if {$state(nestingLevel) == 0} {
puts stderr "Nesting level decremented below 0"
} else {
incr state(nestingLevel) -1
}
}
tcl8.4.20/tools/tcltk-man2html.tcl 0000755 0036047 0045461 00000136173 12153117057 015432 0 ustar dgp 771div #!/bin/sh
# The next line is executed by /bin/sh, but not tcl \
exec tclsh "$0" ${1+"$@"}
package require Tcl 8.4
# Convert Ousterhout format man pages into highly crosslinked
# hypertext.
#
# Along the way detect many unmatched font changes and other odd
# things.
#
# Note well, this program is a hack rather than a piece of software
# engineering. In that sense it's probably a good example of things
# that a scripting language, like Tcl, can do well. It is offered as
# an example of how someone might convert a specific set of man pages
# into hypertext, not as a general solution to the problem. If you
# try to use this, you'll be very much on your own.
#
# Copyright (c) 1995-1997 Roger E. Critchlow Jr
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
# Revisions:
# May 15, 1995 - initial release
# May 16, 1995 - added a back to home link to toplevel table of
# contents.
# May 18, 1995 - broke toplevel table of contents into separate
# pages for each section, and broke long table of contents
# into a one page for each man page.
# Mar 10, 1996 - updated for tcl7.5b3/tk4.1b3
# Apr 14, 1996 - incorporated command line parsing from Tom Tromey,
# -- thanks Tom.
# - updated for tcl7.5/tk4.1 final release.
# - converted to same copyright as the man pages.
# Sep 14, 1996 - made various modifications for tcl7.6b1/tk4.2b1
# Oct 18, 1996 - added tcl7.6/tk4.2 to the list of distributions.
# Oct 22, 1996 - major hacking on indentation code and elsewhere.
# Mar 4, 1997 -
# May 28, 1997 - added tcl8.0b1/tk8.0b1 to the list of distributions
# - cleaned source for tclsh8.0 execution
# - renamed output files for windoze installation
# - added spaces to tables
# Oct 24, 1997 - moved from 8.0b1 to 8.0 release
#
set Version "0.32"
proc parse_command_line {} {
global argv Version
# These variables determine where the man pages come from and where
# the converted pages go to.
global tcltkdir tkdir tcldir webdir build_tcl build_tk
# Set defaults based on original code.
set tcltkdir ../..
set tkdir {}
set tcldir {}
set webdir ../html
set build_tcl 0
set build_tk 0
# Default search version is a glob pattern
set useversion {{,[8-9].[0-9]{,.[0-9]{,[0-9]}}}}
# Handle arguments a la GNU:
# --version
# --useversion=
# --help
# --srcdir=/path
# --htmldir=/path
foreach option $argv {
switch -glob -- $option {
--version {
puts "tcltk-man-html $Version"
exit 0
}
--help {
puts "usage: tcltk-man-html \[OPTION\] ...\n"
puts " --help print this help, then exit"
puts " --version print version number, then exit"
puts " --srcdir=DIR find tcl and tk source below DIR"
puts " --htmldir=DIR put generated HTML in DIR"
puts " --tcl build tcl help"
puts " --tk build tk help"
puts " --useversion version of tcl/tk to search for"
exit 0
}
--srcdir=* {
# length of "--srcdir=" is 9.
set tcltkdir [string range $option 9 end]
}
--htmldir=* {
# length of "--htmldir=" is 10
set webdir [string range $option 10 end]
}
--useversion=* {
# length of "--useversion=" is 13
set useversion [string range $option 13 end]
}
--tcl {
set build_tcl 1
}
--tk {
set build_tk 1
}
default {
puts stderr "tcltk-man-html: unrecognized option -- `$option'"
exit 1
}
}
}
if {!$build_tcl && !$build_tk} {set build_tcl 1; set build_tk 1}
if {$build_tcl} {
# Find Tcl.
set tcldir [lindex [lsort [glob -nocomplain -tails -type d \
-directory $tcltkdir tcl$useversion]] end]
if {$tcldir == ""} then {
puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir"
exit 1
}
puts "using Tcl source directory $tcldir"
}
if {$build_tk} {
# Find Tk.
set tkdir [lindex [lsort [glob -nocomplain -tails -type d \
-directory $tcltkdir tk$useversion]] end]
if {$tkdir == ""} then {
puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir"
exit 1
}
puts "using Tk source directory $tkdir"
}
# the title for the man pages overall
global overall_title
set overall_title ""
if {$build_tcl} {append overall_title "[capitalize $tcldir]"}
if {$build_tcl && $build_tk} {append overall_title "/"}
if {$build_tk} {append overall_title "[capitalize $tkdir]"}
append overall_title " Manual"
}
proc capitalize {string} {
return [string toupper $string 0]
}
##
##
##
set manual(report-level) 1
proc manerror {msg} {
global manual
set name {}
set subj {}
if {[info exists manual(name)]} {
set name $manual(name)
}
if {[info exists manual(section)] && [string length $manual(section)]} {
puts stderr "$name: $manual(section): $msg"
} else {
puts stderr "$name: $msg"
}
}
proc manreport {level msg} {
global manual
if {$level < $manual(report-level)} {
manerror $msg
}
}
proc fatal {msg} {
global manual
manerror $msg
exit 1
}
##
## parsing
##
proc unquote arg {
return [string map [list \" {}] $arg]
}
proc parse-directive {line codename restname} {
upvar $codename code $restname rest
return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest]
}
proc process-text {text} {
global manual
# preprocess text
set text [string map [list \
{\&} "\t" \
{&} {&} \
{\\} {\} \
{\e} {\} \
{\ } { } \
{\|} { } \
{\0} { } \
{\%} {} \
"\\\n" "\n" \
\" {"} \
{<} {<} \
{>} {>} \
{\(+-} {±} \
{\fP} {\fR} \
{\.} . \
{\(bu} {•} \
] $text]
regsub -all {\\o'o\^'} $text {\ô} text; # o-circumflex in re_syntax.n
regsub -all {\\-\\\|\\-} $text -- text; # two hyphens
regsub -all -- {\\-\\\^\\-} $text -- text; # two hyphens
regsub -all {\\-} $text - text; # a hyphen
regsub -all "\\\\\n" $text "\\\\n" text; # backslashed newline
while {[string first "\\" $text] >= 0} {
# C R
if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text \
{\1\2\3} text]} continue
# B R
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \
{\1\2\3} text]} continue
# B I
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \
{\1\2\\fI\3} text]} continue
# I R
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \
{\1\2\3} text]} continue
# I B
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \
{\1\2\\fB\3} text]} continue
# B B, I I, R R
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text \
{\1\\fB\2\3} ntext]
|| [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text \
{\1\\fI\2\3} ntext]
|| [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text \
{\1\\fR\2\3} ntext]} {
manerror "process-text: impotent font change: $text"
set text $ntext
continue
}
# unrecognized
manerror "process-text: uncaught backslash: $text"
set text [string map [list "\\" "#92;"] $text]
}
return $text
}
##
## pass 2 text input and matching
##
proc open-text {} {
global manual
set manual(text-length) [llength $manual(text)]
set manual(text-pointer) 0
}
proc more-text {} {
global manual
return [expr {$manual(text-pointer) < $manual(text-length)}]
}
proc next-text {} {
global manual
if {[more-text]} {
set text [lindex $manual(text) $manual(text-pointer)]
incr manual(text-pointer)
return $text
}
manerror "read past end of text"
error "fatal"
}
proc is-a-directive {line} {
return [string match .* $line]
}
proc split-directive {line opname restname} {
upvar $opname op $restname rest
set op [string range $line 0 2]
set rest [string trim [string range $line 3 end]]
}
proc next-op-is {op restname} {
global manual
upvar $restname rest
if {[more-text]} {
set text [lindex $manual(text) $manual(text-pointer)]
if {[string equal -length 3 $text $op]} {
set rest [string range $text 4 end]
incr manual(text-pointer)
return 1
}
}
return 0
}
proc backup-text {n} {
global manual
if {$manual(text-pointer)-$n >= 0} {
incr manual(text-pointer) -$n
}
}
proc match-text args {
global manual
set nargs [llength $args]
if {$manual(text-pointer) + $nargs > $manual(text-length)} {
return 0
}
set nback 0
foreach arg $args {
if {![more-text]} {
backup-text $nback
return 0
}
set arg [string trim $arg]
set targ [string trim [lindex $manual(text) $manual(text-pointer)]]
if {[string equal $arg $targ]} {
incr nback
incr manual(text-pointer)
continue
}
if {[regexp {^@(\w+)$} $arg all name]} {
upvar $name var
set var $targ
incr nback
incr manual(text-pointer)
continue
}
if {[regexp -nocase {^(\.[A-Z][A-Z])@(\w+)$} $arg all op name]\
&& [string equal $op [lindex $targ 0]]} {
upvar $name var
set var [lrange $targ 1 end]
incr nback
incr manual(text-pointer)
continue
}
backup-text $nback
return 0
}
return 1
}
proc expand-next-text {n} {
global manual
return [join [lrange $manual(text) $manual(text-pointer) \
[expr {$manual(text-pointer)+$n-1}]] \n\n]
}
##
## pass 2 output
##
proc man-puts {text} {
global manual
lappend manual(output-$manual(wing-file)-$manual(name)) $text
}
##
## build hypertext links to tables of contents
##
proc long-toc {text} {
global manual
set here M[incr manual(section-toc-n)]
set there L[incr manual(long-toc-n)]
lappend manual(section-toc) \
"$text"
return "$text"
}
proc option-toc {name class switch} {
global manual
if {[string equal $manual(section) "WIDGET-SPECIFIC OPTIONS"]} {
# link the defined option into the long table of contents
set link [long-toc "$switch, $name, $class"]
regsub -- "$switch, $name, $class" $link "$switch" link
return $link
} elseif {[string equal $manual(name):$manual(section) \
"options:DESCRIPTION"]} {
# link the defined standard option to the long table of
# contents and make a target for the standard option references
# from other man pages.
set first [lindex $switch 0]
set here M$first
set there L[incr manual(long-toc-n)]
set manual(standard-option-$first) "$switch, $name, $class"
lappend manual(section-toc) "$switch, $name, $class"
return "$switch"
} else {
error "option-toc in $manual(name) section $manual(section)"
}
}
proc std-option-toc {name} {
global manual
if {[info exists manual(standard-option-$name)]} {
lappend manual(section-toc) $manual(standard-option-$name)
return $manual(standard-option-$name)
}
set here M[incr manual(section-toc-n)]
set there L[incr manual(long-toc-n)]
set other M$name
lappend manual(section-toc) "$name"
return "$name"
}
##
## process the widget option section
## in widget and options man pages
##
proc output-widget-options {rest} {
global manual
man-puts
lappend manual(section-toc)
backup-text 1
set para {}
while {[next-op-is .OP rest]} {
switch -exact [llength $rest] {
3 { foreach {switch name class} $rest { break } }
5 {
set switch [lrange $rest 0 2]
set name [lindex $rest 3]
set class [lindex $rest 4]
}
default {
fatal "bad .OP $rest"
}
}
if {![regexp {^(<.>)([-\w ]+)()$} $switch all oswitch switch cswitch]} {
if {![regexp {^(<.>)([-\w ]+) or ([-\w ]+)()$} $switch all oswitch switch1 switch2 cswitch]} {
error "not Switch: $switch"
} else {
set switch "$switch1$cswitch or $oswitch$switch2"
}
}
if {![regexp {^(<.>)([\w]*)()$} $name all oname name cname]} {
error "not Name: $name"
}
if {![regexp {^(<.>)([\w]*)()$} $class all oclass class cclass]} {
error "not Class: $class"
}
man-puts "$para- Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch"
man-puts "
- Database Name: $oname$name$cname"
man-puts "
- Database Class: $oclass$class$cclass"
man-puts
- [next-text]
set para
}
man-puts
lappend manual(section-toc)
}
##
## process .RS lists
##
proc output-RS-list {} {
global manual
if {[next-op-is .IP rest]} {
output-IP-list .RS .IP $rest
if {[match-text .RE .sp .RS @rest .IP @rest2]} {
man-puts $rest
output-IP-list .RS .IP $rest2
}
if {[match-text .RE .sp .RS @rest .RE]} {
man-puts
$rest
return
}
if {[next-op-is .RE rest]} {
return
}
}
man-puts
-
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
split-directive $line code rest
switch -exact $code {
.RE {
break
}
.SH - .SS {
manerror "unbalanced .RS at section end"
backup-text 1
break
}
default {
output-directive $line
}
}
} else {
man-puts $line
}
}
man-puts
}
##
## process .IP lists which may be plain indents,
## numeric lists, or definition lists
##
proc output-IP-list {context code rest} {
global manual
if {![string length $rest]} {
# blank label, plain indent, no contents entry
man-puts -
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
split-directive $line code rest
if {[string equal $code ".IP"] && [string equal $rest {}]} {
man-puts "
"
continue
}
if {[lsearch {.br .DS .RS} $code] >= 0} {
output-directive $line
} else {
backup-text 1
break
}
} else {
man-puts $line
}
}
man-puts
} else {
# labelled list, make contents
if {
[string compare $context ".SH"] &&
[string compare $context ".SS"]
} then {
man-puts
}
man-puts
lappend manual(section-toc)
backup-text 1
set accept_RE 0
set para {}
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
split-directive $line code rest
switch -exact $code {
.IP {
if {$accept_RE} {
output-IP-list .IP $code $rest
continue
}
if {[string equal $manual(section) "ARGUMENTS"] || \
[regexp {^\[\d+\]$} $rest]} {
man-puts "$para- $rest
- "
} elseif {[string equal {•} $rest]} {
man-puts "$para
- $rest "
} else {
man-puts "$para
- [long-toc $rest]
- "
}
if {[string equal $manual(name):$manual(section) \
"selection:DESCRIPTION"]} {
if {[match-text .RE @rest .RS .RS]} {
man-puts
- [long-toc $rest]
-
}
}
}
.sp -
.br -
.DS -
.CS {
output-directive $line
}
.RS {
if {[match-text .RS]} {
output-directive $line
incr accept_RE 1
} elseif {[match-text .CS]} {
output-directive .CS
incr accept_RE 1
} elseif {[match-text .PP]} {
output-directive .PP
incr accept_RE 1
} elseif {[match-text .DS]} {
output-directive .DS
incr accept_RE 1
} else {
output-directive $line
}
}
.PP {
if {[match-text @rest1 .br @rest2 .RS]} {
# yet another nroff kludge as above
man-puts "$para
- [long-toc $rest1]"
man-puts "
- [long-toc $rest2]
- "
incr accept_RE 1
} elseif {[match-text @rest .RE]} {
# gad, this is getting ridiculous
if {!$accept_RE} {
man-puts "
$rest
"
backup-text 1
set para {}
break
} else {
man-puts "$rest"
incr accept_RE -1
}
} elseif {$accept_RE} {
output-directive $line
} else {
backup-text 1
break
}
}
.RE {
if {!$accept_RE} {
backup-text 1
break
}
incr accept_RE -1
}
default {
backup-text 1
break
}
}
} else {
man-puts $line
}
set para
}
man-puts "$para
"
lappend manual(section-toc)
if {$accept_RE} {
manerror "missing .RE in output-IP-list"
}
}
}
##
## handle the NAME section lines
## there's only one line in the NAME section,
## consisting of a comma separated list of names,
## followed by a hyphen and a short description.
##
proc output-name {line} {
global manual
# split name line into pieces
regexp {^([^-]+) - (.*)$} $line all head tail
# output line to manual page untouched
man-puts $line
# output line to long table of contents
lappend manual(section-toc) - $line
# separate out the names for future reference
foreach name [split $head ,] {
set name [string trim $name]
if {[llength $name] > 1} {
manerror "name has a space: {$name}\nfrom: $line"
}
lappend manual(wing-toc) $name
lappend manual(name-$name) $manual(wing-file)/$manual(name)
}
}
##
## build a cross-reference link if appropriate
##
proc cross-reference {ref} {
global manual
if {[string match Tcl_* $ref]} {
set lref $ref
} elseif {[string match Tk_* $ref]} {
set lref $ref
} elseif {[string equal $ref "Tcl"]} {
set lref $ref
} else {
set lref [string tolower $ref]
}
##
## nothing to reference
##
if {![info exists manual(name-$lref)]} {
foreach name {array file history info interp string trace
after clipboard grab image option pack place selection tk tkwait update winfo wm} {
if {[regexp "^$name \[a-z0-9]*\$" $lref] && \
[info exists manual(name-$name)] && \
[string compare $manual(tail) "$name.n"]} {
return "$ref"
}
}
if {[lsearch {stdin stdout stderr end} $lref] >= 0} {
# no good place to send these
# tcl tokens?
# also end
}
return $ref
}
##
## would be a self reference
##
foreach name $manual(name-$lref) {
if {[lsearch $name $manual(wing-file)/$manual(name)] >= 0} {
return $ref
}
}
##
## multiple choices for reference
##
if {[llength $manual(name-$lref)] > 1} {
set tcl_i [lsearch -glob $manual(name-$lref) *TclCmd*]
set tcl_ref [lindex $manual(name-$lref) $tcl_i]
set tk_i [lsearch -glob $manual(name-$lref) *TkCmd*]
set tk_ref [lindex $manual(name-$lref) $tk_i]
if {$tcl_i >= 0 && "$manual(wing-file)" == {TclCmd} \
|| "$manual(wing-file)" == {TclLib}} {
return "$ref"
}
if {$tk_i >= 0 && "$manual(wing-file)" == {TkCmd} \
|| "$manual(wing-file)" == {TkLib}} {
return "$ref"
}
if {"$lref" == {exit} && "$manual(tail)" == {tclsh.1} && $tcl_i >= 0} {
return "$ref"
}
puts stderr "multiple cross reference to $ref in $manual(name-$lref) from $manual(wing-file)/$manual(tail)"
return $ref
}
##
## exceptions, sigh, to the rule
##
switch $manual(tail) {
canvas.n {
if {$lref == {focus}} {
upvar tail tail
set clue [string first command $tail]
if {$clue < 0 || $clue > 5} {
return $ref
}
}
if {[lsearch {bitmap image text} $lref] >= 0} {
return $ref
}
}
checkbutton.n -
radiobutton.n {
if {[lsearch {image} $lref] >= 0} {
return $ref
}
}
menu.n {
if {[lsearch {checkbutton radiobutton} $lref] >= 0} {
return $ref
}
}
options.n {
if {[lsearch {bitmap image set} $lref] >= 0} {
return $ref
}
}
regexp.n {
if {[lsearch {string} $lref] >= 0} {
return $ref
}
}
source.n {
if {[lsearch {text} $lref] >= 0} {
return $ref
}
}
history.n {
if {[lsearch {exec} $lref] >= 0} {
return $ref
}
}
return.n {
if {[lsearch {error continue break} $lref] >= 0} {
return $ref
}
}
scrollbar.n {
if {[lsearch {set} $lref] >= 0} {
return $ref
}
}
}
##
## return the cross reference
##
return "$ref"
}
##
## reference generation errors
##
proc reference-error {msg text} {
global manual
puts stderr "$manual(tail): $msg: {$text}"
return $text
}
##
## insert as many cross references into this text string as are appropriate
##
proc insert-cross-references {text} {
global manual
##
## we identify cross references by:
## ``quotation''
## emboldening
## Tcl_ prefix
## Tk_ prefix
## [a-zA-Z0-9]+ manual entry
## and we avoid messing with already anchored text
##
##
## find where each item lives
##
array set offset [list \
anchor [string first {} $text] \
quote [string first {``} $text] \
end-quote [string first {''} $text] \
bold [string first {} $text] \
end-bold [string first {} $text] \
tcl [string first {Tcl_} $text] \
tk [string first {Tk_} $text] \
Tcl1 [string first {Tcl manual entry} $text] \
Tcl2 [string first {Tcl overview manual entry} $text] \
]
##
## accumulate a list
##
foreach name [array names offset] {
if {$offset($name) >= 0} {
set invert($offset($name)) $name
lappend offsets $offset($name)
}
}
##
## if nothing, then we're done.
##
if {![info exists offsets]} {
return $text
}
##
## sort the offsets
##
set offsets [lsort -integer $offsets]
##
## see which we want to use
##
switch -exact $invert([lindex $offsets 0]) {
anchor {
if {$offset(end-anchor) < 0} {
return [reference-error {Missing end anchor} $text]
}
set head [string range $text 0 $offset(end-anchor)]
set tail [string range $text [expr {$offset(end-anchor)+1}] end]
return $head[insert-cross-references $tail]
}
quote {
if {$offset(end-quote) < 0} {
return [reference-error "Missing end quote" $text]
}
if {$invert([lindex $offsets 1]) == "tk"} {
set offsets [lreplace $offsets 1 1]
}
if {$invert([lindex $offsets 1]) == "tcl"} {
set offsets [lreplace $offsets 1 1]
}
switch -exact $invert([lindex $offsets 1]) {
end-quote {
set head [string range $text 0 [expr {$offset(quote)-1}]]
set body [string range $text [expr {$offset(quote)+2}] \
[expr {$offset(end-quote)-1}]]
set tail [string range $text \
[expr {$offset(end-quote)+2}] end]
return "$head``[cross-reference $body]''[insert-cross-references $tail]"
}
bold -
anchor {
set head [string range $text \
0 [expr {$offset(end-quote)+1}]]
set tail [string range $text \
[expr {$offset(end-quote)+2}] end]
return "$head[insert-cross-references $tail]"
}
}
return [reference-error "Uncaught quote case" $text]
}
bold {
if {$offset(end-bold) < 0} { return $text }
if {$invert([lindex $offsets 1]) == "tk"} {
set offsets [lreplace $offsets 1 1]
}
if {$invert([lindex $offsets 1]) == "tcl"} {
set offsets [lreplace $offsets 1 1]
}
switch -exact $invert([lindex $offsets 1]) {
end-bold {
set head [string range $text 0 [expr {$offset(bold)-1}]]
set body [string range $text [expr {$offset(bold)+3}] \
[expr {$offset(end-bold)-1}]]
set tail [string range $text \
[expr {$offset(end-bold)+4}] end]
return "$head[cross-reference $body][insert-cross-references $tail]"
}
anchor {
set head [string range $text \
0 [expr {$offset(end-bold)+3}]]
set tail [string range $text \
[expr {$offset(end-bold)+4}] end]
return "$head[insert-cross-references $tail]"
}
}
return [reference-error "Uncaught bold case" $text]
}
tk {
set head [string range $text 0 [expr {$offset(tk)-1}]]
set tail [string range $text $offset(tk) end]
if {![regexp {^(Tk_\w+)(.*)$} $tail all body tail]} {
return [reference-error "Tk regexp failed" $text]
}
return $head[cross-reference $body][insert-cross-references $tail]
}
tcl {
set head [string range $text 0 [expr {$offset(tcl)-1}]]
set tail [string range $text $offset(tcl) end]
if {![regexp {^(Tcl_\w+)(.*)$} $tail all body tail]} {
return [reference-error {Tcl regexp failed} $text]
}
return $head[cross-reference $body][insert-cross-references $tail]
}
Tcl1 -
Tcl2 {
set off [lindex $offsets 0]
set head [string range $text 0 [expr {$off-1}]]
set body Tcl
set tail [string range $text [expr {$off+3}] end]
return $head[cross-reference $body][insert-cross-references $tail]
}
end-anchor -
end-bold -
end-quote {
return [reference-error "Out of place $invert([lindex $offsets 0])" $text]
}
}
}
##
## process formatting directives
##
proc output-directive {line} {
global manual
# process format directive
split-directive $line code rest
switch -exact $code {
.BS -
.BE {
# man-puts
}
.SH - .SS {
# drain any open lists
# announce the subject
set manual(section) $rest
# start our own stack of stuff
set manual($manual(name)-$manual(section)) {}
lappend manual(has-$manual(section)) $manual(name)
if {[string compare .SS $code]} {
man-puts "[long-toc $manual(section)]
"
} else {
man-puts "[long-toc $manual(section)]
"
}
# some sections can simply free wheel their way through the text
# some sections can be processed in their own loops
switch -exact $manual(section) {
NAME {
if {[lsearch {CrtImgType.3 CrtItemType.3 CrtPhImgFmt.3} $manual(tail)] >= 0} {
# these manual pages have two NAME sections
if {[info exists manual($manual(tail)-NAME)]} {
return
}
set manual($manual(tail)-NAME) 1
}
set names {}
while {1} {
set line [next-text]
if {[is-a-directive $line]} {
backup-text 1
output-name [join $names { }]
return
} else {
lappend names [string trim $line]
}
}
}
SYNOPSIS {
lappend manual(section-toc)
while {1} {
if {[next-op-is .nf rest]
|| [next-op-is .br rest]
|| [next-op-is .fi rest]} {
continue
}
if {[next-op-is .SH rest]
|| [next-op-is .SS rest]
|| [next-op-is .BE rest]
|| [next-op-is .SO rest]} {
backup-text 1
break
}
if {[next-op-is .sp rest]} {
#man-puts
continue
}
set more [next-text]
if {[is-a-directive $more]} {
manerror "in SYNOPSIS found $more"
backup-text 1
break
} else {
foreach more [split $more \n] {
man-puts $more
if {[lsearch {TclLib TkLib} $manual(wing-file)] < 0} {
lappend manual(section-toc)
- $more
}
}
}
}
lappend manual(section-toc)
return
}
{SEE ALSO} {
while {[more-text]} {
if {[next-op-is .SH rest] || [next-op-is .SS rest]} {
backup-text 1
return
}
set more [next-text]
if {[is-a-directive $more]} {
manerror "$more"
backup-text 1
return
}
set nmore {}
foreach cr [split $more ,] {
set cr [string trim $cr]
if {![regexp {^.*$} $cr]} {
set cr $cr
}
if {[regexp {^(.*)\([13n]\)$} $cr all name]} {
set cr $name
}
lappend nmore $cr
}
man-puts [join $nmore {, }]
}
return
}
KEYWORDS {
while {[more-text]} {
if {[next-op-is .SH rest] || [next-op-is .SS rest]} {
backup-text 1
return
}
set more [next-text]
if {[is-a-directive $more]} {
manerror "$more"
backup-text 1
return
}
set keys {}
foreach key [split $more ,] {
set key [string trim $key]
lappend manual(keyword-$key) [list $manual(name) $manual(wing-file)/$manual(name).htm]
set initial [string toupper [string index $key 0]]
lappend keys "$key"
}
man-puts [join $keys {, }]
}
return
}
}
if {[next-op-is .IP rest]} {
output-IP-list $code .IP $rest
return
}
if {[next-op-is .PP rest]} {
return
}
return
}
.SO {
if {[match-text @stuff .SE]} {
output-directive {.SH STANDARD OPTIONS}
set opts {}
foreach line [split $stuff \n] {
foreach option [split $line \t] {
lappend opts $option
}
}
man-puts
lappend manual(section-toc)
foreach option [lsort $opts] {
man-puts "- [std-option-toc $option]"
}
man-puts
lappend manual(section-toc)
} else {
manerror "unexpected .SO format:\n[expand-next-text 2]"
}
}
.OP {
output-widget-options $rest
return
}
.IP {
output-IP-list .IP .IP $rest
return
}
.PP {
man-puts
}
.RS {
output-RS-list
return
}
.RE {
manerror "unexpected .RE"
return
}
.br {
man-puts
return
}
.DE {
manerror "unexpected .DE"
return
}
.DS {
if {[next-op-is .ta rest]} {
}
if {[match-text @stuff .DE]} {
man-puts
$stuff
} elseif {[match-text .fi @ul1 @ul2 .nf @stuff .DE]} {
man-puts "[lindex $ul1 1][lindex $ul2 1]\n$stuff
"
} else {
manerror "unexpected .DS format:\n[expand-next-text 2]"
}
return
}
.CS {
if {[next-op-is .ta rest]} {
}
if {[match-text @stuff .CE]} {
man-puts $stuff
} else {
manerror "unexpected .CS format:\n[expand-next-text 2]"
}
return
}
.CE {
manerror "unexpected .CE"
return
}
.sp {
man-puts
}
.ta {
# these are tab stop settings for short tables
switch -exact $manual(name):$manual(section) {
{bind:MODIFIERS} -
{bind:EVENT TYPES} -
{bind:BINDING SCRIPTS AND SUBSTITUTIONS} -
{expr:OPERANDS} -
{expr:MATH FUNCTIONS} -
{history:DESCRIPTION} -
{history:HISTORY REVISION} -
{re_syntax:BRACKET EXPRESSIONS} -
{switch:DESCRIPTION} -
{upvar:DESCRIPTION} {
return; # fix.me
}
default {
manerror "ignoring $line"
}
}
}
.nf {
if {[match-text @more .fi]} {
foreach more [split $more \n] {
man-puts $more
}
} elseif {[match-text .RS @more .RE .fi]} {
man-puts
-
foreach more [split $more \n] {
man-puts $more
}
man-puts
} elseif {[match-text .RS @more .RS @more2 .RE .RE .fi]} {
man-puts -
foreach more [split $more \n] {
man-puts $more
}
man-puts -
foreach more2 [split $more2 \n] {
man-puts $more2
}
man-puts
} elseif {[match-text .RS @more .RS @more2 .RE @more3 .RE .fi]} {
man-puts -
foreach more [split $more \n] {
man-puts $more
}
man-puts -
foreach more2 [split $more2 \n] {
man-puts $more2
}
man-puts
-
foreach more3 [split $more3 \n] {
man-puts $more3
}
man-puts
} elseif {[match-text .sp .RS @more .RS @more2 .sp .RE .RE .fi]} {
man-puts -
foreach more [split $more \n] {
man-puts $more
}
man-puts -
foreach more2 [split $more2 \n] {
man-puts $more2
}
man-puts
} elseif {[match-text .RS .sp @more .sp .RE .fi]} {
man-puts
-
foreach more [split $more \n] {
man-puts $more
}
man-puts
} else {
manerror "ignoring $line"
}
}
.fi {
manerror "ignoring $line"
}
.na -
.ad -
.UL -
.ne {
manerror "ignoring $line"
}
default {
manerror "unrecognized format directive: $line"
}
}
}
##
## merge copyright listings
##
proc merge-copyrights {l1 l2} {
foreach copyright [concat $l1 $l2] {
if {[regexp {^Copyright +\(c\) +(\d+) +(by +)?(\w.*)$} $copyright all date by who]} {
lappend dates($who) $date
continue
}
if {[regexp {^Copyright +\(c\) +(\d+)-(\d+) +(by +)?(\w.*)$} $copyright all from to by who]} {
for {set date $from} {$date <= $to} {incr date} {
lappend dates($who) $date
}
continue
}
if {[regexp {^Copyright +\(c\) +(\d+), *(\d+) +(by +)?(\w.*)$} $copyright all date1 date2 by who]} {
lappend dates($who) $date1 $date2
continue
}
puts "oops: $copyright"
}
foreach who [array names dates] {
set list [lsort $dates($who)]
if {[llength $list] == 1 || [lindex $list 0] == [lrange $list end end]} {
lappend merge "Copyright (c) [lindex $list 0] $who"
} else {
lappend merge "Copyright (c) [lindex $list 0]-[lrange $list end end] $who"
}
}
return [lsort $merge]
}
proc makedirhier {dir} {
if {![file isdirectory $dir] && \
[catch {file mkdir $dir} error]} {
return -code error "cannot create directory $dir: $error"
}
}
##
## foreach of the man directories specified by args
## convert manpages into hypertext in the directory
## specified by html.
##
proc make-man-pages {html args} {
global env manual overall_title tcltkdesc
makedirhier $html
set manual(short-toc-n) 1
set manual(short-toc-fp) [open $html/contents.htm w]
puts $manual(short-toc-fp) "
$overall_title"
puts $manual(short-toc-fp) "
$overall_title
"
set manual(merge-copyrights) {}
foreach arg $args {
if {$arg == ""} {continue}
set manual(wing-glob) [lindex $arg 0]
set manual(wing-name) [lindex $arg 1]
set manual(wing-file) [lindex $arg 2]
set manual(wing-description) [lindex $arg 3]
set manual(wing-copyrights) {}
makedirhier $html/$manual(wing-file)
set manual(wing-toc-fp) [open $html/$manual(wing-file)/contents.htm w]
# whistle
puts stderr "scanning section $manual(wing-name)"
# put the entry for this section into the short table of contents
puts $manual(short-toc-fp) "- $manual(wing-name)
- $manual(wing-description)"
# initialize the wing table of contents
puts $manual(wing-toc-fp) "$manual(wing-name) Manual"
puts $manual(wing-toc-fp) "
$manual(wing-name)
"
# initialize the short table of contents for this section
set manual(wing-toc) {}
# initialize the man directory for this section
makedirhier $html/$manual(wing-file)
# initialize the long table of contents for this section
set manual(long-toc-n) 1
# get the manual pages for this section
set manual(pages) [lsort [glob $manual(wing-glob)]]
if {[lsearch -glob $manual(pages) */options.n] >= 0} {
set n [lsearch $manual(pages) */options.n]
set manual(pages) "[lindex $manual(pages) $n] [lreplace $manual(pages) $n $n]"
}
# set manual(pages) [lrange $manual(pages) 0 5]
foreach manual(page) $manual(pages) {
# whistle
puts stderr "scanning page $manual(page)"
set manual(tail) [file tail $manual(page)]
set manual(name) [file root $manual(tail)]
set manual(section) {}
if {[lsearch {case pack-old menubar} $manual(name)] >= 0} {
# obsolete
manerror "discarding $manual(name)"
continue
}
set manual(infp) [open $manual(page)]
set manual(text) {}
set manual(partial-text) {}
foreach p {.RS .DS .CS .SO} {
set manual($p) 0
}
set manual(stack) {}
set manual(section) {}
set manual(section-toc) {}
set manual(section-toc-n) 1
set manual(copyrights) {}
lappend manual(all-pages) $manual(wing-file)/$manual(tail)
manreport 100 $manual(name)
while {[gets $manual(infp) line] >= 0} {
manreport 100 $line
if {[regexp {^[`'][/\\]} $line]} {
if {[regexp {Copyright \(c\).*$} $line copyright]} {
lappend manual(copyrights) $copyright
}
# comment
continue
}
if {"$line" == {'}} {
# comment
continue
}
if {[parse-directive $line code rest]} {
switch -exact $code {
.ad - .na - .so - .ne - .AS - .VE - .VS -
. {
# ignore
continue
}
}
if {"$manual(partial-text)" != {}} {
lappend manual(text) [process-text $manual(partial-text)]
set manual(partial-text) {}
}
switch -exact $code {
.SH - .SS {
if {[llength $rest] == 0} {
gets $manual(infp) rest
}
lappend manual(text) "$code [unquote $rest]"
}
.TH {
lappend manual(text) "$code [unquote $rest]"
}
.HS - .UL -
.ta {
lappend manual(text) "$code [unquote $rest]"
}
.BS - .BE - .br - .fi - .sp -
.nf {
if {"$rest" != {}} {
manerror "unexpected argument: $line"
}
lappend manual(text) $code
}
.AP {
lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]]
}
.IP {
regexp {^(.*) +\d+$} $rest all rest
lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]"
}
.TP {
while {[is-a-directive [set next [gets $manual(infp)]]]} {
manerror "ignoring $next after .TP"
}
if {"$next" != {'}} {
lappend manual(text) ".IP [process-text $next]"
}
}
.OP {
lappend manual(text) [concat .OP [process-text \
"\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]]
}
.PP -
.LP {
lappend manual(text) {.PP}
}
.RS {
incr manual(.RS)
lappend manual(text) $code
}
.RE {
incr manual(.RS) -1
lappend manual(text) $code
}
.SO {
incr manual(.SO)
lappend manual(text) $code
}
.SE {
incr manual(.SO) -1
lappend manual(text) $code
}
.DS {
incr manual(.DS)
lappend manual(text) $code
}
.DE {
incr manual(.DS) -1
lappend manual(text) $code
}
.CS {
incr manual(.CS)
lappend manual(text) $code
}
.CE {
incr manual(.CS) -1
lappend manual(text) $code
}
.de {
while {[gets $manual(infp) line] >= 0} {
if {[string match "..*" $line]} {
break
}
}
}
.. {
error "found .. outside of .de"
}
default {
manerror "unrecognized format directive: $line"
}
}
} else {
if {$manual(partial-text) == ""} {
set manual(partial-text) $line
} else {
append manual(partial-text) \n$line
}
}
}
if {$manual(partial-text) != ""} {
lappend manual(text) [process-text $manual(partial-text)]
}
close $manual(infp)
# fixups
if {$manual(.RS) != 0} {
if {$manual(name) != "selection"} {
puts "unbalanced .RS .RE"
}
}
if {$manual(.DS) != 0} {
puts "unbalanced .DS .DE"
}
if {$manual(.CS) != 0} {
puts "unbalanced .CS .CE"
}
if {$manual(.SO) != 0} {
puts "unbalanced .SO .SE"
}
# output conversion
open-text
if {[next-op-is .HS rest]} {
set manual($manual(name)-title) \
"[lrange $rest 1 end] [lindex $rest 0] manual page"
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
output-directive $line
} else {
man-puts $line
}
}
man-puts
foreach copyright $manual(copyrights) {
man-puts "Copyright © [lrange $copyright 2 end]"
}
man-puts "Copyright © 1995-1997 Roger E. Critchlow Jr."
set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)]
} elseif {[next-op-is .TH rest]} {
set manual($manual(name)-title) "[lrange $rest 4 end] - [lindex $rest 0] manual page"
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
output-directive $line
} else {
man-puts $line
}
}
man-puts
foreach copyright $manual(copyrights) {
man-puts "Copyright © [lrange $copyright 2 end]"
}
man-puts "Copyright © 1995-1997 Roger E. Critchlow Jr."
set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)]
} else {
manerror "no .HS or .TH record found"
}
#
# make the long table of contents for this page
#
set manual(toc-$manual(wing-file)-$manual(name)) [concat $manual(section-toc)
]
}
#
# make the wing table of contents for the section
#
set width 0
foreach name $manual(wing-toc) {
if {[string length $name] > $width} {
set width [string length $name]
}
}
set perline [expr {120 / $width}]
set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}]
set n 0
catch {unset rows}
foreach name [lsort $manual(wing-toc)] {
set tail $manual(name-$name)
if {[llength $tail] > 1} {
manerror "$name is defined in more than one file: $tail"
set tail [lindex $tail [expr {[llength $tail]-1}]]
}
set tail [file tail $tail]
append rows([expr {$n%$nrows}]) \
" $name"
incr n
}
puts $manual(wing-toc-fp)
foreach row [lsort -integer [array names rows]] {
puts $manual(wing-toc-fp) $rows($row)
}
puts $manual(wing-toc-fp)
#
# insert wing copyrights
#
puts $manual(wing-toc-fp) "
"
foreach copyright $manual(wing-copyrights) {
puts $manual(wing-toc-fp) "Copyright © [lrange $copyright 2 end]"
}
puts $manual(wing-toc-fp) "Copyright © 1995-1997 Roger E. Critchlow Jr."
puts $manual(wing-toc-fp) ""
close $manual(wing-toc-fp)
set manual(merge-copyrights) [merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)]
}
##
## build the keyword index.
##
proc strcasecmp {a b} { return [string compare -nocase $a $b] }
set keys [lsort -command strcasecmp [array names manual keyword-*]]
makedirhier $html/Keywords
catch {eval file delete -- [glob $html/Keywords/*]}
puts $manual(short-toc-fp) "- Keywords
- The keywords from the $tcltkdesc man pages."
set keyfp [open $html/Keywords/contents.htm w]
puts $keyfp "$tcltkdesc Keywords"
puts $keyfp "
$tcltkdesc Keywords
"
foreach a {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} {
puts $keyfp "$a"
set afp [open $html/Keywords/$a.htm w]
puts $afp "$tcltkdesc Keywords - $a"
puts $afp "
$tcltkdesc Keywords - $a
"
foreach b {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} {
puts $afp "$b"
}
puts $afp "
"
foreach k $keys {
if {[string match -nocase "keyword-${a}*" $k]} {
set k [string range $k 8 end]
puts $afp "- $k
- "
set refs {}
foreach man $manual(keyword-$k) {
set name [lindex $man 0]
set file [lindex $man 1]
lappend refs "$name"
}
puts $afp [join $refs {, }]
}
}
puts $afp "
"
# insert merged copyrights
foreach copyright $manual(merge-copyrights) {
puts $afp "Copyright © [lrange $copyright 2 end]"
}
puts $afp "Copyright © 1995-1997 Roger E. Critchlow Jr."
puts $afp ""
close $afp
}
puts $keyfp "
"
# insert merged copyrights
foreach copyright $manual(merge-copyrights) {
puts $keyfp "Copyright © [lrange $copyright 2 end]"
}
puts $keyfp "Copyright © 1995-1997 Roger E. Critchlow Jr."
puts $keyfp
close $keyfp
##
## finish off short table of contents
##
puts $manual(short-toc-fp) { - Source
- More information about these man pages.}
puts $manual(short-toc-fp) "
"
# insert merged copyrights
foreach copyright $manual(merge-copyrights) {
puts $manual(short-toc-fp) "Copyright © [lrange $copyright 2 end]"
}
puts $manual(short-toc-fp) "Copyright © 1995-1997 Roger E. Critchlow Jr."
puts $manual(short-toc-fp) ""
close $manual(short-toc-fp)
##
## output man pages
##
unset manual(section)
foreach path $manual(all-pages) {
set manual(wing-file) [file dirname $path]
set manual(tail) [file tail $path]
set manual(name) [file root $manual(tail)]
set text $manual(output-$manual(wing-file)-$manual(name))
set ntext 0
foreach item $text {
incr ntext [llength [split $item \n]]
incr ntext
}
set toc $manual(toc-$manual(wing-file)-$manual(name))
set ntoc 0
foreach item $toc {
incr ntoc [llength [split $item \n]]
incr ntoc
}
puts stderr "rescanning page $manual(name) $ntoc/$ntext"
set manual(outfp) [open $html/$manual(wing-file)/$manual(name).htm w]
puts $manual(outfp) "$manual($manual(name)-title)"
if {($ntext > 60) && ($ntoc > 32) || [lsearch {
Hash LinkVar SetVar TraceVar ConfigWidg CrtImgType CrtItemType
CrtPhImgFmt DoOneEvent GetBitmap GetColor GetCursor GetDash
GetJustify GetPixels GetVisual ParseArgv QueueEvent
} $manual(tail)] >= 0} {
foreach item $toc {
puts $manual(outfp) $item
}
}
foreach item $text {
puts $manual(outfp) [insert-cross-references $item]
}
puts $manual(outfp)
close $manual(outfp)
}
return {}
}
parse_command_line
set tcltkdesc ""; set cmdesc ""; set appdir ""
if {$build_tcl} {append tcltkdesc "Tcl"; append cmdesc "Tcl"; append appdir "$tcldir"}
if {$build_tcl && $build_tk} {append tcltkdesc "/"; append cmdesc " and "; append appdir ","}
if {$build_tk} {append tcltkdesc "Tk"; append cmdesc "Tk"; append appdir "$tkdir"}
set usercmddesc "The interpreters which implement $cmdesc."
set tclcmddesc {The commands which the tclsh interpreter implements.}
set tkcmddesc {The additional commands which the wish interpreter implements.}
set tcllibdesc {The C functions which a Tcl extended C program may use.}
set tklibdesc {The additional C functions which a Tk extended C program may use.}
if {1} {
if {[catch {
make-man-pages $webdir \
"$tcltkdir/{$appdir}/doc/*.1 \"$tcltkdesc Applications\" UserCmd {$usercmddesc}" \
[expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.n {Tcl Commands} TclCmd {$tclcmddesc}" : ""}] \
[expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.n {Tk Commands} TkCmd {$tkcmddesc}" : ""}] \
[expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.3 {Tcl Library} TclLib {$tcllibdesc}" : ""}] \
[expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.3 {Tk Library} TkLib {$tklibdesc}" : ""}]
} error]} {
puts $error\n$errorInfo
}
}
tcl8.4.20/tools/index.tcl 0000644 0036047 0045461 00000010303 11737050675 013670 0 ustar dgp 771div # index.tcl --
#
# This file defines procedures that are used during the first pass of
# the man page conversion. It is used to extract information used to
# generate a table of contents and a keyword list.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Global variables used by these scripts:
#
# state - state variable that controls action of text proc.
#
# topics - array indexed by (package,section,topic) with value
# of topic ID.
#
# keywords - array indexed by keyword string with value of topic ID.
#
# curID - current topic ID, starts at 0 and is incremented for
# each new topic file.
#
# curPkg - current package name (e.g. Tcl).
#
# curSect - current section title (e.g. "Tcl Built-In Commands").
#
# getPackages --
#
# Generate a sorted list of package names from the topics array.
#
# Arguments:
# none.
proc getPackages {} {
global topics
foreach i [array names topics] {
regsub {^(.*),.*,.*$} $i {\1} i
set temp($i) {}
}
lsort [array names temp]
}
# getSections --
#
# Generate a sorted list of section titles in the specified package
# from the topics array.
#
# Arguments:
# pkg - Name of package to search.
proc getSections {pkg} {
global topics
regsub -all {[][*?\\]} $pkg {\\&} pkg
foreach i [array names topics "${pkg},*"] {
regsub {^.*,(.*),.*$} $i {\1} i
set temp($i) {}
}
lsort [array names temp]
}
# getTopics --
#
# Generate a sorted list of topics in the specified section of the
# specified package from the topics array.
#
# Arguments:
# pkg - Name of package to search.
# sect - Name of section to search.
proc getTopics {pkg sect} {
global topics
regsub -all {[][*?\\]} $pkg {\\&} pkg
regsub -all {[][*?\\]} $sect {\\&} sect
foreach i [array names topics "${pkg},${sect},*"] {
regsub {^.*,.*,(.*)$} $i {\1} i
set temp($i) {}
}
lsort [array names temp]
}
# text --
#
# This procedure adds entries to the hypertext arrays topics and keywords.
#
# Arguments:
# string - Text to index.
proc text string {
global state curID curPkg curSect topics keywords
switch $state {
NAME {
foreach i [split $string ","] {
set topic [string trim $i]
set index "$curPkg,$curSect,$topic"
if {[info exists topics($index)]
&& [string compare $topics($index) $curID] != 0} {
puts stderr "duplicate topic $topic in $curPkg"
}
set topics($index) $curID
lappend keywords($topic) $curID
}
}
KEY {
foreach i [split $string ","] {
lappend keywords([string trim $i]) $curID
}
}
DT -
OFF -
DASH {}
default {
puts stderr "text: unknown state: $state"
}
}
}
# macro --
#
# This procedure is invoked to process macro invocations that start
# with "." (instead of ').
#
# Arguments:
# name - The name of the macro (without the ".").
# args - Any additional arguments to the macro.
proc macro {name args} {
switch $name {
SH {
global state
switch $args {
NAME {
if {$state == "INIT" } {
set state NAME
}
}
DESCRIPTION {set state DT}
INTRODUCTION {set state DT}
KEYWORDS {set state KEY}
default {set state OFF}
}
}
TH {
global state curID curPkg curSect topics keywords
set state INIT
if {[llength $args] != 5} {
set args [join $args " "]
puts stderr "Bad .TH macro: .$name $args"
}
incr curID
set topic [lindex $args 0] ;# Tcl_UpVar
set curPkg [lindex $args 3] ;# Tcl
set curSect [lindex $args 4] ;# {Tcl Library Procedures}
regsub -all {\\ } $curSect { } curSect
set index "$curPkg,$curSect,$topic"
set topics($index) $curID
lappend keywords($topic) $curID
}
}
}
# dash --
#
# This procedure is invoked to handle dash characters ("\-" in
# troff). It only function in pass1 is to terminate the NAME state.
#
# Arguments:
# None.
proc dash {} {
global state
if {$state == "NAME"} {
set state DASH
}
}
# initGlobals, tab, font, char, macro2 --
#
# These procedures do nothing during the first pass.
#
# Arguments:
# None.
proc initGlobals {} {}
proc newline {} {}
proc tab {} {}
proc font type {}
proc char name {}
proc macro2 {name args} {}
tcl8.4.20/tools/uniClass.tcl 0000644 0036047 0045461 00000006456 11737050675 014360 0 ustar dgp 771div #!/bin/sh
# The next line is executed by /bin/sh, but not tcl \
exec tclsh "$0" ${1+"$@"}
#
# uniClass.tcl --
#
# Generates the character ranges and singletons that are used in
# generic/regc_locale.c for translation of character classes.
# This file must be generated using a tclsh that contains the
# correct corresponding tclUniData.c file (generated by uniParse.tcl)
# in order for the class ranges to match.
#
proc emitRange {first last} {
global ranges numranges chars numchars extchars extranges
if {$first < ($last-1)} {
if {!$extranges && ($first) > 0xffff} {
set extranges 1
set numranges 0
set ranges [string trimright $ranges " \n\r\t,"]
append ranges "\n#if TCL_UTF_MAX > 4\n ,"
}
append ranges [format "{0x%x, 0x%x}, " \
$first $last]
if {[incr numranges] % 4 == 0} {
set ranges [string trimright $ranges]
append ranges "\n "
}
} else {
if {!$extchars && ($first) > 0xffff} {
set extchars 1
set numchars 0
set chars [string trimright $chars " \n\r\t,"]
append chars "\n#if TCL_UTF_MAX > 4\n ,"
}
append chars [format "0x%x, " $first]
incr numchars
if {$numchars % 9 == 0} {
set chars [string trimright $chars]
append chars "\n "
}
if {$first != $last} {
append chars [format "0x%x, " $last]
incr numchars
if {$numchars % 9 == 0} {
append chars "\n "
}
}
}
}
proc genTable {type} {
global first last ranges numranges chars numchars extchars extranges
set first -2
set last -2
set ranges " "
set numranges 0
set chars " "
set numchars 0
set extchars 0
set extranges 0
for {set i 0} {$i <= 0x10ffff} {incr i} {
if {$i == 0xd800} {
# Skip surrogates
set i 0xdc00
}
if {[string is $type [format %c $i]]} {
if {$i == ($last + 1)} {
set last $i
} else {
if {$first > 0} {
emitRange $first $last
}
set first $i
set last $i
}
}
}
emitRange $first $last
set ranges [string trimright $ranges "\t\n ,"]
if {$extranges} {
append ranges "\n#endif"
}
set chars [string trimright $chars "\t\n ,"]
if {$extchars} {
append chars "\n#endif"
}
if {$ranges ne ""} {
puts "static CONST crange ${type}RangeTable\[\] = {\n$ranges\n};\n"
puts "#define NUM_[string toupper $type]_RANGE (sizeof(${type}RangeTable)/sizeof(crange))\n"
} else {
puts "/* no contiguous ranges of $type characters */\n"
}
if {$chars ne ""} {
puts "static CONST chr ${type}CharTable\[\] = {\n$chars\n};\n"
puts "#define NUM_[string toupper $type]_CHAR (sizeof(${type}CharTable)/sizeof(chr))\n"
} else {
puts "/*\n * no singletons of $type characters.\n */\n"
}
}
puts "/*
* Declarations of Unicode character ranges. This code
* is automatically generated by the tools/uniClass.tcl script
* and used in generic/regc_locale.c. Do not modify by hand.
*/
"
foreach {type desc} {
alpha "alphabetic characters"
control "control characters"
digit "decimal digit characters"
punct "punctuation characters"
space "white space characters"
lower "lowercase characters"
upper "uppercase characters"
graph "unicode print characters excluding space"
} {
puts "/*\n * Unicode: $desc.\n */\n"
genTable $type
}
puts "/*
* End of auto-generated Unicode character ranges declarations.
*/"
tcl8.4.20/tools/regexpTestLib.tcl 0000644 0036047 0045461 00000016716 11737050675 015360 0 ustar dgp 771div # regexpTestLib.tcl --
#
# This file contains tcl procedures used by spencer2testregexp.tcl and
# spencer2regexp.tcl, which are programs written to convert Henry
# Spencer's test suite to tcl test files.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
proc readInputFile {} {
global inFileName
global lineArray
set fileId [open $inFileName r]
set i 0
while {[gets $fileId line] >= 0} {
set len [string length $line]
if {($len > 0) && ([string index $line [expr $len - 1]] == "\\")} {
if {[info exists lineArray(c$i)] == 0} {
set lineArray(c$i) 1
} else {
incr lineArray(c$i)
}
set line [string range $line 0 [expr $len - 2]]
append lineArray($i) $line
continue
}
if {[info exists lineArray(c$i)] == 0} {
set lineArray(c$i) 1
} else {
incr lineArray(c$i)
}
append lineArray($i) $line
incr i
}
close $fileId
return $i
}
#
# strings with embedded @'s are truncated
# unpreceeded @'s are replaced by {}
#
proc removeAts {ls} {
set len [llength $ls]
set newLs {}
foreach item $ls {
regsub @.* $item "" newItem
lappend newLs $newItem
}
return $newLs
}
proc convertErrCode {code} {
set errMsg "couldn't compile regular expression pattern:"
if {[string compare $code "INVARG"] == 0} {
return "$errMsg invalid argument to regex routine"
} elseif {[string compare $code "BADRPT"] == 0} {
return "$errMsg ?+* follows nothing"
} elseif {[string compare $code "BADBR"] == 0} {
return "$errMsg invalid repetition count(s)"
} elseif {[string compare $code "BADOPT"] == 0} {
return "$errMsg invalid embedded option"
} elseif {[string compare $code "EPAREN"] == 0} {
return "$errMsg unmatched ()"
} elseif {[string compare $code "EBRACE"] == 0} {
return "$errMsg unmatched {}"
} elseif {[string compare $code "EBRACK"] == 0} {
return "$errMsg unmatched \[\]"
} elseif {[string compare $code "ERANGE"] == 0} {
return "$errMsg invalid character range"
} elseif {[string compare $code "ECTYPE"] == 0} {
return "$errMsg invalid character class"
} elseif {[string compare $code "ECOLLATE"] == 0} {
return "$errMsg invalid collating element"
} elseif {[string compare $code "EESCAPE"] == 0} {
return "$errMsg invalid escape sequence"
} elseif {[string compare $code "BADPAT"] == 0} {
return "$errMsg invalid regular expression"
} elseif {[string compare $code "ESUBREG"] == 0} {
return "$errMsg invalid backreference number"
} elseif {[string compare $code "IMPOSS"] == 0} {
return "$errMsg can never match"
}
return "$errMsg $code"
}
proc writeOutputFile {numLines fcn} {
global outFileName
global lineArray
# open output file and write file header info to it.
set fileId [open $outFileName w]
puts $fileId "# Commands covered: $fcn"
puts $fileId "#"
puts $fileId "# This Tcl-generated file contains tests for the $fcn tcl command."
puts $fileId "# Sourcing this file into Tcl runs the tests and generates output for"
puts $fileId "# errors. No output means no errors were found. Setting VERBOSE to"
puts $fileId "# -1 will run tests that are known to fail."
puts $fileId "#"
puts $fileId "# Copyright (c) 1998 Sun Microsystems, Inc."
puts $fileId "#"
puts $fileId "# See the file \"license.terms\" for information on usage and redistribution"
puts $fileId "# of this file, and for a DISCLAIMER OF ALL WARRANTIES."
puts $fileId "#"
puts $fileId "\# SCCS: \%Z\% \%M\% \%I\% \%E\% \%U\%"
puts $fileId "\nproc print \{arg\} \{puts \$arg\}\n"
puts $fileId "if \{\[string compare test \[info procs test\]\] == 1\} \{"
puts $fileId " source defs ; set VERBOSE -1\n\}\n"
puts $fileId "if \{\$VERBOSE != -1\} \{"
puts $fileId " proc print \{arg\} \{\}\n\}\n"
puts $fileId "#"
puts $fileId "# The remainder of this file is Tcl tests that have been"
puts $fileId "# converted from Henry Spencer's regexp test suite."
puts $fileId "#\n"
set lineNum 0
set srcLineNum 1
while {$lineNum < $numLines} {
set currentLine $lineArray($lineNum)
# copy comment string to output file and continue
if {[string index $currentLine 0] == "#"} {
puts $fileId $currentLine
incr srcLineNum $lineArray(c$lineNum)
incr lineNum
continue
}
set len [llength $currentLine]
# copy empty string to output file and continue
if {$len == 0} {
puts $fileId "\n"
incr srcLineNum $lineArray(c$lineNum)
incr lineNum
continue
}
if {($len < 3)} {
puts "warning: test is too short --\n\t$currentLine"
incr srcLineNum $lineArray(c$lineNum)
incr lineNum
continue
}
puts $fileId [convertTestLine $currentLine $len $lineNum $srcLineNum]
incr srcLineNum $lineArray(c$lineNum)
incr lineNum
}
close $fileId
}
proc convertTestLine {currentLine len lineNum srcLineNum} {
regsub -all {(?b)\\} $currentLine {\\\\} currentLine
set re [lindex $currentLine 0]
set flags [lindex $currentLine 1]
set str [lindex $currentLine 2]
# based on flags, decide whether to skip the test
if {[findSkipFlag $flags]} {
regsub -all {\[|\]|\(|\)|\{|\}|\#} $currentLine {\&} line
set msg "\# skipping char mapping test from line $srcLineNum\n"
append msg "print \{... skip test from line $srcLineNum: $line\}"
return $msg
}
# perform mapping if '=' flag exists
set noBraces 0
if {[regexp {=|>} $flags] == 1} {
regsub -all {_} $currentLine {\\ } currentLine
regsub -all {A} $currentLine {\\007} currentLine
regsub -all {B} $currentLine {\\b} currentLine
regsub -all {E} $currentLine {\\033} currentLine
regsub -all {F} $currentLine {\\f} currentLine
regsub -all {N} $currentLine {\\n} currentLine
# if and \r substitutions are made, do not wrap re, flags,
# str, and result in braces
set noBraces [regsub -all {R} $currentLine {\\\u000D} currentLine]
regsub -all {T} $currentLine {\\t} currentLine
regsub -all {V} $currentLine {\\v} currentLine
if {[regexp {=} $flags] == 1} {
set re [lindex $currentLine 0]
}
set str [lindex $currentLine 2]
}
set flags [removeFlags $flags]
# find the test result
set numVars [expr $len - 3]
set vars {}
set vals {}
set result 0
set v 0
if {[regsub {\*} "$flags" "" newFlags] == 1} {
# an error is expected
if {[string compare $str "EMPTY"] == 0} {
# empty regexp is not an error
# skip this test
return "\# skipping the empty-re test from line $srcLineNum\n"
}
set flags $newFlags
set result "\{1 \{[convertErrCode $str]\}\}"
} elseif {$numVars > 0} {
# at least 1 match is made
if {[regexp {s} $flags] == 1} {
set result "\{0 1\}"
} else {
while {$v < $numVars} {
append vars " var($v)"
append vals " \$var($v)"
incr v
}
set tmp [removeAts [lrange $currentLine 3 $len]]
set result "\{0 \{1 $tmp\}\}"
if {$noBraces} {
set result "\[subst $result\]"
}
}
} else {
# no match is made
set result "\{0 0\}"
}
# set up the test and write it to the output file
set cmd [prepareCmd $flags $re $str $vars $noBraces]
if {$cmd == -1} {
return "\# skipping test with metasyntax from line $srcLineNum\n"
}
set test "test regexp-1.$srcLineNum \{converted from line $srcLineNum\} \{\n"
append test "\tcatch {unset var}\n"
append test "\tlist \[catch \{ \n"
append test "\t\tset match \[$cmd\] \n"
append test "\t\tlist \$match $vals \n"
append test "\t\} msg\] \$msg \n"
append test "\} $result \n"
return $test
}
tcl8.4.20/tools/feather.bmp 0000644 0036047 0045461 00000004066 11737050675 014204 0 ustar dgp 771div BM6 6 ( Ф Ф РРР РмР №ЪІ @ ` Р р @ @ @@ @` @ @ @Р @р ` ` `@ `` ` ` `Р `р @ ` Р р @ ` Р р Р Р Р@ Р` Р Р РР Рр р р р@ р` р р рР рр @ @ @ @ @ ` @ @ @ Р @ р @ @ @ @ @ ` @ @ @ Р @ р @@ @@ @@@ @@` @@ @@ @@Р @@р @` @` @`@ @`` @` @` @`Р @`р @ @ @@ @` @ @ @Р @р @ @ @ @ @ ` @ @ @ Р @ р @Р @Р @Р@ @Р` @Р @Р @РР @Рр @р @р @р@ @р` @р @р @рР @рр @ ` Р р @ ` Р р @ @ @@ @` @ @ @Р @р ` ` `@ `` ` ` `Р `р @ ` Р р @ ` Р р Р Р Р@ Р` Р Р РР Рр р р р@ р` р р рР рр Р Р Р @ Р ` Р Р Р Р Р р Р Р Р @ Р ` Р Р Р Р Р р Р@ Р@ Р@@ Р@` Р@ Р@ Р@Р Р@р Р` Р` Р`@ Р`` Р` Р` Р`Р Р`р Р Р Р@ Р` Р Р РР Рр Р Р Р @ Р ` Р Р Р Р Р р РР РР РР@ РР` РР РР №ћџ Є џ џ џџ џ џ џ џџ џџџ ћћЄћћћћћћћћћћћћћћћћћћћћћћћћћћћћћћћЄћћћћћћћћћћћћћћћћћћћћћћћћћћћћћћћЄћћћћћћћћћћћћћћћћћћћћћћћћћћћћћћћЄћћћћћћћћћћћћћћћћћћћћћћћћћћћћћћћћЄћћћћћћћћћћћћћћћћћћћћћћћћћћћћћћћ ћћћћћћћћћЄЄћћћћћћћћћћћћћЄћЄаРРР ћћћћћћћћћЄЄћћћћћћћћћћћћЄћЄРРРРРР ћћћћћћћћћћЄћћћћћћћћћћћќЄћаРРРРРРћћћћћћћћћЄћћћћћћћћћћРќїаРРРРРРРћћћћЄЄћћћћћћћћћћћћћРќќїРРРРРРРРћћћћћЄћћћћћћћћћћћћћРќќЄРРРРРРРРћћћћћЄћћћћћћћћћћћћРќќќаРРРРРРРРћћћћћЄћћћћћћћћћћћРќќќќаРРРРРРРРћћћћћћћћћћћћћћћћћРќќќќаРРРРРРРћћћћћћћћћћћћћћћћћРќќќќќаРРРРРРћћћћћћћћћћћћћћћћћћРќќќќќїРРРРРР ћћћћћћћћћћћћћћћћћРќќќќќїРРРРРРР ћћћћћћћћћћћћћћћћРќќќќаќїРРРРРРР ћћћћћћћћћћћћћћћћРќаќќќќЄРРРРРРР ћћћћћћћћћћћћћћћћРќќќќаќаЄРРРРРР ћћћћћћћћћћћћћћћћРќќаќаќаРРРРРР ћћћћћћћћћћћћћћћћРќќаќаааќРРРРРР ћћћћћћћћЄћћћћћћћћРаќаќаааќРРРРР ћћћћћћћЄћћћЄћћћћћРаќаааааќРРРРР ћћћћћћћћЄћћћЄћћћћћРќааааааќРРРР ћћћћћћћЄћћћћЄћћћћћРРќаааааќРРРР ћћћћћћћћЄћћћћЄћћћћћћРќаааааќРРР ћћћћћћћћЄћћћћЄЄћћћћћРРќааааќРРР ћћћћћћћћћЄћћћћћЄЄћћћћћРРќаааќРР ћћћћћћћћћћћћћћћћћћћћћћћћРРРќаќР ћћћћћћћћћћћћћћћћћћћћћћћћћћћРРРРћћ tcl8.4.20/tools/checkLibraryDoc.tcl 0000755 0036047 0045461 00000016302 11737050674 015620 0 ustar dgp 771div # checkLibraryDoc.tcl --
#
# This script attempts to determine what APIs exist in the source base that
# have not been documented. By grepping through all of the doc/*.3 man
# pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list
# against the list of Pkg_ APIs found in the source (e.g., tcl8.2/*/*.[ch])
# we create six lists:
# 1) APIs in Source not in Docs.
# 2) APIs in Docs not in Source.
# 3) Internal APIs and structs.
# 4) Misc APIs and structs that we are not documenting.
# 5) Command APIs (e.g., Tcl_ArrayObjCmd.)
# 6) Proc pointers (e.g., Tcl_CloseProc.)
#
# Note: Each list is "a best guess" approximation. If developers write
# non-standard code, this script will produce erroneous results. Each
# list should be carefully checked for accuracy.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
lappend auto_path "c:/program\ files/tclpro1.2/win32-ix86/bin"
#lappend auto_path "/home/surles/cvs/tclx8.0/tcl/unix"
if {[catch {package require Tclx}]} {
puts "error: could not load TclX. Please set TCL_LIBRARY."
exit 1
}
# A list of structs that are known to be undocumented.
set StructList {
Tcl_AsyncHandler \
Tcl_CallFrame \
Tcl_Condition \
Tcl_Encoding \
Tcl_EncodingState \
Tcl_EncodingType \
Tcl_HashEntry \
Tcl_HashSearch \
Tcl_HashTable \
Tcl_Mutex \
Tcl_Pid \
Tcl_QueuePosition \
Tcl_ResolvedVarInfo \
Tcl_SavedResult \
Tcl_ThreadDataKey \
Tcl_ThreadId \
Tcl_Time \
Tcl_TimerToken \
Tcl_Token \
Tcl_Trace \
Tcl_Value \
Tcl_ValueType \
Tcl_Var \
Tk_3DBorder \
Tk_ArgvInfo \
Tk_BindingTable \
Tk_Canvas \
Tk_CanvasTextInfo \
Tk_ConfigSpec \
Tk_ConfigTypes \
Tk_Cursor \
Tk_CustomOption \
Tk_ErrorHandler \
Tk_FakeWin \
Tk_Font \
Tk_FontMetrics \
Tk_GeomMgr \
Tk_Image \
Tk_ImageMaster \
Tk_ImageType \
Tk_Item \
Tk_ItemType \
Tk_OptionSpec\
Tk_OptionTable \
Tk_OptionType \
Tk_PhotoHandle \
Tk_PhotoImageBlock \
Tk_PhotoImageFormat \
Tk_PostscriptInfo \
Tk_SavedOption \
Tk_SavedOptions \
Tk_SegType \
Tk_TextLayout \
Tk_Window \
}
# Misc junk that appears in the comments of the source. This just
# allows us to filter comments that "fool" the script.
set CommentList {
Tcl_Create\[Obj\]Command \
Tcl_DecrRefCount\\n \
Tcl_NewObj\\n \
Tk_GetXXX \
}
# Main entry point to this script.
proc main {} {
global argv0
global argv
set len [llength $argv]
if {($len != 2) && ($len != 3)} {
puts "usage: $argv0 pkgName pkgDir \[outFile\]"
puts " pkgName == Tcl,Tk"
puts " pkgDir == /home/surles/cvs/tcl8.2"
exit 1
}
set pkg [lindex $argv 0]
set dir [lindex $argv 1]
if {[llength $argv] == 3} {
set file [open [lindex $argv 2] w]
} else {
set file stdout
}
foreach {c d} [compare [grepCode $dir $pkg] [grepDocs $dir $pkg]] {}
filter $c $d $dir $pkg $file
if {$file != "stdout"} {
close $file
}
return
}
# Intersect the two list and write out the sets of APIs in one
# list that is not in the other.
proc compare {list1 list2} {
set inter [intersect3 $list1 $list2]
return [list [lindex $inter 0] [lindex $inter 2]]
}
# Filter the lists into the six lists we report on. Then write
# the results to the file.
proc filter {code docs dir pkg {outFile stdout}} {
set apis {}
# A list of Tcl command APIs. These are not documented.
# This list should just be verified for accuracy.
set cmds {}
# A list of proc pointer structs. These are not documented.
# This list should just be verified for accuracy.
set procs {}
# A list of internal declarations. These are not documented.
# This list should just be verified for accuracy.
set decls [grepDecl $dir $pkg]
# A list of misc. procedure declarations that are not documented.
# This list should just be verified for accuracy.
set misc [grepMisc $dir $pkg]
set pat1 ".*(${pkg}_\[A-z0-9]+).*$"
# A list of APIs in the source, not in the docs.
# This list should just be verified for accuracy.
foreach x $code {
if {[string match *Cmd $x]} {
if {[string match ${pkg}* $x]} {
lappend cmds $x
}
} elseif {[string match *Proc $x]} {
if {[string match ${pkg}* $x]} {
lappend procs $x
}
} elseif {[lsearch -exact $decls $x] >= 0} {
# No Op.
} elseif {[lsearch -exact $misc $x] >= 0} {
# No Op.
} else {
lappend apis $x
}
}
dump $apis "APIs in Source not in Docs." $outFile
dump $docs "APIs in Docs not in Source." $outFile
dump $decls "Internal APIs and structs." $outFile
dump $misc "Misc APIs and structs that we are not documenting." $outFile
dump $cmds "Command APIs." $outFile
dump $procs "Proc pointers." $outFile
return
}
# Print the list of APIs if the list is not null.
proc dump {list title file} {
if {$list != {}} {
puts $file ""
puts $file $title
puts $file "---------------------------------------------------------"
foreach x $list {
puts $file $x
}
}
}
# Grep into "dir/*/*.[ch]" looking for APIs that match $pkg_*.
# (e.g., Tcl_Exit). Return a list of APIs.
proc grepCode {dir pkg} {
set apis [myGrep "${pkg}_\.\*" "${dir}/\*/\*\.\[ch\]"]
set pat1 ".*(${pkg}_\[A-z0-9]+).*$"
foreach a $apis {
if {[regexp -- $pat1 $a main n1]} {
set result([string trim $n1]) 1
}
}
return [lsort [array names result]]
}
# Grep into "dir/doc/*.3" looking for APIs that match $pkg_*.
# (e.g., Tcl_Exit). Return a list of APIs.
proc grepDocs {dir pkg} {
set apis [myGrep "\\fB${pkg}_\.\*\\fR" "${dir}/doc/\*\.3"]
set pat1 ".*(${pkg}_\[A-z0-9]+)\\\\fR.*$"
foreach a $apis {
if {[regexp -- $pat1 $a main n1]} {
set result([string trim $n1]) 1
}
}
return [lsort [array names result]]
}
# Grep into "generic/pkgIntDecls.h" looking for APIs that match $pkg_*.
# (e.g., Tcl_Export). Return a list of APIs.
proc grepDecl {dir pkg} {
set file [file join $dir generic "[string tolower $pkg]IntDecls.h"]
set apis [myGrep "^EXTERN.*\[ \t\]${pkg}_.*" $file]
set pat1 ".*(${pkg}_\[A-z0-9]+).*$"
foreach a $apis {
if {[regexp -- $pat1 $a main n1]} {
set result([string trim $n1]) 1
}
}
return [lsort [array names result]]
}
# Grep into "*/*.[ch]" looking for APIs that match $pkg_Db*.
# (e.g., Tcl_DbCkalloc). Return a list of APIs.
proc grepMisc {dir pkg} {
global CommentList
global StructList
set apis [myGrep "^EXTERN.*\[ \t\]${pkg}_Db.*" "${dir}/\*/\*\.\[ch\]"]
set pat1 ".*(${pkg}_\[A-z0-9]+).*$"
foreach a $apis {
if {[regexp -- $pat1 $a main n1]} {
set dbg([string trim $n1]) 1
}
}
set result {}
eval {lappend result} $StructList
eval {lappend result} [lsort [array names dbg]]
eval {lappend result} $CommentList
return $result
}
proc myGrep {searchPat globPat} {
set result {}
foreach file [glob -nocomplain $globPat] {
set file [open $file r]
set data [read $file]
close $file
foreach line [split $data "\n"] {
if {[regexp "^.*${searchPat}.*\$" $line]} {
lappend result $line
}
}
}
return $result
}
main
tcl8.4.20/tools/README 0000644 0036047 0045461 00000001640 11737050674 012740 0 ustar dgp 771div This directory contains unsupported tools used to build parts of Tcl
for distribution.
uniParse.tcl -- Script for converting the Unicode character database
into a compact table stored in generic/tclUniData.c.
uniClass.tcl -- Script for generating regexp class tables from the Tcl
"string is" classes
Generating HTML files.
The tcl-tk-man-html.tcl script from Robert Critchlow
generates a nice set of HTML with good cross references.
Use it like
tclsh tcl-tk-man-html.tcl --htmldir=/tmp/tcl8.2
This script is very picky about the organization of man pages,
effectively acting as a style enforcer.
Generating Windows Help Files:
1) Build tcl in the ../unix directory
2) On UNIX, (after autoconf and configure), do
make
this converts the Nroff to RTF files.
2) On Windows, convert the RTF to a Help doc, do
nmake helpfile
Generating Windows binary distribution.
Update and compile the WYSE tcl.wse configuration.
tcl8.4.20/tools/genWinImage.tcl 0000644 0036047 0045461 00000007330 11737050675 014761 0 ustar dgp 771div # genWinImage.tcl --
#
# This script generates the Windows installer.
#
# Copyright (c) 1999 by Scriptics Corporation.
# All rights reserved.
# This file is insensitive to the directory from which it is invoked.
namespace eval genWinImage {
# toolsDir --
#
# This variable points to the platform specific tools directory.
variable toolsDir
# tclBuildDir --
#
# This variable points to the directory containing the Tcl built tree.
variable tclBuildDir
# tkBuildDir --
#
# This variable points to the directory containing the Tk built tree.
variable tkBuildDir
# our script name at runtime
variable script [info script]
}
# genWinImage::init --
#
# This is the main entry point.
#
# Arguments:
# None.
#
# Results:
# None.
proc genWinImage::init {} {
global tcl_platform argv argv0
variable tclBuildDir
variable tkBuildDir
variable toolsDir
variable script
puts "\n--- $script started: \
[clock format [clock seconds] -format "%Y%m%d-%H:%M"] --\n"
if {$tcl_platform(platform) != "windows"} {
puts stderr "ERROR: Cannot build TCL.EXE on Unix systems"
exit 1
}
if {[llength $argv] != 3} {
puts stderr "usage: $argv0 "
exit 0
}
set tclBuildDir [lindex $argv 0]
set tkBuildDir [lindex $argv 1]
set toolsDir [lindex $argv 2]
generateInstallers
puts "\n--- $script finished: \
[clock format [clock seconds] -format "%Y%m%d-%H:%M"] --\n\n"
}
# genWinImage::makeTextFile --
#
# Convert the input file into a CRLF terminated text file.
#
# Arguments:
# infile The input file to convert.
# outfile The location where the text file should be stored.
#
# Results:
# None.
proc genWinImage::makeTextFile {infile outfile} {
set f [open $infile r]
set text [read $f]
close $f
set f [open $outfile w]
fconfigure $f -translation crlf
puts -nonewline $f $text
close $f
}
# genWinImage::generateInstallers --
#
# Perform substitutions on the pro.wse.in file and then
# invoke the WSE script twice; once for CD and once for web.
#
# Arguments:
# None.
#
# Results:
# Leaves proweb.exe and procd.exe sitting in the curent directory.
proc genWinImage::generateInstallers {} {
variable toolsDir
variable tclBuildDir
variable tkBuildDir
# Now read the "pro/srcs/install/pro.wse.in" file, have Tcl make
# appropriate substitutions, write out the resulting file in a
# current-working-directory. Use this new file to perform installation
# image creation. Note that we have to use this technique to set
# the value of _WISE_ because wise32 won't use a /d switch for this
# variable.
set __TCLBASEDIR__ [file native $tclBuildDir]
set __TKBASEDIR__ [file native $tkBuildDir]
set __WISE__ [file native [file join $toolsDir wise]]
set f [open [file join $__TCLBASEDIR__ generic/tcl.h] r]
set s [read $f]
close $f
regexp {TCL_PATCH_LEVEL\s*\"([^\"]*)\"} $s dummy __TCL_PATCH_LEVEL__
set f [open tcl.wse.in r]
set s [read $f]
close $f
set s [subst -nocommands -nobackslashes $s]
set f [open tcl.wse w]
puts $f $s
close $f
# Ensure the text files are CRLF terminated
makeTextFile [file join $tclBuildDir win/README.binary] \
[file join $tclBuildDir win/readme.txt]
makeTextFile [file join $tclBuildDir license.terms] \
[file join $tclBuildDir license.txt]
set wise32ProgFilePath [file native [file join $__WISE__ wise32.exe]]
# Run the Wise installer to create the Windows install images.
if {[catch {exec [file native $wise32ProgFilePath] /c tcl.wse} errMsg]} {
puts stderr "ERROR: $errMsg"
} else {
puts "\"TCL.EXE\" created."
}
return
}
genWinImage::init
tcl8.4.20/tools/white.bmp 0000644 0036047 0045461 00000050052 11737050675 013702 0 ustar dgp 771div BM*P > ( е U ьO t t џџџ џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј џџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџџј tcl8.4.20/generic/ 0000755 0036047 0045461 00000000000 12153151142 012314 5 ustar dgp 771div tcl8.4.20/generic/regexec.c 0000644 0036047 0045461 00000067373 11737050674 014141 0 ustar dgp 771div /*
* re_*exec and friends - match REs
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*/
#include "regguts.h"
/* lazy-DFA representation */
struct arcp { /* "pointer" to an outarc */
struct sset *ss;
color co;
};
struct sset { /* state set */
unsigned *states; /* pointer to bitvector */
unsigned hash; /* hash of bitvector */
# define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw))
# define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \
memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0))
int flags;
# define STARTER 01 /* the initial state set */
# define POSTSTATE 02 /* includes the goal state */
# define LOCKED 04 /* locked in cache */
# define NOPROGRESS 010 /* zero-progress state set */
struct arcp ins; /* chain of inarcs pointing here */
chr *lastseen; /* last entered on arrival here */
struct sset **outs; /* outarc vector indexed by color */
struct arcp *inchain; /* chain-pointer vector for outarcs */
};
struct dfa {
int nssets; /* size of cache */
int nssused; /* how many entries occupied yet */
int nstates; /* number of states */
int ncolors; /* length of outarc and inchain vectors */
int wordsper; /* length of state-set bitvectors */
struct sset *ssets; /* state-set cache */
unsigned *statesarea; /* bitvector storage */
unsigned *work; /* pointer to work area within statesarea */
struct sset **outsarea; /* outarc-vector storage */
struct arcp *incarea; /* inchain storage */
struct cnfa *cnfa;
struct colormap *cm;
chr *lastpost; /* location of last cache-flushed success */
chr *lastnopr; /* location of last cache-flushed NOPROGRESS */
struct sset *search; /* replacement-search-pointer memory */
int cptsmalloced; /* were the areas individually malloced? */
char *mallocarea; /* self, or master malloced area, or NULL */
};
#define WORK 1 /* number of work bitvectors needed */
/* setup for non-malloc allocation for small cases */
#define FEWSTATES 20 /* must be less than UBITS */
#define FEWCOLORS 15
struct smalldfa {
struct dfa dfa;
struct sset ssets[FEWSTATES*2];
unsigned statesarea[FEWSTATES*2 + WORK];
struct sset *outsarea[FEWSTATES*2 * FEWCOLORS];
struct arcp incarea[FEWSTATES*2 * FEWCOLORS];
};
#define DOMALLOC ((struct smalldfa *)NULL) /* force malloc */
/* internal variables, bundled for easy passing around */
struct vars {
regex_t *re;
struct guts *g;
int eflags; /* copies of arguments */
size_t nmatch;
regmatch_t *pmatch;
rm_detail_t *details;
chr *start; /* start of string */
chr *stop; /* just past end of string */
int err; /* error code if any (0 none) */
regoff_t *mem; /* memory vector for backtracking */
struct smalldfa dfa1;
struct smalldfa dfa2;
};
#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */
#define ISERR() VISERR(v)
#define VERR(vv,e) (((vv)->err) ? (vv)->err : ((vv)->err = (e)))
#define ERR(e) VERR(v, e) /* record an error */
#define NOERR() {if (ISERR()) return v->err;} /* if error seen, return it */
#define OFF(p) ((p) - v->start)
#define LOFF(p) ((long)OFF(p))
/*
* forward declarations
*/
/* =====^!^===== begin forwards =====^!^===== */
/* automatically gathered by fwd; do not hand-edit */
/* === regexec.c === */
int exec _ANSI_ARGS_((regex_t *, CONST chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int));
static int find _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *));
static int cfind _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *));
static int cfindloop _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *, struct dfa *, struct dfa *, chr **));
static VOID zapsubs _ANSI_ARGS_((regmatch_t *, size_t));
static VOID zapmem _ANSI_ARGS_((struct vars *, struct subre *));
static VOID subset _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
static int dissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
static int condissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
static int altdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
static int cdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
static int ccondissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
static int crevdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
static int cbrdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
static int caltdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
/* === rege_dfa.c === */
static chr *longest _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *, int *));
static chr *shortest _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *, chr *, chr **, int *));
static chr *lastcold _ANSI_ARGS_((struct vars *, struct dfa *));
static struct dfa *newdfa _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *, struct smalldfa *));
static VOID freedfa _ANSI_ARGS_((struct dfa *));
static unsigned hash _ANSI_ARGS_((unsigned *, int));
static struct sset *initialize _ANSI_ARGS_((struct vars *, struct dfa *, chr *));
static struct sset *miss _ANSI_ARGS_((struct vars *, struct dfa *, struct sset *, pcolor, chr *, chr *));
static int lacon _ANSI_ARGS_((struct vars *, struct cnfa *, chr *, pcolor));
static struct sset *getvacant _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *));
static struct sset *pickss _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *));
/* automatically gathered by fwd; do not hand-edit */
/* =====^!^===== end forwards =====^!^===== */
/*
- exec - match regular expression
^ int exec(regex_t *, CONST chr *, size_t, rm_detail_t *,
^ size_t, regmatch_t [], int);
*/
int
exec(re, string, len, details, nmatch, pmatch, flags)
regex_t *re;
CONST chr *string;
size_t len;
rm_detail_t *details;
size_t nmatch;
regmatch_t pmatch[];
int flags;
{
struct vars var;
register struct vars *v = &var;
int st;
size_t n;
int backref;
# define LOCALMAT 20
regmatch_t mat[LOCALMAT];
# define LOCALMEM 40
regoff_t mem[LOCALMEM];
/* sanity checks */
if (re == NULL || string == NULL || re->re_magic != REMAGIC)
return REG_INVARG;
if (re->re_csize != sizeof(chr))
return REG_MIXED;
/* setup */
v->re = re;
v->g = (struct guts *)re->re_guts;
if ((v->g->cflags®_EXPECT) && details == NULL)
return REG_INVARG;
if (v->g->info®_UIMPOSSIBLE)
return REG_NOMATCH;
backref = (v->g->info®_UBACKREF) ? 1 : 0;
v->eflags = flags;
if (v->g->cflags®_NOSUB)
nmatch = 0; /* override client */
v->nmatch = nmatch;
if (backref) {
/* need work area */
if (v->g->nsub + 1 <= LOCALMAT)
v->pmatch = mat;
else
v->pmatch = (regmatch_t *)MALLOC((v->g->nsub + 1) *
sizeof(regmatch_t));
if (v->pmatch == NULL)
return REG_ESPACE;
v->nmatch = v->g->nsub + 1;
} else
v->pmatch = pmatch;
v->details = details;
v->start = (chr *)string;
v->stop = (chr *)string + len;
v->err = 0;
if (backref) {
/* need retry memory */
assert(v->g->ntree >= 0);
n = (size_t)v->g->ntree;
if (n <= LOCALMEM)
v->mem = mem;
else
v->mem = (regoff_t *)MALLOC(n*sizeof(regoff_t));
if (v->mem == NULL) {
if (v->pmatch != pmatch && v->pmatch != mat)
FREE(v->pmatch);
return REG_ESPACE;
}
} else
v->mem = NULL;
/* do it */
assert(v->g->tree != NULL);
if (backref)
st = cfind(v, &v->g->tree->cnfa, &v->g->cmap);
else
st = find(v, &v->g->tree->cnfa, &v->g->cmap);
/* copy (portion of) match vector over if necessary */
if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) {
zapsubs(pmatch, nmatch);
n = (nmatch < v->nmatch) ? nmatch : v->nmatch;
memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t));
}
/* clean up */
if (v->pmatch != pmatch && v->pmatch != mat)
FREE(v->pmatch);
if (v->mem != NULL && v->mem != mem)
FREE(v->mem);
return st;
}
/*
- find - find a match for the main NFA (no-complications case)
^ static int find(struct vars *, struct cnfa *, struct colormap *);
*/
static int
find(v, cnfa, cm)
struct vars *v;
struct cnfa *cnfa;
struct colormap *cm;
{
struct dfa *s;
struct dfa *d;
chr *begin;
chr *end = NULL;
chr *cold;
chr *open; /* open and close of range of possible starts */
chr *close;
int hitend;
int shorter = (v->g->tree->flags&SHORTER) ? 1 : 0;
/* first, a shot with the search RE */
s = newdfa(v, &v->g->search, cm, &v->dfa1);
assert(!(ISERR() && s != NULL));
NOERR();
MDEBUG(("\nsearch at %ld\n", LOFF(v->start)));
cold = NULL;
close = shortest(v, s, v->start, v->start, v->stop, &cold, (int *)NULL);
freedfa(s);
NOERR();
if (v->g->cflags®_EXPECT) {
assert(v->details != NULL);
if (cold != NULL)
v->details->rm_extend.rm_so = OFF(cold);
else
v->details->rm_extend.rm_so = OFF(v->stop);
v->details->rm_extend.rm_eo = OFF(v->stop); /* unknown */
}
if (close == NULL) /* not found */
return REG_NOMATCH;
if (v->nmatch == 0) /* found, don't need exact location */
return REG_OKAY;
/* find starting point and match */
assert(cold != NULL);
open = cold;
cold = NULL;
MDEBUG(("between %ld and %ld\n", LOFF(open), LOFF(close)));
d = newdfa(v, cnfa, cm, &v->dfa1);
assert(!(ISERR() && d != NULL));
NOERR();
for (begin = open; begin <= close; begin++) {
MDEBUG(("\nfind trying at %ld\n", LOFF(begin)));
if (shorter)
end = shortest(v, d, begin, begin, v->stop,
(chr **)NULL, &hitend);
else
end = longest(v, d, begin, v->stop, &hitend);
NOERR();
if (hitend && cold == NULL)
cold = begin;
if (end != NULL)
break; /* NOTE BREAK OUT */
}
assert(end != NULL); /* search RE succeeded so loop should */
freedfa(d);
/* and pin down details */
assert(v->nmatch > 0);
v->pmatch[0].rm_so = OFF(begin);
v->pmatch[0].rm_eo = OFF(end);
if (v->g->cflags®_EXPECT) {
if (cold != NULL)
v->details->rm_extend.rm_so = OFF(cold);
else
v->details->rm_extend.rm_so = OFF(v->stop);
v->details->rm_extend.rm_eo = OFF(v->stop); /* unknown */
}
if (v->nmatch == 1) /* no need for submatches */
return REG_OKAY;
/* submatches */
zapsubs(v->pmatch, v->nmatch);
return dissect(v, v->g->tree, begin, end);
}
/*
- cfind - find a match for the main NFA (with complications)
^ static int cfind(struct vars *, struct cnfa *, struct colormap *);
*/
static int
cfind(v, cnfa, cm)
struct vars *v;
struct cnfa *cnfa;
struct colormap *cm;
{
struct dfa *s;
struct dfa *d;
chr *cold = NULL; /* silence gcc 4 warning */
int ret;
s = newdfa(v, &v->g->search, cm, &v->dfa1);
NOERR();
d = newdfa(v, cnfa, cm, &v->dfa2);
if (ISERR()) {
assert(d == NULL);
freedfa(s);
return v->err;
}
ret = cfindloop(v, cnfa, cm, d, s, &cold);
freedfa(d);
freedfa(s);
NOERR();
if (v->g->cflags®_EXPECT) {
assert(v->details != NULL);
if (cold != NULL)
v->details->rm_extend.rm_so = OFF(cold);
else
v->details->rm_extend.rm_so = OFF(v->stop);
v->details->rm_extend.rm_eo = OFF(v->stop); /* unknown */
}
return ret;
}
/*
- cfindloop - the heart of cfind
^ static int cfindloop(struct vars *, struct cnfa *, struct colormap *,
^ struct dfa *, struct dfa *, chr **);
*/
static int
cfindloop(v, cnfa, cm, d, s, coldp)
struct vars *v;
struct cnfa *cnfa;
struct colormap *cm;
struct dfa *d;
struct dfa *s;
chr **coldp; /* where to put coldstart pointer */
{
chr *begin;
chr *end;
chr *cold;
chr *open; /* open and close of range of possible starts */
chr *close;
chr *estart;
chr *estop;
int er;
int shorter = v->g->tree->flags&SHORTER;
int hitend;
assert(d != NULL && s != NULL);
cold = NULL;
close = v->start;
do {
MDEBUG(("\ncsearch at %ld\n", LOFF(close)));
close = shortest(v, s, close, close, v->stop, &cold, (int *)NULL);
if (close == NULL)
break; /* NOTE BREAK */
assert(cold != NULL);
open = cold;
cold = NULL;
MDEBUG(("cbetween %ld and %ld\n", LOFF(open), LOFF(close)));
for (begin = open; begin <= close; begin++) {
MDEBUG(("\ncfind trying at %ld\n", LOFF(begin)));
estart = begin;
estop = v->stop;
for (;;) {
if (shorter)
end = shortest(v, d, begin, estart,
estop, (chr **)NULL, &hitend);
else
end = longest(v, d, begin, estop,
&hitend);
if (hitend && cold == NULL)
cold = begin;
if (end == NULL)
break; /* NOTE BREAK OUT */
MDEBUG(("tentative end %ld\n", LOFF(end)));
zapsubs(v->pmatch, v->nmatch);
zapmem(v, v->g->tree);
er = cdissect(v, v->g->tree, begin, end);
if (er == REG_OKAY) {
if (v->nmatch > 0) {
v->pmatch[0].rm_so = OFF(begin);
v->pmatch[0].rm_eo = OFF(end);
}
*coldp = cold;
return REG_OKAY;
}
if (er != REG_NOMATCH) {
ERR(er);
return er;
}
if ((shorter) ? end == estop : end == begin) {
/* no point in trying again */
*coldp = cold;
return REG_NOMATCH;
}
/* go around and try again */
if (shorter)
estart = end + 1;
else
estop = end - 1;
}
}
} while (close < v->stop);
*coldp = cold;
return REG_NOMATCH;
}
/*
- zapsubs - initialize the subexpression matches to "no match"
^ static VOID zapsubs(regmatch_t *, size_t);
*/
static VOID
zapsubs(p, n)
regmatch_t *p;
size_t n;
{
size_t i;
for (i = n-1; i > 0; i--) {
p[i].rm_so = -1;
p[i].rm_eo = -1;
}
}
/*
- zapmem - initialize the retry memory of a subtree to zeros
^ static VOID zapmem(struct vars *, struct subre *);
*/
static VOID
zapmem(v, t)
struct vars *v;
struct subre *t;
{
if (t == NULL)
return;
assert(v->mem != NULL);
v->mem[t->retry] = 0;
if (t->op == '(') {
assert(t->subno > 0);
v->pmatch[t->subno].rm_so = -1;
v->pmatch[t->subno].rm_eo = -1;
}
if (t->left != NULL)
zapmem(v, t->left);
if (t->right != NULL)
zapmem(v, t->right);
}
/*
- subset - set any subexpression relevant to a successful subre
^ static VOID subset(struct vars *, struct subre *, chr *, chr *);
*/
static VOID
subset(v, sub, begin, end)
struct vars *v;
struct subre *sub;
chr *begin;
chr *end;
{
int n = sub->subno;
assert(n > 0);
if ((size_t)n >= v->nmatch)
return;
MDEBUG(("setting %d\n", n));
v->pmatch[n].rm_so = OFF(begin);
v->pmatch[n].rm_eo = OFF(end);
}
/*
- dissect - determine subexpression matches (uncomplicated case)
^ static int dissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
dissect(v, t, begin, end)
struct vars *v;
struct subre *t;
chr *begin; /* beginning of relevant substring */
chr *end; /* end of same */
{
assert(t != NULL);
MDEBUG(("dissect %ld-%ld\n", LOFF(begin), LOFF(end)));
switch (t->op) {
case '=': /* terminal node */
assert(t->left == NULL && t->right == NULL);
return REG_OKAY; /* no action, parent did the work */
break;
case '|': /* alternation */
assert(t->left != NULL);
return altdissect(v, t, begin, end);
break;
case 'b': /* back ref -- shouldn't be calling us! */
return REG_ASSERT;
break;
case '.': /* concatenation */
assert(t->left != NULL && t->right != NULL);
return condissect(v, t, begin, end);
break;
case '(': /* capturing */
assert(t->left != NULL && t->right == NULL);
assert(t->subno > 0);
subset(v, t, begin, end);
return dissect(v, t->left, begin, end);
break;
default:
return REG_ASSERT;
break;
}
}
/*
- condissect - determine concatenation subexpression matches (uncomplicated)
^ static int condissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
condissect(v, t, begin, end)
struct vars *v;
struct subre *t;
chr *begin; /* beginning of relevant substring */
chr *end; /* end of same */
{
struct dfa *d;
struct dfa *d2;
chr *mid;
int i;
int shorter = (t->left->flags&SHORTER) ? 1 : 0;
chr *stop = (shorter) ? end : begin;
assert(t->op == '.');
assert(t->left != NULL && t->left->cnfa.nstates > 0);
assert(t->right != NULL && t->right->cnfa.nstates > 0);
d = newdfa(v, &t->left->cnfa, &v->g->cmap, &v->dfa1);
NOERR();
d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &v->dfa2);
if (ISERR()) {
assert(d2 == NULL);
freedfa(d);
return v->err;
}
/* pick a tentative midpoint */
if (shorter)
mid = shortest(v, d, begin, begin, end, (chr **)NULL,
(int *)NULL);
else
mid = longest(v, d, begin, end, (int *)NULL);
if (mid == NULL) {
freedfa(d);
freedfa(d2);
return REG_ASSERT;
}
MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
/* iterate until satisfaction or failure */
while (longest(v, d2, mid, end, (int *)NULL) != end) {
/* that midpoint didn't work, find a new one */
if (mid == stop) {
/* all possibilities exhausted! */
MDEBUG(("no midpoint!\n"));
freedfa(d);
freedfa(d2);
return REG_ASSERT;
}
if (shorter)
mid = shortest(v, d, begin, mid+1, end, (chr **)NULL,
(int *)NULL);
else
mid = longest(v, d, begin, mid-1, (int *)NULL);
if (mid == NULL) {
/* failed to find a new one! */
MDEBUG(("failed midpoint!\n"));
freedfa(d);
freedfa(d2);
return REG_ASSERT;
}
MDEBUG(("new midpoint %ld\n", LOFF(mid)));
}
/* satisfaction */
MDEBUG(("successful\n"));
freedfa(d);
freedfa(d2);
i = dissect(v, t->left, begin, mid);
if (i != REG_OKAY)
return i;
return dissect(v, t->right, mid, end);
}
/*
- altdissect - determine alternative subexpression matches (uncomplicated)
^ static int altdissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
altdissect(v, t, begin, end)
struct vars *v;
struct subre *t;
chr *begin; /* beginning of relevant substring */
chr *end; /* end of same */
{
struct dfa *d;
int i;
assert(t != NULL);
assert(t->op == '|');
for (i = 0; t != NULL; t = t->right, i++) {
MDEBUG(("trying %dth\n", i));
assert(t->left != NULL && t->left->cnfa.nstates > 0);
d = newdfa(v, &t->left->cnfa, &v->g->cmap, &v->dfa1);
if (ISERR())
return v->err;
if (longest(v, d, begin, end, (int *)NULL) == end) {
MDEBUG(("success\n"));
freedfa(d);
return dissect(v, t->left, begin, end);
}
freedfa(d);
}
return REG_ASSERT; /* none of them matched?!? */
}
/*
- cdissect - determine subexpression matches (with complications)
* The retry memory stores the offset of the trial midpoint from begin,
* plus 1 so that 0 uniquely means "clean slate".
^ static int cdissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
cdissect(v, t, begin, end)
struct vars *v;
struct subre *t;
chr *begin; /* beginning of relevant substring */
chr *end; /* end of same */
{
int er;
assert(t != NULL);
MDEBUG(("cdissect %ld-%ld %c\n", LOFF(begin), LOFF(end), t->op));
switch (t->op) {
case '=': /* terminal node */
assert(t->left == NULL && t->right == NULL);
return REG_OKAY; /* no action, parent did the work */
break;
case '|': /* alternation */
assert(t->left != NULL);
return caltdissect(v, t, begin, end);
break;
case 'b': /* back ref -- shouldn't be calling us! */
assert(t->left == NULL && t->right == NULL);
return cbrdissect(v, t, begin, end);
break;
case '.': /* concatenation */
assert(t->left != NULL && t->right != NULL);
return ccondissect(v, t, begin, end);
break;
case '(': /* capturing */
assert(t->left != NULL && t->right == NULL);
assert(t->subno > 0);
er = cdissect(v, t->left, begin, end);
if (er == REG_OKAY)
subset(v, t, begin, end);
return er;
break;
default:
return REG_ASSERT;
break;
}
}
/*
- ccondissect - concatenation subexpression matches (with complications)
* The retry memory stores the offset of the trial midpoint from begin,
* plus 1 so that 0 uniquely means "clean slate".
^ static int ccondissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
ccondissect(v, t, begin, end)
struct vars *v;
struct subre *t;
chr *begin; /* beginning of relevant substring */
chr *end; /* end of same */
{
struct dfa *d;
struct dfa *d2;
chr *mid;
int er;
assert(t->op == '.');
assert(t->left != NULL && t->left->cnfa.nstates > 0);
assert(t->right != NULL && t->right->cnfa.nstates > 0);
if (t->left->flags&SHORTER) /* reverse scan */
return crevdissect(v, t, begin, end);
d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
if (ISERR())
return v->err;
d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, DOMALLOC);
if (ISERR()) {
freedfa(d);
return v->err;
}
MDEBUG(("cconcat %d\n", t->retry));
/* pick a tentative midpoint */
if (v->mem[t->retry] == 0) {
mid = longest(v, d, begin, end, (int *)NULL);
if (mid == NULL) {
freedfa(d);
freedfa(d2);
return REG_NOMATCH;
}
MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
v->mem[t->retry] = (mid - begin) + 1;
} else {
mid = begin + (v->mem[t->retry] - 1);
MDEBUG(("working midpoint %ld\n", LOFF(mid)));
}
/* iterate until satisfaction or failure */
for (;;) {
/* try this midpoint on for size */
if (longest(v, d2, mid, end, NULL) == end) {
er = cdissect(v, t->left, begin, mid);
if (er == REG_OKAY) {
er = cdissect(v, t->right, mid, end);
if (er == REG_OKAY) {
/* satisfaction */
MDEBUG(("successful\n"));
freedfa(d);
freedfa(d2);
return REG_OKAY;
}
}
if ((er != REG_OKAY) && (er != REG_NOMATCH)) {
freedfa(d);
freedfa(d2);
return er;
}
}
/* that midpoint didn't work, find a new one */
if (mid == begin) {
/* all possibilities exhausted */
MDEBUG(("%d no midpoint\n", t->retry));
freedfa(d);
freedfa(d2);
return REG_NOMATCH;
}
mid = longest(v, d, begin, mid-1, (int *)NULL);
if (mid == NULL) {
/* failed to find a new one */
MDEBUG(("%d failed midpoint\n", t->retry));
freedfa(d);
freedfa(d2);
return REG_NOMATCH;
}
MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid)));
v->mem[t->retry] = (mid - begin) + 1;
zapmem(v, t->left);
zapmem(v, t->right);
}
}
/*
- crevdissect - determine backref shortest-first subexpression matches
* The retry memory stores the offset of the trial midpoint from begin,
* plus 1 so that 0 uniquely means "clean slate".
^ static int crevdissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
crevdissect(v, t, begin, end)
struct vars *v;
struct subre *t;
chr *begin; /* beginning of relevant substring */
chr *end; /* end of same */
{
struct dfa *d;
struct dfa *d2;
chr *mid;
int er;
assert(t->op == '.');
assert(t->left != NULL && t->left->cnfa.nstates > 0);
assert(t->right != NULL && t->right->cnfa.nstates > 0);
assert(t->left->flags&SHORTER);
/* concatenation -- need to split the substring between parts */
d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
if (ISERR())
return v->err;
d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, DOMALLOC);
if (ISERR()) {
freedfa(d);
return v->err;
}
MDEBUG(("crev %d\n", t->retry));
/* pick a tentative midpoint */
if (v->mem[t->retry] == 0) {
mid = shortest(v, d, begin, begin, end, (chr **)NULL, (int *)NULL);
if (mid == NULL) {
freedfa(d);
freedfa(d2);
return REG_NOMATCH;
}
MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
v->mem[t->retry] = (mid - begin) + 1;
} else {
mid = begin + (v->mem[t->retry] - 1);
MDEBUG(("working midpoint %ld\n", LOFF(mid)));
}
/* iterate until satisfaction or failure */
for (;;) {
/* try this midpoint on for size */
if (longest(v, d2, mid, end, NULL) == end) {
er = cdissect(v, t->left, begin, mid);
if (er == REG_OKAY) {
er = cdissect(v, t->right, mid, end);
if (er == REG_OKAY) {
/* satisfaction */
MDEBUG(("successful\n"));
freedfa(d);
freedfa(d2);
return REG_OKAY;
}
}
if (er != REG_OKAY && er != REG_NOMATCH) {
freedfa(d);
freedfa(d2);
return er;
}
}
/* that midpoint didn't work, find a new one */
if (mid == end) {
/* all possibilities exhausted */
MDEBUG(("%d no midpoint\n", t->retry));
freedfa(d);
freedfa(d2);
return REG_NOMATCH;
}
mid = shortest(v, d, begin, mid+1, end, (chr **)NULL, (int *)NULL);
if (mid == NULL) {
/* failed to find a new one */
MDEBUG(("%d failed midpoint\n", t->retry));
freedfa(d);
freedfa(d2);
return REG_NOMATCH;
}
MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid)));
v->mem[t->retry] = (mid - begin) + 1;
zapmem(v, t->left);
zapmem(v, t->right);
}
}
/*
- cbrdissect - determine backref subexpression matches
^ static int cbrdissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
cbrdissect(v, t, begin, end)
struct vars *v;
struct subre *t;
chr *begin; /* beginning of relevant substring */
chr *end; /* end of same */
{
int i;
int n = t->subno;
size_t len;
chr *paren;
chr *p;
chr *stop;
int min = t->min;
int max = t->max;
assert(t != NULL);
assert(t->op == 'b');
assert(n >= 0);
assert((size_t)n < v->nmatch);
MDEBUG(("cbackref n%d %d{%d-%d}\n", t->retry, n, min, max));
if (v->pmatch[n].rm_so == -1)
return REG_NOMATCH;
paren = v->start + v->pmatch[n].rm_so;
len = v->pmatch[n].rm_eo - v->pmatch[n].rm_so;
/* no room to maneuver -- retries are pointless */
if (v->mem[t->retry])
return REG_NOMATCH;
v->mem[t->retry] = 1;
/* special-case zero-length string */
if (len == 0) {
if (begin == end)
return REG_OKAY;
return REG_NOMATCH;
}
/* and too-short string */
assert(end >= begin);
if ((size_t)(end - begin) < len)
return REG_NOMATCH;
stop = end - len;
/* count occurrences */
i = 0;
for (p = begin; p <= stop && (i < max || max == INFINITY); p += len) {
if ((*v->g->compare)(paren, p, len) != 0)
break;
i++;
}
MDEBUG(("cbackref found %d\n", i));
/* and sort it out */
if (p != end) /* didn't consume all of it */
return REG_NOMATCH;
if (min <= i && (i <= max || max == INFINITY))
return REG_OKAY;
return REG_NOMATCH; /* out of range */
}
/*
- caltdissect - determine alternative subexpression matches (w. complications)
^ static int caltdissect(struct vars *, struct subre *, chr *, chr *);
*/
static int /* regexec return code */
caltdissect(v, t, begin, end)
struct vars *v;
struct subre *t;
chr *begin; /* beginning of relevant substring */
chr *end; /* end of same */
{
struct dfa *d;
int er;
# define UNTRIED 0 /* not yet tried at all */
# define TRYING 1 /* top matched, trying submatches */
# define TRIED 2 /* top didn't match or submatches exhausted */
if (t == NULL)
return REG_NOMATCH;
assert(t->op == '|');
if (v->mem[t->retry] == TRIED)
return caltdissect(v, t->right, begin, end);
MDEBUG(("calt n%d\n", t->retry));
assert(t->left != NULL);
if (v->mem[t->retry] == UNTRIED) {
d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC);
if (ISERR())
return v->err;
if (longest(v, d, begin, end, (int *)NULL) != end) {
freedfa(d);
v->mem[t->retry] = TRIED;
return caltdissect(v, t->right, begin, end);
}
freedfa(d);
MDEBUG(("calt matched\n"));
v->mem[t->retry] = TRYING;
}
er = cdissect(v, t->left, begin, end);
if (er != REG_NOMATCH)
return er;
v->mem[t->retry] = TRIED;
return caltdissect(v, t->right, begin, end);
}
#include "rege_dfa.c"
tcl8.4.20/generic/regerrs.h 0000644 0036047 0045461 00000002244 12133546537 014156 0 ustar dgp 771div { REG_OKAY, "REG_OKAY", "no errors detected" },
{ REG_NOMATCH, "REG_NOMATCH", "failed to match" },
{ REG_BADPAT, "REG_BADPAT", "invalid regexp (reg version 0.8)" },
{ REG_ECOLLATE, "REG_ECOLLATE", "invalid collating element" },
{ REG_ECTYPE, "REG_ECTYPE", "invalid character class" },
{ REG_EESCAPE, "REG_EESCAPE", "invalid escape \\ sequence" },
{ REG_ESUBREG, "REG_ESUBREG", "invalid backreference number" },
{ REG_EBRACK, "REG_EBRACK", "brackets [] not balanced" },
{ REG_EPAREN, "REG_EPAREN", "parentheses () not balanced" },
{ REG_EBRACE, "REG_EBRACE", "braces {} not balanced" },
{ REG_BADBR, "REG_BADBR", "invalid repetition count(s)" },
{ REG_ERANGE, "REG_ERANGE", "invalid character range" },
{ REG_ESPACE, "REG_ESPACE", "out of memory" },
{ REG_BADRPT, "REG_BADRPT", "quantifier operand invalid" },
{ REG_ASSERT, "REG_ASSERT", "\"can't happen\" -- you found a bug" },
{ REG_INVARG, "REG_INVARG", "invalid argument to regex function" },
{ REG_MIXED, "REG_MIXED", "character widths of regex and string differ" },
{ REG_BADOPT, "REG_BADOPT", "invalid embedded option" },
{ REG_ETOOBIG, "REG_ETOOBIG", "nfa has too many states" },
{ REG_ECOLORS, "REG_ECOLORS", "too many colors" },
tcl8.4.20/generic/tclIO.c 0000644 0036047 0045461 00001055616 12133546540 013520 0 ustar dgp 771div /*
* tclIO.c --
*
* This file provides the generic portions (those that are the same on
* all platforms and for all channel types) of Tcl's IO facilities.
*
* Copyright (c) 1998-2000 Ajuba Solutions
* Copyright (c) 1995-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.
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclIO.h"
#include
#ifndef TCL_INHERIT_STD_CHANNELS
#define TCL_INHERIT_STD_CHANNELS 1
#endif
/*
* For each channel handler registered in a call to Tcl_CreateChannelHandler,
* there is one record of the following type. All of records for a specific
* channel are chained together in a singly linked list which is stored in
* the channel structure.
*/
typedef struct ChannelHandler {
Channel *chanPtr; /* The channel structure for this channel. */
int mask; /* Mask of desired events. */
Tcl_ChannelProc *proc; /* Procedure to call in the type of
* Tcl_CreateChannelHandler. */
ClientData clientData; /* Argument to pass to procedure. */
struct ChannelHandler *nextPtr;
/* Next one in list of registered handlers. */
} ChannelHandler;
/*
* This structure keeps track of the current ChannelHandler being invoked in
* the current invocation of ChannelHandlerEventProc. There is a potential
* problem if a ChannelHandler is deleted while it is the current one, since
* ChannelHandlerEventProc needs to look at the nextPtr field. To handle this
* problem, structures of the type below indicate the next handler to be
* processed for any (recursively nested) dispatches in progress. The
* nextHandlerPtr field is updated if the handler being pointed to is deleted.
* The nextPtr field is used to chain together all recursive invocations, so
* that Tcl_DeleteChannelHandler can find all the recursively nested
* invocations of ChannelHandlerEventProc and compare the handler being
* deleted against the NEXT handler to be invoked in that invocation; when it
* finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr
* field of the structure to the next handler.
*/
typedef struct NextChannelHandler {
ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in
* this invocation. */
struct NextChannelHandler *nestedHandlerPtr;
/* Next nested invocation of
* ChannelHandlerEventProc. */
} NextChannelHandler;
/*
* The following structure describes the event that is added to the Tcl
* event queue by the channel handler check procedure.
*/
typedef struct ChannelHandlerEvent {
Tcl_Event header; /* Standard header for all events. */
Channel *chanPtr; /* The channel that is ready. */
int readyMask; /* Events that have occurred. */
} ChannelHandlerEvent;
/*
* The following structure is used by Tcl_GetsObj() to encapsulates the
* state for a "gets" operation.
*/
typedef struct GetsState {
Tcl_Obj *objPtr; /* The object to which UTF-8 characters
* will be appended. */
char **dstPtr; /* Pointer into objPtr's string rep where
* next character should be stored. */
Tcl_Encoding encoding; /* The encoding to use to convert raw bytes
* to UTF-8. */
ChannelBuffer *bufPtr; /* The current buffer of raw bytes being
* emptied. */
Tcl_EncodingState state; /* The encoding state just before the last
* external to UTF-8 conversion in
* FilterInputBytes(). */
int rawRead; /* The number of bytes removed from bufPtr
* in the last call to FilterInputBytes(). */
int bytesWrote; /* The number of bytes of UTF-8 data
* appended to objPtr during the last call to
* FilterInputBytes(). */
int charsWrote; /* The corresponding number of UTF-8
* characters appended to objPtr during the
* last call to FilterInputBytes(). */
int totalChars; /* The total number of UTF-8 characters
* appended to objPtr so far, just before the
* last call to FilterInputBytes(). */
} GetsState;
/*
* The following structure encapsulates the state for a background channel
* copy. Note that the data buffer for the copy will be appended to this
* structure.
*/
typedef struct CopyState {
struct Channel *readPtr; /* Pointer to input channel. */
struct Channel *writePtr; /* Pointer to output channel. */
int readFlags; /* Original read channel flags. */
int writeFlags; /* Original write channel flags. */
int toRead; /* Number of bytes to copy, or -1. */
int total; /* Total bytes transferred (written). */
Tcl_Interp *interp; /* Interp that started the copy. */
Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */
int bufSize; /* Size of appended buffer. */
char buffer[1]; /* Copy buffer, this must be the last
* field. */
} CopyState;
/*
* All static variables used in this file are collected into a single
* instance of the following structure. For multi-threaded implementations,
* there is one instance of this structure for each thread.
*
* Notice that different structures with the same name appear in other
* files. The structure defined below is used in this file only.
*/
typedef struct ThreadSpecificData {
/*
* This variable holds the list of nested ChannelHandlerEventProc
* invocations.
*/
NextChannelHandler *nestedHandlerPtr;
/*
* List of all channels currently open, indexed by ChannelState,
* as only one ChannelState exists per set of stacked channels.
*/
ChannelState *firstCSPtr;
#ifdef oldcode
/*
* Has a channel exit handler been created yet?
*/
int channelExitHandlerCreated;
/*
* Has the channel event source been created and registered with the
* notifier?
*/
int channelEventSourceCreated;
#endif
/*
* Static variables to hold channels for stdin, stdout and stderr.
*/
Tcl_Channel stdinChannel;
int stdinInitialized;
Tcl_Channel stdoutChannel;
int stdoutInitialized;
Tcl_Channel stderrChannel;
int stderrInitialized;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Structure to record a close callback. One such record exists for
* each close callback registered for a channel.
*/
typedef struct CloseCallback {
Tcl_CloseProc *proc; /* The procedure to call. */
ClientData clientData; /* Arbitrary one-word data to pass
* to the callback. */
struct CloseCallback *nextPtr; /* For chaining close callbacks. */
} CloseCallback;
/*
* Static functions in this file:
*/
static ChannelBuffer * AllocChannelBuffer _ANSI_ARGS_((int length));
static void ChannelTimerProc _ANSI_ARGS_((
ClientData clientData));
static int CheckChannelErrors _ANSI_ARGS_((ChannelState *statePtr,
int direction));
static int CheckFlush _ANSI_ARGS_((Channel *chanPtr,
ChannelBuffer *bufPtr, int newlineFlag));
static int CheckForDeadChannel _ANSI_ARGS_((Tcl_Interp *interp,
ChannelState *statePtr));
static void CheckForStdChannelsBeingClosed _ANSI_ARGS_((
Tcl_Channel chan));
static void CleanupChannelHandlers _ANSI_ARGS_((
Tcl_Interp *interp, Channel *chanPtr));
static int CloseChannel _ANSI_ARGS_((Tcl_Interp *interp,
Channel *chanPtr, int errorCode));
static void CommonGetsCleanup _ANSI_ARGS_((Channel *chanPtr,
Tcl_Encoding encoding));
static int CopyAndTranslateBuffer _ANSI_ARGS_((
ChannelState *statePtr, char *result,
int space));
static int CopyBuffer _ANSI_ARGS_((
Channel *chanPtr, char *result, int space));
static int CopyData _ANSI_ARGS_((CopyState *csPtr, int mask));
static void CopyEventProc _ANSI_ARGS_((ClientData clientData,
int mask));
static void CreateScriptRecord _ANSI_ARGS_((
Tcl_Interp *interp, Channel *chanPtr,
int mask, Tcl_Obj *scriptPtr));
static void DeleteChannelTable _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp,
Channel *chanPtr, int mask));
static int DetachChannel _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
static void DiscardInputQueued _ANSI_ARGS_((ChannelState *statePtr,
int discardSavedBuffers));
static void DiscardOutputQueued _ANSI_ARGS_((
ChannelState *chanPtr));
static int DoRead _ANSI_ARGS_((Channel *chanPtr, char *srcPtr,
int slen));
static int DoWrite _ANSI_ARGS_((Channel *chanPtr, CONST char *src,
int srcLen));
static int DoReadChars _ANSI_ARGS_ ((Channel* chan,
Tcl_Obj* objPtr, int toRead, int appendFlag));
static int DoWriteChars _ANSI_ARGS_ ((Channel* chan,
CONST char* src, int len));
static int FilterInputBytes _ANSI_ARGS_((Channel *chanPtr,
GetsState *statePtr));
static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp,
Channel *chanPtr, int calledFromAsyncFlush));
static Tcl_HashTable * GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp));
static int GetInput _ANSI_ARGS_((Channel *chanPtr));
static int HaveVersion _ANSI_ARGS_((Tcl_ChannelType *typePtr,
Tcl_ChannelTypeVersion minimumVersion));
static void PeekAhead _ANSI_ARGS_((Channel *chanPtr,
char **dstEndPtr, GetsState *gsPtr));
static int ReadBytes _ANSI_ARGS_((ChannelState *statePtr,
Tcl_Obj *objPtr, int charsLeft,
int *offsetPtr));
static int ReadChars _ANSI_ARGS_((ChannelState *statePtr,
Tcl_Obj *objPtr, int charsLeft,
int *offsetPtr, int *factorPtr));
static void RecycleBuffer _ANSI_ARGS_((ChannelState *statePtr,
ChannelBuffer *bufPtr, int mustDiscard));
static int StackSetBlockMode _ANSI_ARGS_((Channel *chanPtr,
int mode));
static int SetBlockMode _ANSI_ARGS_((Tcl_Interp *interp,
Channel *chanPtr, int mode));
static void StopCopy _ANSI_ARGS_((CopyState *csPtr));
static int TranslateInputEOL _ANSI_ARGS_((ChannelState *statePtr,
char *dst, CONST char *src,
int *dstLenPtr, int *srcLenPtr));
static int TranslateOutputEOL _ANSI_ARGS_((ChannelState *statePtr,
char *dst, CONST char *src,
int *dstLenPtr, int *srcLenPtr));
static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr));
static int WriteBytes _ANSI_ARGS_((Channel *chanPtr,
CONST char *src, int srcLen));
static int WriteChars _ANSI_ARGS_((Channel *chanPtr,
CONST char *src, int srcLen));
#define BUSY_STATE(st,fl) \
((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
(((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
#define MAX_CHANNEL_BUFFER_SIZE (1024*1024)
/*
*---------------------------------------------------------------------------
*
* TclInitIOSubsystem --
*
* Initialize all resources used by this subsystem on a per-process
* basis.
*
* Results:
* None.
*
* Side effects:
* Depends on the memory subsystems.
*
*---------------------------------------------------------------------------
*/
void
TclInitIOSubsystem()
{
/*
* By fetching thread local storage we take care of
* allocating it for each thread.
*/
(void) TCL_TSD_INIT(&dataKey);
}
/*
*-------------------------------------------------------------------------
*
* TclFinalizeIOSubsystem --
*
* Releases all resources used by this subsystem on a per-thread
* basis. Closes all extant channels that have not already been
* closed because they were not owned by any interp.
*
* Results:
* None.
*
* Side effects:
* Depends on encoding and memory subsystems.
*
*-------------------------------------------------------------------------
*/
/* ARGSUSED */
void
TclFinalizeIOSubsystem(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Channel *chanPtr = NULL; /* Iterates over open channels. */
ChannelState *statePtr; /* State of channel stack */
int active = 1; /* Flag == 1 while there's still work to do */
/*
* Walk all channel state structures known to this thread and
* close corresponding channels.
*/
while (active) {
/*
* Iterate through the open channel list, and find the first
* channel that isn't dead. We start from the head of the list
* each time, because the close action on one channel can close
* others.
*/
active = 0;
for (statePtr = tsdPtr->firstCSPtr;
statePtr != NULL;
statePtr = statePtr->nextCSPtr) {
chanPtr = statePtr->topChanPtr;
if (!(statePtr->flags & (CHANNEL_INCLOSE|CHANNEL_CLOSED|CHANNEL_DEAD))) {
active = 1;
break;
}
}
/*
* We've found a live channel. Close it.
*/
if (active) {
/*
* Set the channel back into blocking mode to ensure that we
* wait for all data to flush out.
*/
(void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
"-blocking", "on");
if ((chanPtr == (Channel *) tsdPtr->stdinChannel) ||
(chanPtr == (Channel *) tsdPtr->stdoutChannel) ||
(chanPtr == (Channel *) tsdPtr->stderrChannel)) {
/*
* Decrement the refcount which was earlier artificially
* bumped up to keep the channel from being closed.
*/
statePtr->refCount--;
}
if (statePtr->refCount <= 0) {
/*
* Close it only if the refcount indicates that the channel
* is not referenced from any interpreter. If it is, that
* interpreter will close the channel when it gets destroyed.
*/
(void) Tcl_Close(NULL, (Tcl_Channel) chanPtr);
} else {
/*
* The refcount is greater than zero, so flush the channel.
*/
Tcl_Flush((Tcl_Channel) chanPtr);
/*
* Call the device driver to actually close the underlying
* device for this channel.
*/
if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
(chanPtr->typePtr->closeProc)(chanPtr->instanceData, NULL);
} else {
(chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
NULL, 0);
}
/*
* Finally, we clean up the fields in the channel data
* structure since all of them have been deleted already.
* We mark the channel with CHANNEL_DEAD to prevent any
* further IO operations
* on it.
*/
chanPtr->instanceData = NULL;
statePtr->flags |= CHANNEL_DEAD;
}
}
}
TclpFinalizeSockets();
TclpFinalizePipes();
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetStdChannel --
*
* This function is used to change the channels that are used
* for stdin/stdout/stderr in new interpreters.
*
* Results:
* None
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetStdChannel(channel, type)
Tcl_Channel channel;
int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
switch (type) {
case TCL_STDIN:
tsdPtr->stdinInitialized = 1;
tsdPtr->stdinChannel = channel;
break;
case TCL_STDOUT:
tsdPtr->stdoutInitialized = 1;
tsdPtr->stdoutChannel = channel;
break;
case TCL_STDERR:
tsdPtr->stderrInitialized = 1;
tsdPtr->stderrChannel = channel;
break;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetStdChannel --
*
* Returns the specified standard channel.
*
* Results:
* Returns the specified standard channel, or NULL.
*
* Side effects:
* May cause the creation of a standard channel and the underlying
* file.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_GetStdChannel(type)
int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
Tcl_Channel channel = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* If the channels were not created yet, create them now and
* store them in the static variables.
*/
switch (type) {
case TCL_STDIN:
if (!tsdPtr->stdinInitialized) {
tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN);
tsdPtr->stdinInitialized = 1;
/*
* Artificially bump the refcount to ensure that the channel
* is only closed on exit.
*
* NOTE: Must only do this if stdinChannel is not NULL. It
* can be NULL in situations where Tcl is unable to connect
* to the standard input.
*/
if (tsdPtr->stdinChannel != (Tcl_Channel) NULL) {
(void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
tsdPtr->stdinChannel);
}
}
channel = tsdPtr->stdinChannel;
break;
case TCL_STDOUT:
if (!tsdPtr->stdoutInitialized) {
tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT);
tsdPtr->stdoutInitialized = 1;
if (tsdPtr->stdoutChannel != (Tcl_Channel) NULL) {
(void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
tsdPtr->stdoutChannel);
}
}
channel = tsdPtr->stdoutChannel;
break;
case TCL_STDERR:
if (!tsdPtr->stderrInitialized) {
tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR);
tsdPtr->stderrInitialized = 1;
if (tsdPtr->stderrChannel != (Tcl_Channel) NULL) {
(void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
tsdPtr->stderrChannel);
}
}
channel = tsdPtr->stderrChannel;
break;
}
return channel;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateCloseHandler
*
* Creates a close callback which will be called when the channel is
* closed.
*
* Results:
* None.
*
* Side effects:
* Causes the callback to be called in the future when the channel
* will be closed.
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateCloseHandler(chan, proc, clientData)
Tcl_Channel chan; /* The channel for which to create the
* close callback. */
Tcl_CloseProc *proc; /* The callback routine to call when the
* channel will be closed. */
ClientData clientData; /* Arbitrary data to pass to the
* close callback. */
{
ChannelState *statePtr;
CloseCallback *cbPtr;
statePtr = ((Channel *) chan)->state;
cbPtr = (CloseCallback *) ckalloc((unsigned) sizeof(CloseCallback));
cbPtr->proc = proc;
cbPtr->clientData = clientData;
cbPtr->nextPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteCloseHandler --
*
* Removes a callback that would have been called on closing
* the channel. If there is no matching callback then this
* function has no effect.
*
* Results:
* None.
*
* Side effects:
* The callback will not be called in the future when the channel
* is eventually closed.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteCloseHandler(chan, proc, clientData)
Tcl_Channel chan; /* The channel for which to cancel the
* close callback. */
Tcl_CloseProc *proc; /* The procedure for the callback to
* remove. */
ClientData clientData; /* The callback data for the callback
* to remove. */
{
ChannelState *statePtr;
CloseCallback *cbPtr, *cbPrevPtr;
statePtr = ((Channel *) chan)->state;
for (cbPtr = statePtr->closeCbPtr, cbPrevPtr = (CloseCallback *) NULL;
cbPtr != (CloseCallback *) NULL;
cbPtr = cbPtr->nextPtr) {
if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) {
if (cbPrevPtr == (CloseCallback *) NULL) {
statePtr->closeCbPtr = cbPtr->nextPtr;
} else {
cbPrevPtr->nextPtr = cbPtr->nextPtr;
}
ckfree((char *) cbPtr);
break;
} else {
cbPrevPtr = cbPtr;
}
}
}
/*
*----------------------------------------------------------------------
*
* GetChannelTable --
*
* Gets and potentially initializes the channel table for an
* interpreter. If it is initializing the table it also inserts
* channels for stdin, stdout and stderr if the interpreter is
* trusted.
*
* Results:
* A pointer to the hash table created, for use by the caller.
*
* Side effects:
* Initializes the channel table for an interpreter. May create
* channels for stdin, stdout and stderr.
*
*----------------------------------------------------------------------
*/
static Tcl_HashTable *
GetChannelTable(interp)
Tcl_Interp *interp;
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_Channel stdinChan, stdoutChan, stderrChan;
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);
(void) Tcl_SetAssocData(interp, "tclIO",
(Tcl_InterpDeleteProc *) DeleteChannelTable,
(ClientData) hTblPtr);
/*
* If the interpreter is trusted (not "safe"), insert channels
* for stdin, stdout and stderr (possibly creating them in the
* process).
*/
if (Tcl_IsSafe(interp) == 0) {
stdinChan = Tcl_GetStdChannel(TCL_STDIN);
if (stdinChan != NULL) {
Tcl_RegisterChannel(interp, stdinChan);
}
stdoutChan = Tcl_GetStdChannel(TCL_STDOUT);
if (stdoutChan != NULL) {
Tcl_RegisterChannel(interp, stdoutChan);
}
stderrChan = Tcl_GetStdChannel(TCL_STDERR);
if (stderrChan != NULL) {
Tcl_RegisterChannel(interp, stderrChan);
}
}
}
return hTblPtr;
}
/*
*----------------------------------------------------------------------
*
* DeleteChannelTable --
*
* Deletes the channel table for an interpreter, closing any open
* channels whose refcount reaches zero. This procedure is invoked
* when an interpreter is deleted, via the AssocData cleanup
* mechanism.
*
* Results:
* None.
*
* Side effects:
* Deletes the hash table of channels. May close channels. May flush
* output on closed channels. Removes any channeEvent handlers that were
* registered in this interpreter.
*
*----------------------------------------------------------------------
*/
static void
DeleteChannelTable(clientData, interp)
ClientData clientData; /* The per-interpreter data structure. */
Tcl_Interp *interp; /* The interpreter being deleted. */
{
Tcl_HashTable *hTblPtr; /* The hash table. */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Channel *chanPtr; /* Channel being deleted. */
ChannelState *statePtr; /* State of Channel being deleted. */
EventScriptRecord *sPtr, *prevPtr, *nextPtr;
/* Variables to loop over all channel events
* registered, to delete the ones that refer
* to the interpreter being deleted. */
/*
* Delete all the registered channels - this will close channels whose
* refcount reaches zero.
*/
hTblPtr = (Tcl_HashTable *) clientData;
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != (Tcl_HashEntry *) NULL;
hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) {
chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
/*
* Remove any fileevents registered in this interpreter.
*/
for (sPtr = statePtr->scriptRecordPtr,
prevPtr = (EventScriptRecord *) NULL;
sPtr != (EventScriptRecord *) NULL;
sPtr = nextPtr) {
nextPtr = sPtr->nextPtr;
if (sPtr->interp == interp) {
if (prevPtr == (EventScriptRecord *) NULL) {
statePtr->scriptRecordPtr = nextPtr;
} else {
prevPtr->nextPtr = nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, (ClientData) sPtr);
Tcl_DecrRefCount(sPtr->scriptPtr);
ckfree((char *) sPtr);
} else {
prevPtr = sPtr;
}
}
/*
* Cannot call Tcl_UnregisterChannel because that procedure calls
* Tcl_GetAssocData to get the channel table, which might already
* be inaccessible from the interpreter structure. Instead, we
* emulate the behavior of Tcl_UnregisterChannel directly here.
*/
Tcl_DeleteHashEntry(hPtr);
statePtr->refCount--;
if (statePtr->refCount <= 0) {
if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
(void) Tcl_Close(interp, (Tcl_Channel) chanPtr);
}
}
}
Tcl_DeleteHashTable(hTblPtr);
ckfree((char *) hTblPtr);
}
/*
*----------------------------------------------------------------------
*
* CheckForStdChannelsBeingClosed --
*
* Perform special handling for standard channels being closed. When
* given a standard channel, if the refcount is now 1, it means that
* the last reference to the standard channel is being explicitly
* closed. Now bump the refcount artificially down to 0, to ensure the
* normal handling of channels being closed will occur. Also reset the
* static pointer to the channel to NULL, to avoid dangling references.
*
* Results:
* None.
*
* Side effects:
* Manipulates the refcount on standard channels. May smash the global
* static pointer to a standard channel.
*
*----------------------------------------------------------------------
*/
static void
CheckForStdChannelsBeingClosed(chan)
Tcl_Channel chan;
{
ChannelState *statePtr = ((Channel *) chan)->state;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->stdinInitialized
&& tsdPtr->stdinChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdinChannel)->state) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stdinChannel = NULL;
return;
}
} else if (tsdPtr->stdoutInitialized
&& tsdPtr->stdoutChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stdoutChannel = NULL;
return;
}
} else if (tsdPtr->stderrInitialized
&& tsdPtr->stderrChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stderrChannel)->state) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stderrChannel = NULL;
return;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_IsStandardChannel --
*
* Test if the given channel is a standard channel. No attempt
* is made to check if the channel or the standard channels
* are initialized or otherwise valid.
*
* Results:
* Returns 1 if true, 0 if false.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_IsStandardChannel(chan)
Tcl_Channel chan; /* Channel to check. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if ((chan == tsdPtr->stdinChannel)
|| (chan == tsdPtr->stdoutChannel)
|| (chan == tsdPtr->stderrChannel)) {
return 1;
} else {
return 0;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegisterChannel --
*
* Adds an already-open channel to the channel table of an interpreter.
* If the interpreter passed as argument is NULL, it only increments
* the channel refCount.
*
* Results:
* None.
*
* Side effects:
* May increment the reference count of a channel.
*
*----------------------------------------------------------------------
*/
void
Tcl_RegisterChannel(interp, chan)
Tcl_Interp *interp; /* Interpreter in which to add the channel. */
Tcl_Channel chan; /* The channel to add to this interpreter
* channel table. */
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashEntry *hPtr; /* Search variable. */
int new; /* Is the hash entry new or does it exist? */
Channel *chanPtr; /* The actual channel. */
ChannelState *statePtr; /* State of the actual channel. */
/*
* Always (un)register bottom-most channel in the stack. This makes
* management of the channel list easier because no manipulation is
* necessary during (un)stack operation.
*/
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
if (statePtr->channelName == (CONST char *) NULL) {
panic("Tcl_RegisterChannel: channel without name");
}
if (interp != (Tcl_Interp *) NULL) {
hTblPtr = GetChannelTable(interp);
hPtr = Tcl_CreateHashEntry(hTblPtr, statePtr->channelName, &new);
if (new == 0) {
if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) {
return;
}
panic("Tcl_RegisterChannel: duplicate channel names");
}
Tcl_SetHashValue(hPtr, (ClientData) chanPtr);
}
statePtr->refCount++;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnregisterChannel --
*
* Deletes the hash entry for a channel associated with an interpreter.
* If the interpreter given as argument is NULL, it only decrements the
* reference count. (This all happens in the Tcl_DetachChannel helper
* function).
*
* Finally, if the reference count of the channel drops to zero,
* it is deleted.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Calls Tcl_DetachChannel which deletes the hash entry for a channel
* associated with an interpreter.
*
* May delete the channel, which can have a variety of consequences,
* especially if we are forced to close the channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_UnregisterChannel(interp, chan)
Tcl_Interp *interp; /* Interpreter in which channel is defined. */
Tcl_Channel chan; /* Channel to delete. */
{
ChannelState *statePtr; /* State of the real channel. */
statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
if (statePtr->flags & CHANNEL_INCLOSE) {
if (interp != (Tcl_Interp*) NULL) {
Tcl_AppendResult(interp,
"Illegal recursive call to close through close-handler of channel",
(char *) NULL);
}
return TCL_ERROR;
}
if (DetachChannel(interp, chan) != TCL_OK) {
return TCL_OK;
}
statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
/*
* Perform special handling for standard channels being closed. If the
* refCount is now 1 it means that the last reference to the standard
* channel is being explicitly closed, so bump the refCount down
* artificially to 0. This will ensure that the channel is actually
* closed, below. Also set the static pointer to NULL for the channel.
*/
CheckForStdChannelsBeingClosed(chan);
/*
* If the refCount reached zero, close the actual channel.
*/
if (statePtr->refCount <= 0) {
/*
* Ensure that if there is another buffer, it gets flushed
* whether or not we are doing a background flush.
*/
if ((statePtr->curOutPtr != NULL) &&
(statePtr->curOutPtr->nextAdded >
statePtr->curOutPtr->nextRemoved)) {
statePtr->flags |= BUFFER_READY;
}
Tcl_Preserve((ClientData)statePtr);
if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
/* We don't want to re-enter Tcl_Close */
if (!(statePtr->flags & CHANNEL_CLOSED)) {
if (Tcl_Close(interp, chan) != TCL_OK) {
statePtr->flags |= CHANNEL_CLOSED;
Tcl_Release((ClientData)statePtr);
return TCL_ERROR;
}
}
}
statePtr->flags |= CHANNEL_CLOSED;
Tcl_Release((ClientData)statePtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DetachChannel --
*
* Deletes the hash entry for a channel associated with an interpreter.
* If the interpreter given as argument is NULL, it only decrements the
* reference count. Even if the ref count drops to zero, the
* channel is NOT closed or cleaned up. This allows a channel to
* be detached from an interpreter and left in the same state it
* was in when it was originally returned by 'Tcl_OpenFileChannel',
* for example.
*
* This function cannot be used on the standard channels, and
* will return TCL_ERROR if that is attempted.
*
* This function should only be necessary for special purposes
* in which you need to generate a pristine channel from one
* that has already been used. All ordinary purposes will almost
* always want to use Tcl_UnregisterChannel instead.
*
* Provided the channel is not attached to any other interpreter,
* it can then be closed with Tcl_Close, rather than with
* Tcl_UnregisterChannel.
*
* Results:
* A standard Tcl result. If the channel is not currently registered
* with the given interpreter, TCL_ERROR is returned, otherwise
* TCL_OK. However no error messages are left in the interp's result.
*
* Side effects:
* Deletes the hash entry for a channel associated with an
* interpreter.
*
*----------------------------------------------------------------------
*/
int
Tcl_DetachChannel(interp, chan)
Tcl_Interp *interp; /* Interpreter in which channel is defined. */
Tcl_Channel chan; /* Channel to delete. */
{
if (Tcl_IsStandardChannel(chan)) {
return TCL_ERROR;
}
return DetachChannel(interp, chan);
}
/*
*----------------------------------------------------------------------
*
* DetachChannel --
*
* Deletes the hash entry for a channel associated with an interpreter.
* If the interpreter given as argument is NULL, it only decrements the
* reference count. Even if the ref count drops to zero, the
* channel is NOT closed or cleaned up. This allows a channel to
* be detached from an interpreter and left in the same state it
* was in when it was originally returned by 'Tcl_OpenFileChannel',
* for example.
*
* Results:
* A standard Tcl result. If the channel is not currently registered
* with the given interpreter, TCL_ERROR is returned, otherwise
* TCL_OK. However no error messages are left in the interp's result.
*
* Side effects:
* Deletes the hash entry for a channel associated with an
* interpreter.
*
*----------------------------------------------------------------------
*/
static int
DetachChannel(interp, chan)
Tcl_Interp *interp; /* Interpreter in which channel is defined. */
Tcl_Channel chan; /* Channel to delete. */
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashEntry *hPtr; /* Search variable. */
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of the real channel. */
/*
* Always (un)register bottom-most channel in the stack. This makes
* management of the channel list easier because no manipulation is
* necessary during (un)stack operation.
*/
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
if (interp != (Tcl_Interp *) NULL) {
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
if (hPtr == (Tcl_HashEntry *) NULL) {
return TCL_ERROR;
}
if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
return TCL_ERROR;
}
Tcl_DeleteHashEntry(hPtr);
/*
* Remove channel handlers that refer to this interpreter, so that they
* will not be present if the actual close is delayed and more events
* happen on the channel. This may occur if the channel is shared
* between several interpreters, or if the channel has async
* flushing active.
*/
CleanupChannelHandlers(interp, chanPtr);
}
statePtr->refCount--;
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_GetChannel --
*
* Finds an existing Tcl_Channel structure by name in a given
* interpreter. This function is public because it is used by
* channel-type-specific functions.
*
* Results:
* A Tcl_Channel or NULL on failure. If failed, interp's result
* object contains an error message. *modePtr is filled with the
* modes in which the channel was opened.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Channel
Tcl_GetChannel(interp, chanName, modePtr)
Tcl_Interp *interp; /* Interpreter in which to find or create
* the channel. */
CONST char *chanName; /* The name of the channel. */
int *modePtr; /* Where to store the mode in which the
* channel was opened? Will contain an ORed
* combination of TCL_READABLE and
* TCL_WRITABLE, if non-NULL. */
{
Channel *chanPtr; /* The actual channel. */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashEntry *hPtr; /* Search variable. */
CONST char *name; /* Translated name. */
/*
* Substitute "stdin", etc. Note that even though we immediately
* find the channel using Tcl_GetStdChannel, we still need to look
* it up in the specified interpreter to ensure that it is present
* in the channel table. Otherwise, safe interpreters would always
* have access to the standard channels.
*/
name = chanName;
if ((chanName[0] == 's') && (chanName[1] == 't')) {
chanPtr = NULL;
if (strcmp(chanName, "stdin") == 0) {
chanPtr = (Channel *) Tcl_GetStdChannel(TCL_STDIN);
} else if (strcmp(chanName, "stdout") == 0) {
chanPtr = (Channel *) Tcl_GetStdChannel(TCL_STDOUT);
} else if (strcmp(chanName, "stderr") == 0) {
chanPtr = (Channel *) Tcl_GetStdChannel(TCL_STDERR);
}
if (chanPtr != NULL) {
name = chanPtr->state->channelName;
}
}
hTblPtr = GetChannelTable(interp);
hPtr = Tcl_FindHashEntry(hTblPtr, name);
if (hPtr == (Tcl_HashEntry *) NULL) {
Tcl_AppendResult(interp, "can not find channel named \"",
chanName, "\"", (char *) NULL);
return NULL;
}
/*
* Always return bottom-most channel in the stack. This one lives
* the longest - other channels may go away unnoticed.
* The other APIs compensate where necessary to retrieve the
* topmost channel again.
*/
chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
chanPtr = chanPtr->state->bottomChanPtr;
if (modePtr != NULL) {
*modePtr = (chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE));
}
return (Tcl_Channel) chanPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateChannel --
*
* Creates a new entry in the hash table for a Tcl_Channel
* record.
*
* Results:
* Returns the new Tcl_Channel.
*
* Side effects:
* Creates a new Tcl_Channel instance and inserts it into the
* hash table.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_CreateChannel(typePtr, chanName, instanceData, mask)
Tcl_ChannelType *typePtr; /* The channel type record. */
CONST char *chanName; /* Name of channel to record. */
ClientData instanceData; /* Instance specific data. */
int mask; /* TCL_READABLE & TCL_WRITABLE to indicate
* if the channel is readable, writable. */
{
Channel *chanPtr; /* The channel structure newly created. */
ChannelState *statePtr; /* The stack-level independent state info
* for the channel. */
CONST char *name;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* With the change of the Tcl_ChannelType structure to use a version in
* 8.3.2+, we have to make sure that our assumption that the structure
* remains a binary compatible size is true.
*
* If this assertion fails on some system, then it can be removed
* only if the user recompiles code with older channel drivers in
* the new system as well.
*/
assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc*));
/*
* JH: We could subsequently memset these to 0 to avoid the
* numerous assignments to 0/NULL below.
*/
chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel));
statePtr = (ChannelState *) ckalloc((unsigned) sizeof(ChannelState));
chanPtr->state = statePtr;
chanPtr->instanceData = instanceData;
chanPtr->typePtr = typePtr;
/*
* Set all the bits that are part of the stack-independent state
* information for the channel.
*/
if (chanName != (char *) NULL) {
char *tmp = ckalloc((unsigned) (strlen(chanName) + 1));
statePtr->channelName = tmp;
strcpy(tmp, chanName);
} else {
panic("Tcl_CreateChannel: NULL channel name");
}
statePtr->flags = mask;
/*
* Set the channel to system default encoding.
*/
statePtr->encoding = NULL;
name = Tcl_GetEncodingName(NULL);
if (strcmp(name, "binary") != 0) {
statePtr->encoding = Tcl_GetEncoding(NULL, name);
}
statePtr->inputEncodingState = NULL;
statePtr->inputEncodingFlags = TCL_ENCODING_START;
statePtr->outputEncodingState = NULL;
statePtr->outputEncodingFlags = TCL_ENCODING_START;
/*
* Set the channel up initially in AUTO input translation mode to
* accept "\n", "\r" and "\r\n". Output translation mode is set to
* a platform specific default value. The eofChar is set to 0 for both
* input and output, so that Tcl does not look for an in-file EOF
* indicator (e.g. ^Z) and does not append an EOF indicator to files.
*/
statePtr->inputTranslation = TCL_TRANSLATE_AUTO;
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
statePtr->inEofChar = 0;
statePtr->outEofChar = 0;
statePtr->unreportedError = 0;
statePtr->refCount = 0;
statePtr->closeCbPtr = (CloseCallback *) NULL;
statePtr->curOutPtr = (ChannelBuffer *) NULL;
statePtr->outQueueHead = (ChannelBuffer *) NULL;
statePtr->outQueueTail = (ChannelBuffer *) NULL;
statePtr->saveInBufPtr = (ChannelBuffer *) NULL;
statePtr->inQueueHead = (ChannelBuffer *) NULL;
statePtr->inQueueTail = (ChannelBuffer *) NULL;
statePtr->chPtr = (ChannelHandler *) NULL;
statePtr->interestMask = 0;
statePtr->scriptRecordPtr = (EventScriptRecord *) NULL;
statePtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE;
statePtr->timer = NULL;
statePtr->csPtrR = NULL;
statePtr->csPtrW = NULL;
statePtr->outputStage = NULL;
if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
statePtr->outputStage = (char *)
ckalloc((unsigned) (statePtr->bufSize + 2));
}
/*
* As we are creating the channel, it is obviously the top for now
*/
statePtr->topChanPtr = chanPtr;
statePtr->bottomChanPtr = chanPtr;
chanPtr->downChanPtr = (Channel *) NULL;
chanPtr->upChanPtr = (Channel *) NULL;
chanPtr->inQueueHead = (ChannelBuffer*) NULL;
chanPtr->inQueueTail = (ChannelBuffer*) NULL;
/*
* Link the channel into the list of all channels; create an on-exit
* handler if there is not one already, to close off all the channels
* in the list on exit.
*
* JH: Could call Tcl_SpliceChannel, but need to avoid NULL check.
*
* TIP #218.
* AK: Just initialize the field to NULL before invoking Tcl_SpliceChannel
* We need Tcl_SpliceChannel, for the threadAction calls.
* There is no real reason to duplicate all of this.
* NOTE: All drivers using thread actions now have to perform their TSD
* manipulation only in their thread action proc. Doing it when
* creating their instance structures will collide with the thread
* action activity and lead to damaged lists.
*/
statePtr->nextCSPtr = (ChannelState *) NULL;
Tcl_SpliceChannel ((Tcl_Channel) chanPtr);
/*
* Install this channel in the first empty standard channel slot, if
* the channel was previously closed explicitly.
*/
#if TCL_INHERIT_STD_CHANNELS
if ((tsdPtr->stdinChannel == NULL) &&
(tsdPtr->stdinInitialized == 1)) {
Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDIN);
Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
} else if ((tsdPtr->stdoutChannel == NULL) &&
(tsdPtr->stdoutInitialized == 1)) {
Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDOUT);
Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
} else if ((tsdPtr->stderrChannel == NULL) &&
(tsdPtr->stderrInitialized == 1)) {
Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDERR);
Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
}
#endif
return (Tcl_Channel) chanPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_StackChannel --
*
* Replaces an entry in the hash table for a Tcl_Channel
* record. The replacement is a new channel with same name,
* it supercedes the replaced channel. Input and output of
* the superceded channel is now going through the newly
* created channel and allows the arbitrary filtering/manipulation
* of the dataflow.
*
* Andreas Kupries , 12/13/1998
* "Trf-Patch for filtering channels"
*
* Results:
* Returns the new Tcl_Channel, which actually contains the
* saved information about prevChan.
*
* Side effects:
* A new channel structure is allocated and linked below
* the existing channel. The channel operations and client
* data of the existing channel are copied down to the newly
* created channel, and the current channel has its operations
* replaced by the new typePtr.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan)
Tcl_Interp *interp; /* The interpreter we are working in */
Tcl_ChannelType *typePtr; /* The channel type record for the new
* channel. */
ClientData instanceData; /* Instance specific data for the new
* channel. */
int mask; /* TCL_READABLE & TCL_WRITABLE to indicate
* if the channel is readable, writable. */
Tcl_Channel prevChan; /* The channel structure to replace */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Channel *chanPtr, *prevChanPtr;
ChannelState *statePtr;
/*
* Find the given channel in the list of all channels.
* If we don't find it, then it was never registered correctly.
*
* This operation should occur at the top of a channel stack.
*/
statePtr = (ChannelState *) tsdPtr->firstCSPtr;
prevChanPtr = ((Channel *) prevChan)->state->topChanPtr;
while ((statePtr != NULL) && (statePtr->topChanPtr != prevChanPtr)) {
statePtr = statePtr->nextCSPtr;
}
if (statePtr == NULL) {
if (interp) {
Tcl_AppendResult(interp, "couldn't find state for channel \"",
Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
}
return (Tcl_Channel) NULL;
}
/*
* Here we check if the given "mask" matches the "flags"
* of the already existing channel.
*
* | - | R | W | RW |
* --+---+---+---+----+ <=> 0 != (chan->mask & prevChan->mask)
* - | | | | |
* R | | + | | + | The superceding channel is allowed to
* W | | | + | + | restrict the capabilities of the
* RW| | + | + | + | superceded one !
* --+---+---+---+----+
*/
if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) {
if (interp) {
Tcl_AppendResult(interp,
"reading and writing both disallowed for channel \"",
Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
}
return (Tcl_Channel) NULL;
}
/*
* Flush the buffers. This ensures that any data still in them
* at this time is not handled by the new transformation. Restrict
* this to writable channels. Take care to hide a possible bg-copy
* in progress from Tcl_Flush and the CheckForChannelErrors inside.
*/
if ((mask & TCL_WRITABLE) != 0) {
CopyState *csPtrR;
CopyState *csPtrW;
csPtrR = statePtr->csPtrR;
statePtr->csPtrR = (CopyState*) NULL;
csPtrW = statePtr->csPtrW;
statePtr->csPtrW = (CopyState*) NULL;
if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
if (interp) {
Tcl_AppendResult(interp, "could not flush channel \"",
Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
}
return (Tcl_Channel) NULL;
}
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
}
/*
* Discard any input in the buffers. They are not yet read by the
* user of the channel, so they have to go through the new
* transformation before reading. As the buffers contain the
* untransformed form their contents are not only useless but actually
* distorts our view of the system.
*
* To preserve the information without having to read them again and
* to avoid problems with the location in the channel (seeking might
* be impossible) we move the buffers from the common state structure
* into the channel itself. We use the buffers in the channel below
* the new transformation to hold the data. In the future this allows
* us to write transformations which pre-read data and push the unused
* part back when they are going away.
*/
if (((mask & TCL_READABLE) != 0) &&
(statePtr->inQueueHead != (ChannelBuffer*) NULL)) {
/*
* Remark: It is possible that the channel buffers contain data from
* some earlier push-backs.
*/
statePtr->inQueueTail->nextPtr = prevChanPtr->inQueueHead;
prevChanPtr->inQueueHead = statePtr->inQueueHead;
if (prevChanPtr->inQueueTail == (ChannelBuffer*) NULL) {
prevChanPtr->inQueueTail = statePtr->inQueueTail;
}
statePtr->inQueueHead = (ChannelBuffer*) NULL;
statePtr->inQueueTail = (ChannelBuffer*) NULL;
}
chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel));
/*
* Save some of the current state into the new structure,
* reinitialize the parts which will stay with the transformation.
*
* Remarks:
*/
chanPtr->state = statePtr;
chanPtr->instanceData = instanceData;
chanPtr->typePtr = typePtr;
chanPtr->downChanPtr = prevChanPtr;
chanPtr->upChanPtr = (Channel *) NULL;
chanPtr->inQueueHead = (ChannelBuffer*) NULL;
chanPtr->inQueueTail = (ChannelBuffer*) NULL;
/*
* Place new block at the head of a possibly existing list of previously
* stacked channels.
*/
prevChanPtr->upChanPtr = chanPtr;
statePtr->topChanPtr = chanPtr;
return (Tcl_Channel) chanPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnstackChannel --
*
* Unstacks an entry in the hash table for a Tcl_Channel
* record. This is the reverse to 'Tcl_StackChannel'.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* If TCL_ERROR is returned, the posix error code will be set
* with Tcl_SetErrno.
*
*----------------------------------------------------------------------
*/
int
Tcl_UnstackChannel (interp, chan)
Tcl_Interp *interp; /* The interpreter we are working in */
Tcl_Channel chan; /* The channel to unstack */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
int result = 0;
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
if (chanPtr->downChanPtr != (Channel *) NULL) {
/*
* Instead of manipulating the per-thread / per-interp list/hashtable
* of registered channels we wind down the state of the transformation,
* and then restore the state of underlying channel into the old
* structure.
*/
Channel *downChanPtr = chanPtr->downChanPtr;
/*
* Flush the buffers. This ensures that any data still in them
* at this time _is_ handled by the transformation we are unstacking
* right now. Restrict this to writable channels. Take care to hide
* a possible bg-copy in progress from Tcl_Flush and the
* CheckForChannelErrors inside.
*/
if (statePtr->flags & TCL_WRITABLE) {
CopyState *csPtrR;
CopyState *csPtrW;
csPtrR = statePtr->csPtrR;
statePtr->csPtrR = (CopyState*) NULL;
csPtrW = statePtr->csPtrW;
statePtr->csPtrW = (CopyState*) NULL;
if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) {
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
if (interp) {
Tcl_AppendResult(interp, "could not flush channel \"",
Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"",
(char *) NULL);
}
return TCL_ERROR;
}
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
}
/*
* Anything in the input queue and the push-back buffers of
* the transformation going away is transformed data, but not
* yet read. As unstacking means that the caller does not want
* to see transformed data any more we have to discard these
* bytes. To avoid writing an analogue to 'DiscardInputQueued'
* we move the information in the push back buffers to the
* input queue and then call 'DiscardInputQueued' on that.
*/
if (((statePtr->flags & TCL_READABLE) != 0) &&
((statePtr->inQueueHead != (ChannelBuffer*) NULL) ||
(chanPtr->inQueueHead != (ChannelBuffer*) NULL))) {
if ((statePtr->inQueueHead != (ChannelBuffer*) NULL) &&
(chanPtr->inQueueHead != (ChannelBuffer*) NULL)) {
statePtr->inQueueTail->nextPtr = chanPtr->inQueueHead;
statePtr->inQueueTail = chanPtr->inQueueTail;
statePtr->inQueueHead = statePtr->inQueueTail;
} else if (chanPtr->inQueueHead != (ChannelBuffer*) NULL) {
statePtr->inQueueHead = chanPtr->inQueueHead;
statePtr->inQueueTail = chanPtr->inQueueTail;
}
chanPtr->inQueueHead = (ChannelBuffer*) NULL;
chanPtr->inQueueTail = (ChannelBuffer*) NULL;
DiscardInputQueued (statePtr, 0);
}
statePtr->topChanPtr = downChanPtr;
downChanPtr->upChanPtr = (Channel *) NULL;
/*
* Leave this link intact for closeproc
* chanPtr->downChanPtr = (Channel *) NULL;
*/
/*
* Close and free the channel driver state.
*/
if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData,
interp);
} else {
result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
interp, 0);
}
chanPtr->typePtr = NULL;
/*
* AK: Tcl_NotifyChannel may hold a reference to this block of memory
*/
Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
UpdateInterest(downChanPtr);
if (result != 0) {
Tcl_SetErrno(result);
return TCL_ERROR;
}
} else {
/*
* This channel does not cover another one.
* Simply do a close, if necessary.
*/
if (statePtr->refCount <= 0) {
if (Tcl_Close(interp, chan) != TCL_OK) {
return TCL_ERROR;
}
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetStackedChannel --
*
* Determines whether the specified channel is stacked upon another.
*
* Results:
* NULL if the channel is not stacked upon another one, or a reference
* to the channel it is stacked upon. This reference can be used in
* queries, but modification is not allowed.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_GetStackedChannel(chan)
Tcl_Channel chan;
{
Channel *chanPtr = (Channel *) chan; /* The actual channel. */
return (Tcl_Channel) chanPtr->downChanPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetTopChannel --
*
* Returns the top channel of a channel stack.
*
* Results:
* NULL if the channel is not stacked upon another one, or a reference
* to the channel it is stacked upon. This reference can be used in
* queries, but modification is not allowed.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_GetTopChannel(chan)
Tcl_Channel chan;
{
Channel *chanPtr = (Channel *) chan; /* The actual channel. */
return (Tcl_Channel) chanPtr->state->topChanPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelInstanceData --
*
* Returns the client data associated with a channel.
*
* Results:
* The client data.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_GetChannelInstanceData(chan)
Tcl_Channel chan; /* Channel for which to return client data. */
{
Channel *chanPtr = (Channel *) chan; /* The actual channel. */
return chanPtr->instanceData;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelThread --
*
* Given a channel structure, returns the thread managing it.
* TIP #10
*
* Results:
* Returns the id of the thread managing the channel.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_ThreadId
Tcl_GetChannelThread(chan)
Tcl_Channel chan; /* The channel to return managing thread for. */
{
Channel *chanPtr = (Channel *) chan; /* The actual channel. */
return chanPtr->state->managingThread;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelType --
*
* Given a channel structure, returns the channel type structure.
*
* Results:
* Returns a pointer to the channel type structure.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_ChannelType *
Tcl_GetChannelType(chan)
Tcl_Channel chan; /* The channel to return type for. */
{
Channel *chanPtr = (Channel *) chan; /* The actual channel. */
return chanPtr->typePtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelMode --
*
* Computes a mask indicating whether the channel is open for
* reading and writing.
*
* Results:
* An OR-ed combination of TCL_READABLE and TCL_WRITABLE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetChannelMode(chan)
Tcl_Channel chan; /* The channel for which the mode is
* being computed. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of actual channel. */
return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE));
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelName --
*
* Returns the string identifying the channel name.
*
* Results:
* The string containing the channel name. This memory is
* owned by the generic layer and should not be modified by
* the caller.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_GetChannelName(chan)
Tcl_Channel chan; /* The channel for which to return the name. */
{
ChannelState *statePtr; /* State of actual channel. */
statePtr = ((Channel *) chan)->state;
return statePtr->channelName;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelHandle --
*
* Returns an OS handle associated with a channel.
*
* Results:
* Returns TCL_OK and places the handle in handlePtr, or returns
* TCL_ERROR on failure.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetChannelHandle(chan, direction, handlePtr)
Tcl_Channel chan; /* The channel to get file from. */
int direction; /* TCL_WRITABLE or TCL_READABLE. */
ClientData *handlePtr; /* Where to store handle */
{
Channel *chanPtr; /* The actual channel. */
ClientData handle;
int result;
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
result = (chanPtr->typePtr->getHandleProc)(chanPtr->instanceData,
direction, &handle);
if (handlePtr) {
*handlePtr = handle;
}
return result;
}
/*
*---------------------------------------------------------------------------
*
* AllocChannelBuffer --
*
* A channel buffer has BUFFER_PADDING bytes extra at beginning to
* hold any bytes of a native-encoding character that got split by
* the end of the previous buffer and need to be moved to the
* beginning of the next buffer to make a contiguous string so it
* can be converted to UTF-8.
*
* A channel buffer has BUFFER_PADDING bytes extra at the end to
* hold any bytes of a native-encoding character (generated from a
* UTF-8 character) that overflow past the end of the buffer and
* need to be moved to the next buffer.
*
* Results:
* A newly allocated channel buffer.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static ChannelBuffer *
AllocChannelBuffer(length)
int length; /* Desired length of channel buffer. */
{
ChannelBuffer *bufPtr;
int n;
n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
bufPtr = (ChannelBuffer *) ckalloc((unsigned) n);
bufPtr->nextAdded = BUFFER_PADDING;
bufPtr->nextRemoved = BUFFER_PADDING;
bufPtr->bufLength = length + BUFFER_PADDING;
bufPtr->nextPtr = (ChannelBuffer *) NULL;
return bufPtr;
}
/*
*----------------------------------------------------------------------
*
* RecycleBuffer --
*
* Helper function to recycle input and output buffers. Ensures
* that two input buffers are saved (one in the input queue and
* another in the saveInBufPtr field) and that curOutPtr is set
* to a buffer. Only if these conditions are met is the buffer
* freed to the OS.
*
* Results:
* None.
*
* Side effects:
* May free a buffer to the OS.
*
*----------------------------------------------------------------------
*/
static void
RecycleBuffer(statePtr, bufPtr, mustDiscard)
ChannelState *statePtr; /* ChannelState in which to recycle buffers. */
ChannelBuffer *bufPtr; /* The buffer to recycle. */
int mustDiscard; /* If nonzero, free the buffer to the
* OS, always. */
{
/*
* Do we have to free the buffer to the OS?
*/
if (mustDiscard) {
ckfree((char *) bufPtr);
return;
}
/*
* Only save buffers which are at least as big as the requested
* buffersize for the channel. This is to honor dynamic changes
* of the buffersize made by the user.
*/
if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) {
ckfree((char *) bufPtr);
return;
}
/*
* Only save buffers for the input queue if the channel is readable.
*/
if (statePtr->flags & TCL_READABLE) {
if (statePtr->inQueueHead == (ChannelBuffer *) NULL) {
statePtr->inQueueHead = bufPtr;
statePtr->inQueueTail = bufPtr;
goto keepit;
}
if (statePtr->saveInBufPtr == (ChannelBuffer *) NULL) {
statePtr->saveInBufPtr = bufPtr;
goto keepit;
}
}
/*
* Only save buffers for the output queue if the channel is writable.
*/
if (statePtr->flags & TCL_WRITABLE) {
if (statePtr->curOutPtr == (ChannelBuffer *) NULL) {
statePtr->curOutPtr = bufPtr;
goto keepit;
}
}
/*
* If we reached this code we return the buffer to the OS.
*/
ckfree((char *) bufPtr);
return;
keepit:
bufPtr->nextRemoved = BUFFER_PADDING;
bufPtr->nextAdded = BUFFER_PADDING;
bufPtr->nextPtr = (ChannelBuffer *) NULL;
}
/*
*----------------------------------------------------------------------
*
* DiscardOutputQueued --
*
* Discards all output queued in the output queue of a channel.
*
* Results:
* None.
*
* Side effects:
* Recycles buffers.
*
*----------------------------------------------------------------------
*/
static void
DiscardOutputQueued(statePtr)
ChannelState *statePtr; /* ChannelState for which to discard output. */
{
ChannelBuffer *bufPtr;
while (statePtr->outQueueHead != (ChannelBuffer *) NULL) {
bufPtr = statePtr->outQueueHead;
statePtr->outQueueHead = bufPtr->nextPtr;
RecycleBuffer(statePtr, bufPtr, 0);
}
statePtr->outQueueHead = (ChannelBuffer *) NULL;
statePtr->outQueueTail = (ChannelBuffer *) NULL;
}
/*
*----------------------------------------------------------------------
*
* CheckForDeadChannel --
*
* This function checks is a given channel is Dead.
* (A channel that has been closed but not yet deallocated.)
*
* Results:
* True (1) if channel is Dead, False (0) if channel is Ok
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
static int
CheckForDeadChannel(interp, statePtr)
Tcl_Interp *interp; /* For error reporting (can be NULL) */
ChannelState *statePtr; /* The channel state to check. */
{
if (statePtr->flags & CHANNEL_DEAD) {
Tcl_SetErrno(EINVAL);
if (interp) {
Tcl_AppendResult(interp,
"unable to access channel: invalid channel",
(char *) NULL);
}
return 1;
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* FlushChannel --
*
* This function flushes as much of the queued output as is possible
* now. If calledFromAsyncFlush is nonzero, it is being called in an
* event handler to flush channel output asynchronously.
*
* Results:
* 0 if successful, else the error code that was returned by the
* channel type operation.
*
* Side effects:
* May produce output on a channel. May block indefinitely if the
* channel is synchronous. May schedule an async flush on the channel.
* May recycle memory for buffers in the output queue.
*
*----------------------------------------------------------------------
*/
static int
FlushChannel(interp, chanPtr, calledFromAsyncFlush)
Tcl_Interp *interp; /* For error reporting during close. */
Channel *chanPtr; /* The channel to flush on. */
int calledFromAsyncFlush; /* If nonzero then we are being
* called from an asynchronous
* flush callback. */
{
ChannelState *statePtr = chanPtr->state;
/* State of the channel stack. */
ChannelBuffer *bufPtr; /* Iterates over buffered output
* queue. */
int toWrite; /* Amount of output data in current
* buffer available to be written. */
int written; /* Amount of output data actually
* written in current round. */
int errorCode = 0; /* Stores POSIX error codes from
* channel driver operations. */
int wroteSome = 0; /* Set to one if any data was
* written to the driver. */
/*
* Prevent writing on a dead channel -- a channel that has been closed
* but not yet deallocated. This can occur if the exit handler for the
* channel deallocation runs before all channels are deregistered in
* all interpreters.
*/
if (CheckForDeadChannel(interp, statePtr)) return -1;
/*
* Loop over the queued buffers and attempt to flush as
* much as possible of the queued output to the channel.
*/
while (1) {
/*
* If the queue is empty and there is a ready current buffer, OR if
* the current buffer is full, then move the current buffer to the
* queue.
*/
if (((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
(statePtr->curOutPtr->nextAdded == statePtr->curOutPtr->bufLength))
|| ((statePtr->flags & BUFFER_READY) &&
(statePtr->outQueueHead == (ChannelBuffer *) NULL))) {
statePtr->flags &= (~(BUFFER_READY));
statePtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL;
if (statePtr->outQueueHead == (ChannelBuffer *) NULL) {
statePtr->outQueueHead = statePtr->curOutPtr;
} else {
statePtr->outQueueTail->nextPtr = statePtr->curOutPtr;
}
statePtr->outQueueTail = statePtr->curOutPtr;
statePtr->curOutPtr = (ChannelBuffer *) NULL;
}
bufPtr = statePtr->outQueueHead;
/*
* If we are not being called from an async flush and an async
* flush is active, we just return without producing any output.
*/
if ((!calledFromAsyncFlush) &&
(statePtr->flags & BG_FLUSH_SCHEDULED)) {
return 0;
}
/*
* If the output queue is still empty, break out of the while loop.
*/
if (bufPtr == (ChannelBuffer *) NULL) {
break; /* Out of the "while (1)". */
}
/*
* Produce the output on the channel.
*/
toWrite = bufPtr->nextAdded - bufPtr->nextRemoved;
if (toWrite == 0) {
written = 0;
} else {
written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData,
bufPtr->buf + bufPtr->nextRemoved, toWrite,
&errorCode);
}
/*
* If the write failed completely attempt to start the asynchronous
* flush mechanism and break out of this loop - do not attempt to
* write any more output at this time.
*/
if (written < 0) {
/*
* If the last attempt to write was interrupted, simply retry.
*/
if (errorCode == EINTR) {
errorCode = 0;
continue;
}
/*
* If the channel is non-blocking and we would have blocked,
* start a background flushing handler and break out of the loop.
*/
if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) {
/*
* This used to check for CHANNEL_NONBLOCKING, and panic
* if the channel was blocking. However, it appears
* that setting stdin to -blocking 0 has some effect on
* the stdout when it's a tty channel (dup'ed underneath)
*/
if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
statePtr->flags |= BG_FLUSH_SCHEDULED;
UpdateInterest(chanPtr);
}
errorCode = 0;
break;
}
/*
* Decide whether to report the error upwards or defer it.
*/
if (calledFromAsyncFlush) {
if (statePtr->unreportedError == 0) {
statePtr->unreportedError = errorCode;
}
} else {
Tcl_SetErrno(errorCode);
if (interp != NULL) {
/*
* Casting away CONST here is safe because the
* TCL_VOLATILE flag guarantees CONST treatment
* of the Posix error string.
*/
Tcl_SetResult(interp,
(char *) Tcl_PosixError(interp), TCL_VOLATILE);
}
}
/*
* When we get an error we throw away all the output
* currently queued.
*/
DiscardOutputQueued(statePtr);
continue;
} else {
wroteSome = 1;
}
bufPtr->nextRemoved += written;
/*
* If this buffer is now empty, recycle it.
*/
if (bufPtr->nextRemoved == bufPtr->nextAdded) {
statePtr->outQueueHead = bufPtr->nextPtr;
if (statePtr->outQueueHead == (ChannelBuffer *) NULL) {
statePtr->outQueueTail = (ChannelBuffer *) NULL;
}
RecycleBuffer(statePtr, bufPtr, 0);
}
} /* Closes "while (1)". */
/*
* If we wrote some data while flushing in the background, we are done.
* We can't finish the background flush until we run out of data and
* the channel becomes writable again. This ensures that all of the
* pending data has been flushed at the system level.
*/
if (statePtr->flags & BG_FLUSH_SCHEDULED) {
if (wroteSome) {
return errorCode;
} else if (statePtr->outQueueHead == (ChannelBuffer *) NULL) {
statePtr->flags &= (~(BG_FLUSH_SCHEDULED));
(chanPtr->typePtr->watchProc)(chanPtr->instanceData,
statePtr->interestMask);
}
}
/*
* If the channel is flagged as closed, delete it when the refCount
* drops to zero, the output queue is empty and there is no output
* in the current output buffer.
*/
if ((statePtr->flags & CHANNEL_CLOSED) && (statePtr->refCount <= 0) &&
(statePtr->outQueueHead == (ChannelBuffer *) NULL) &&
((statePtr->curOutPtr == (ChannelBuffer *) NULL) ||
(statePtr->curOutPtr->nextAdded ==
statePtr->curOutPtr->nextRemoved))) {
return CloseChannel(interp, chanPtr, errorCode);
}
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* CloseChannel --
*
* Utility procedure to close a channel and free associated resources.
*
* If the channel was stacked, then the it will copy the necessary
* elements of the NEXT channel into the TOP channel, in essence
* unstacking the channel. The NEXT channel will then be freed.
*
* If the channel was not stacked, then we will free all the bits
* for the TOP channel, including the data structure itself.
*
* Results:
* 1 if the channel was stacked, 0 otherwise.
*
* Side effects:
* May close the actual channel; may free memory.
* May change the value of errno.
*
*----------------------------------------------------------------------
*/
static int
CloseChannel(interp, chanPtr, errorCode)
Tcl_Interp *interp; /* For error reporting. */
Channel *chanPtr; /* The channel to close. */
int errorCode; /* Status of operation so far. */
{
int result = 0; /* Of calling driver close
* operation. */
ChannelState *statePtr; /* state of the channel stack. */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (chanPtr == NULL) {
return result;
}
statePtr = chanPtr->state;
/*
* No more input can be consumed so discard any leftover input.
*/
DiscardInputQueued(statePtr, 1);
/*
* Discard a leftover buffer in the current output buffer field.
*/
if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
ckfree((char *) statePtr->curOutPtr);
statePtr->curOutPtr = (ChannelBuffer *) NULL;
}
/*
* The caller guarantees that there are no more buffers
* queued for output.
*/
if (statePtr->outQueueHead != (ChannelBuffer *) NULL) {
panic("TclFlush, closed channel: queued output left");
}
/*
* If the EOF character is set in the channel, append that to the
* output device.
*/
if ((statePtr->outEofChar != 0) && (statePtr->flags & TCL_WRITABLE)) {
int dummy;
char c;
c = (char) statePtr->outEofChar;
(chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy);
}
/*
* Remove this channel from of the list of all channels.
*/
Tcl_CutChannel((Tcl_Channel) chanPtr);
/*
* Close and free the channel driver state.
*/
if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, interp);
} else {
result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp,
0);
}
/*
* Some resources can be cleared only if the bottom channel
* in a stack is closed. All the other channels in the stack
* are not allowed to remove.
*/
if (chanPtr == statePtr->bottomChanPtr) {
if (statePtr->channelName != (char *) NULL) {
ckfree((char *) statePtr->channelName);
statePtr->channelName = NULL;
}
Tcl_FreeEncoding(statePtr->encoding);
if (statePtr->outputStage != NULL) {
ckfree((char *) statePtr->outputStage);
statePtr->outputStage = (char *) NULL;
}
}
/*
* If we are being called synchronously, report either
* any latent error on the channel or the current error.
*/
if (statePtr->unreportedError != 0) {
errorCode = statePtr->unreportedError;
}
if (errorCode == 0) {
errorCode = result;
if (errorCode != 0) {
Tcl_SetErrno(errorCode);
}
}
/*
* Cancel any outstanding timer.
*/
Tcl_DeleteTimerHandler(statePtr->timer);
/*
* Mark the channel as deleted by clearing the type structure.
*/
if (chanPtr->downChanPtr != (Channel *) NULL) {
Channel *downChanPtr = chanPtr->downChanPtr;
statePtr->nextCSPtr = tsdPtr->firstCSPtr;
tsdPtr->firstCSPtr = statePtr;
statePtr->topChanPtr = downChanPtr;
downChanPtr->upChanPtr = (Channel *) NULL;
chanPtr->typePtr = NULL;
Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
return Tcl_Close(interp, (Tcl_Channel) downChanPtr);
}
/*
* There is only the TOP Channel, so we free the remaining
* pointers we have and then ourselves. Since this is the
* last of the channels in the stack, make sure to free the
* ChannelState structure associated with it. We use
* Tcl_EventuallyFree to allow for any last
*/
chanPtr->typePtr = NULL;
Tcl_EventuallyFree((ClientData) statePtr, TCL_DYNAMIC);
Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CutChannel --
*
* Removes a channel from the (thread-)global list of all channels
* (in that thread). This is actually the statePtr for the stack
* of channel.
*
* Results:
* Nothing.
*
* Side effects:
* Resets the field 'nextCSPtr' of the specified channel state to NULL.
*
* NOTE:
* The channel to cut out of the list must not be referenced
* in any interpreter. This is something this procedure cannot
* check (despite the refcount) because the caller usually wants
* fiddle with the channel (like transfering it to a different
* thread) and thus keeps the refcount artifically high to prevent
* its destruction.
*
*----------------------------------------------------------------------
*/
void
Tcl_CutChannel(chan)
Tcl_Channel chan; /* The channel being removed. Must
* not be referenced in any
* interpreter. */
{
ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
ChannelState *prevCSPtr; /* Preceding channel state in list of
* all states - used to splice a
* channel out of the list on close. */
ChannelState *statePtr = ((Channel *) chan)->state;
/* state of the channel stack. */
Tcl_DriverThreadActionProc *threadActionProc;
/*
* Remove this channel from of the list of all channels
* (in the current thread).
*/
if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) {
tsdPtr->firstCSPtr = statePtr->nextCSPtr;
} else {
for (prevCSPtr = tsdPtr->firstCSPtr;
prevCSPtr && (prevCSPtr->nextCSPtr != statePtr);
prevCSPtr = prevCSPtr->nextCSPtr) {
/* Empty loop body. */
}
if (prevCSPtr == (ChannelState *) NULL) {
panic("FlushChannel: damaged channel list");
}
prevCSPtr->nextCSPtr = statePtr->nextCSPtr;
}
statePtr->nextCSPtr = (ChannelState *) NULL;
/* TIP #218, Channel Thread Actions */
threadActionProc = Tcl_ChannelThreadActionProc (Tcl_GetChannelType (chan));
if (threadActionProc != NULL) {
(*threadActionProc) (Tcl_GetChannelInstanceData(chan),
TCL_CHANNEL_THREAD_REMOVE);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SpliceChannel --
*
* Adds a channel to the (thread-)global list of all channels
* (in that thread). Expects that the field 'nextChanPtr' in
* the channel is set to NULL.
*
* Results:
* Nothing.
*
* Side effects:
* Nothing.
*
* NOTE:
* The channel to splice into the list must not be referenced in any
* interpreter. This is something this procedure cannot check
* (despite the refcount) because the caller usually wants figgle
* with the channel (like transfering it to a different thread)
* and thus keeps the refcount artifically high to prevent its
* destruction.
*
*----------------------------------------------------------------------
*/
void
Tcl_SpliceChannel(chan)
Tcl_Channel chan; /* The channel being added. Must
* not be referenced in any
* interpreter. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ChannelState *statePtr = ((Channel *) chan)->state;
Tcl_DriverThreadActionProc *threadActionProc;
if (statePtr->nextCSPtr != (ChannelState *) NULL) {
panic("Tcl_SpliceChannel: trying to add channel used in different list");
}
statePtr->nextCSPtr = tsdPtr->firstCSPtr;
tsdPtr->firstCSPtr = statePtr;
/*
* TIP #10. Mark the current thread as the new one managing this
* channel. Note: 'Tcl_GetCurrentThread' returns sensible
* values even for a non-threaded core.
*/
statePtr->managingThread = Tcl_GetCurrentThread ();
/* TIP #218, Channel Thread Actions */
threadActionProc = Tcl_ChannelThreadActionProc (Tcl_GetChannelType (chan));
if (threadActionProc != NULL) {
(*threadActionProc) (Tcl_GetChannelInstanceData(chan),
TCL_CHANNEL_THREAD_INSERT);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_Close --
*
* Closes a channel.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Closes the channel if this is the last reference.
*
* NOTE:
* Tcl_Close removes the channel as far as the user is concerned.
* However, it may continue to exist for a while longer if it has
* a background flush scheduled. The device itself is eventually
* closed and the channel record removed, in CloseChannel, above.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_Close(interp, chan)
Tcl_Interp *interp; /* Interpreter for errors. */
Tcl_Channel chan; /* The channel being closed. Must
* not be referenced in any
* interpreter. */
{
CloseCallback *cbPtr; /* Iterate over close callbacks
* for this channel. */
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of real IO channel. */
int result; /* Of calling FlushChannel. */
if (chan == (Tcl_Channel) NULL) {
return TCL_OK;
}
/*
* Perform special handling for standard channels being closed. If the
* refCount is now 1 it means that the last reference to the standard
* channel is being explicitly closed, so bump the refCount down
* artificially to 0. This will ensure that the channel is actually
* closed, below. Also set the static pointer to NULL for the channel.
*/
CheckForStdChannelsBeingClosed(chan);
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
if (statePtr->refCount > 0) {
panic("called Tcl_Close on channel with refCount > 0");
}
if (statePtr->flags & CHANNEL_INCLOSE) {
if (interp) {
Tcl_AppendResult(interp,
"Illegal recursive call to close through close-handler of channel",
(char *) NULL);
}
return TCL_ERROR;
}
statePtr->flags |= CHANNEL_INCLOSE;
/*
* When the channel has an escape sequence driven encoding such as
* iso2022, the terminated escape sequence must write to the buffer.
*/
if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)
&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
statePtr->outputEncodingFlags |= TCL_ENCODING_END;
WriteChars(chanPtr, "", 0);
}
Tcl_ClearChannelHandlers(chan);
/*
* Invoke the registered close callbacks and delete their records.
*/
while (statePtr->closeCbPtr != (CloseCallback *) NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
(cbPtr->proc) (cbPtr->clientData);
ckfree((char *) cbPtr);
}
statePtr->flags &= ~CHANNEL_INCLOSE;
/*
* Ensure that the last output buffer will be flushed.
*/
if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
(statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) {
statePtr->flags |= BUFFER_READY;
}
/*
* If this channel supports it, close the read side, since we don't need it
* anymore and this will help avoid deadlocks on some channel types.
*/
if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) {
result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp,
TCL_CLOSE_READ);
} else {
result = 0;
}
/*
* The call to FlushChannel will flush any queued output and invoke
* the close function of the channel driver, or it will set up the
* channel to be flushed and closed asynchronously.
*/
statePtr->flags |= CHANNEL_CLOSED;
if ((FlushChannel(interp, chanPtr, 0) != 0) || (result != 0)) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ClearChannelHandlers --
*
* Removes all channel handlers and event scripts from the channel,
* cancels all background copies involving the channel and any interest
* in events.
*
* Results:
* None.
*
* Side effects:
* See above. Deallocates memory.
*
*----------------------------------------------------------------------
*/
void
Tcl_ClearChannelHandlers (channel)
Tcl_Channel channel;
{
ChannelHandler *chPtr, *chNext; /* Iterate over channel handlers. */
EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of real IO channel. */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
NextChannelHandler *nhPtr;
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = (Channel *) channel;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
/*
* Cancel any outstanding timer.
*/
Tcl_DeleteTimerHandler(statePtr->timer);
/*
* Remove any references to channel handlers for this channel that
* may be about to be invoked.
*/
for (nhPtr = tsdPtr->nestedHandlerPtr;
nhPtr != (NextChannelHandler *) NULL;
nhPtr = nhPtr->nestedHandlerPtr) {
if (nhPtr->nextHandlerPtr &&
(nhPtr->nextHandlerPtr->chanPtr == chanPtr)) {
nhPtr->nextHandlerPtr = NULL;
}
}
/*
* Remove all the channel handler records attached to the channel
* itself.
*/
for (chPtr = statePtr->chPtr;
chPtr != (ChannelHandler *) NULL;
chPtr = chNext) {
chNext = chPtr->nextPtr;
ckfree((char *) chPtr);
}
statePtr->chPtr = (ChannelHandler *) NULL;
/*
* Cancel any pending copy operation.
*/
StopCopy(statePtr->csPtrR);
StopCopy(statePtr->csPtrW);
/*
* Must set the interest mask now to 0, otherwise infinite loops
* will occur if Tcl_DoOneEvent is called before the channel is
* finally deleted in FlushChannel. This can happen if the channel
* has a background flush active.
*/
statePtr->interestMask = 0;
/*
* Remove any EventScript records for this channel.
*/
for (ePtr = statePtr->scriptRecordPtr;
ePtr != (EventScriptRecord *) NULL;
ePtr = eNextPtr) {
eNextPtr = ePtr->nextPtr;
Tcl_DecrRefCount(ePtr->scriptPtr);
ckfree((char *) ePtr);
}
statePtr->scriptRecordPtr = (EventScriptRecord *) NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Write --
*
* Puts a sequence of bytes into an output buffer, may queue the
* buffer for output if it gets full, and also remembers whether the
* current buffer is ready e.g. if it contains a newline and we are in
* line buffering mode. Compensates stacking, i.e. will redirect the
* data from the specified channel to the topmost channel in a stack.
*
* No encoding conversions are applied to the bytes being read.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
* Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_Write(chan, src, srcLen)
Tcl_Channel chan; /* The channel to buffer output for. */
CONST char *src; /* Data to queue in output buffer. */
int srcLen; /* Length of data in bytes, or < 0 for
* strlen(). */
{
/*
* Always use the topmost channel of the stack
*/
Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
statePtr = ((Channel *) chan)->state;
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return -1;
}
if (srcLen < 0) {
srcLen = strlen(src);
}
return DoWrite(chanPtr, src, srcLen);
}
/*
*----------------------------------------------------------------------
*
* Tcl_WriteRaw --
*
* Puts a sequence of bytes into an output buffer, may queue the
* buffer for output if it gets full, and also remembers whether the
* current buffer is ready e.g. if it contains a newline and we are in
* line buffering mode. Writes directly to the driver of the channel,
* does not compensate for stacking.
*
* No encoding conversions are applied to the bytes being read.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
* Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_WriteRaw(chan, src, srcLen)
Tcl_Channel chan; /* The channel to buffer output for. */
CONST char *src; /* Data to queue in output buffer. */
int srcLen; /* Length of data in bytes, or < 0 for
* strlen(). */
{
Channel *chanPtr = ((Channel *) chan);
ChannelState *statePtr = chanPtr->state; /* state info for channel */
int errorCode, written;
if (CheckChannelErrors(statePtr, TCL_WRITABLE | CHANNEL_RAW_MODE) != 0) {
return -1;
}
if (srcLen < 0) {
srcLen = strlen(src);
}
/*
* Go immediately to the driver, do all the error handling by ourselves.
* The code was stolen from 'FlushChannel'.
*/
written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData,
src, srcLen, &errorCode);
if (written < 0) {
Tcl_SetErrno(errorCode);
}
return written;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_WriteChars --
*
* Takes a sequence of UTF-8 characters and converts them for output
* using the channel's current encoding, may queue the buffer for
* output if it gets full, and also remembers whether the current
* buffer is ready e.g. if it contains a newline and we are in
* line buffering mode. Compensates stacking, i.e. will redirect the
* data from the specified channel to the topmost channel in a stack.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
* Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_WriteChars(chan, src, len)
Tcl_Channel chan; /* The channel to buffer output for. */
CONST char *src; /* UTF-8 characters to queue in output buffer. */
int len; /* Length of string in bytes, or < 0 for
* strlen(). */
{
ChannelState *statePtr; /* state info for channel */
statePtr = ((Channel *) chan)->state;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return -1;
}
return DoWriteChars ((Channel*) chan, src, len);
}
/*
*---------------------------------------------------------------------------
*
* DoWriteChars --
*
* Takes a sequence of UTF-8 characters and converts them for output
* using the channel's current encoding, may queue the buffer for
* output if it gets full, and also remembers whether the current
* buffer is ready e.g. if it contains a newline and we are in
* line buffering mode. Compensates stacking, i.e. will redirect the
* data from the specified channel to the topmost channel in a stack.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
* Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
static int
DoWriteChars(chanPtr, src, len)
Channel* chanPtr; /* The channel to buffer output for. */
CONST char *src; /* UTF-8 characters to queue in output buffer. */
int len; /* Length of string in bytes, or < 0 for
* strlen(). */
{
/*
* Always use the topmost channel of the stack
*/
ChannelState *statePtr; /* state info for channel */
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
if (len < 0) {
len = strlen(src);
}
if (statePtr->encoding == NULL) {
/*
* Inefficient way to convert UTF-8 to byte-array, but the
* code parallels the way it is done for objects.
*/
Tcl_Obj *objPtr;
int result;
objPtr = Tcl_NewStringObj(src, len);
src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len);
result = WriteBytes(chanPtr, src, len);
Tcl_DecrRefCount(objPtr);
return result;
}
return WriteChars(chanPtr, src, len);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_WriteObj --
*
* Takes the Tcl object and queues its contents for output. If the
* encoding of the channel is NULL, takes the byte-array representation
* of the object and queues those bytes for output. Otherwise, takes
* the characters in the UTF-8 (string) representation of the object
* and converts them for output using the channel's current encoding.
* May flush internal buffers to output if one becomes full or is ready
* for some other reason, e.g. if it contains a newline and the channel
* is in line buffering mode.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
* Tcl_GetErrno() will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_WriteObj(chan, objPtr)
Tcl_Channel chan; /* The channel to buffer output for. */
Tcl_Obj *objPtr; /* The object to write. */
{
/*
* Always use the topmost channel of the stack
*/
Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
char *src;
int srcLen;
statePtr = ((Channel *) chan)->state;
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return -1;
}
if (statePtr->encoding == NULL) {
src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen);
return WriteBytes(chanPtr, src, srcLen);
} else {
src = Tcl_GetStringFromObj(objPtr, &srcLen);
return WriteChars(chanPtr, src, srcLen);
}
}
/*
*----------------------------------------------------------------------
*
* WriteBytes --
*
* Write a sequence of bytes into an output buffer, may queue the
* buffer for output if it gets full, and also remembers whether the
* current buffer is ready e.g. if it contains a newline and we are in
* line buffering mode.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
* Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
static int
WriteBytes(chanPtr, src, srcLen)
Channel *chanPtr; /* The channel to buffer output for. */
CONST char *src; /* Bytes to write. */
int srcLen; /* Number of bytes to write. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
char *dst;
int dstMax, sawLF, savedLF, total, dstLen, toWrite;
total = 0;
sawLF = 0;
savedLF = 0;
/*
* Loop over all bytes in src, storing them in output buffer with
* proper EOL translation.
*/
while (srcLen + savedLF > 0) {
bufPtr = statePtr->curOutPtr;
if (bufPtr == NULL) {
bufPtr = AllocChannelBuffer(statePtr->bufSize);
statePtr->curOutPtr = bufPtr;
}
dst = bufPtr->buf + bufPtr->nextAdded;
dstMax = bufPtr->bufLength - bufPtr->nextAdded;
dstLen = dstMax;
toWrite = dstLen;
if (toWrite > srcLen) {
toWrite = srcLen;
}
if (savedLF) {
/*
* A '\n' was left over from last call to TranslateOutputEOL()
* and we need to store it in this buffer. If the channel is
* line-based, we will need to flush it.
*/
*dst++ = '\n';
dstLen--;
sawLF++;
}
sawLF += TranslateOutputEOL(statePtr, dst, src, &dstLen, &toWrite);
dstLen += savedLF;
savedLF = 0;
if (dstLen > dstMax) {
savedLF = 1;
dstLen = dstMax;
}
bufPtr->nextAdded += dstLen;
if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) {
return -1;
}
total += dstLen;
src += toWrite;
srcLen -= toWrite;
sawLF = 0;
}
return total;
}
/*
*----------------------------------------------------------------------
*
* WriteChars --
*
* Convert UTF-8 bytes to the channel's external encoding and
* write the produced bytes into an output buffer, may queue the
* buffer for output if it gets full, and also remembers whether the
* current buffer is ready e.g. if it contains a newline and we are in
* line buffering mode.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
* Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
static int
WriteChars(chanPtr, src, srcLen)
Channel *chanPtr; /* The channel to buffer output for. */
CONST char *src; /* UTF-8 string to write. */
int srcLen; /* Length of UTF-8 string in bytes. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
char *dst, *stage;
int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote;
int stageLen, toWrite, stageRead, endEncoding, result;
int consumedSomething;
Tcl_Encoding encoding;
char safe[BUFFER_PADDING];
total = 0;
sawLF = 0;
savedLF = 0;
saved = 0;
encoding = statePtr->encoding;
/*
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
/*
* Loop over all UTF-8 characters in src, storing them in staging buffer
* with proper EOL translation.
*/
consumedSomething = 1;
while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) {
consumedSomething = 0;
stage = statePtr->outputStage;
stageMax = statePtr->bufSize;
stageLen = stageMax;
toWrite = stageLen;
if (toWrite > srcLen) {
toWrite = srcLen;
}
if (savedLF) {
/*
* A '\n' was left over from last call to TranslateOutputEOL()
* and we need to store it in the staging buffer. If the
* channel is line-based, we will need to flush the output
* buffer (after translating the staging buffer).
*/
*stage++ = '\n';
stageLen--;
sawLF++;
}
sawLF += TranslateOutputEOL(statePtr, stage, src, &stageLen, &toWrite);
stage -= savedLF;
stageLen += savedLF;
savedLF = 0;
if (stageLen > stageMax) {
savedLF = 1;
stageLen = stageMax;
}
src += toWrite;
srcLen -= toWrite;
/*
* Loop over all UTF-8 characters in staging buffer, converting them
* to external encoding, storing them in output buffer.
*/
while (stageLen + saved + endEncoding > 0) {
bufPtr = statePtr->curOutPtr;
if (bufPtr == NULL) {
bufPtr = AllocChannelBuffer(statePtr->bufSize);
statePtr->curOutPtr = bufPtr;
}
dst = bufPtr->buf + bufPtr->nextAdded;
dstLen = bufPtr->bufLength - bufPtr->nextAdded;
if (saved != 0) {
/*
* Here's some translated bytes left over from the last
* buffer that we need to stick at the beginning of this
* buffer.
*/
memcpy((VOID *) dst, (VOID *) safe, (size_t) saved);
bufPtr->nextAdded += saved;
dst += saved;
dstLen -= saved;
saved = 0;
}
result = Tcl_UtfToExternal(NULL, encoding, stage, stageLen,
statePtr->outputEncodingFlags,
&statePtr->outputEncodingState, dst,
dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL);
/* Fix for SF #506297, reported by Martin Forssen
* .
*
* The encoding chosen in the script exposing the bug writes out
* three intro characters when TCL_ENCODING_START is set, but does
* not consume any input as TCL_ENCODING_END is cleared. As some
* output was generated the enclosing loop calls UtfToExternal
* again, again with START set. Three more characters in the out
* and still no use of input ... To break this infinite loop we
* remove TCL_ENCODING_START from the set of flags after the first
* call (no condition is required, the later calls remove an unset
* flag, which is a no-op). This causes the subsequent calls to
* UtfToExternal to consume and convert the actual input.
*/
statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
/*
* The following code must be executed only when result is not 0.
*/
if (result && ((stageRead + dstWrote) == 0)) {
/*
* We have an incomplete UTF-8 character at the end of the
* staging buffer. It will get moved to the beginning of the
* staging buffer followed by more bytes from src.
*/
src -= stageLen;
srcLen += stageLen;
stageLen = 0;
savedLF = 0;
break;
}
bufPtr->nextAdded += dstWrote;
if (bufPtr->nextAdded > bufPtr->bufLength) {
/*
* When translating from UTF-8 to external encoding, we
* allowed the translation to produce a character that
* crossed the end of the output buffer, so that we would
* get a completely full buffer before flushing it. The
* extra bytes will be moved to the beginning of the next
* buffer.
*/
saved = bufPtr->nextAdded - bufPtr->bufLength;
memcpy((VOID *) safe, (VOID *) (dst + dstLen), (size_t) saved);
bufPtr->nextAdded = bufPtr->bufLength;
}
if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) {
return -1;
}
total += dstWrote;
stage += stageRead;
stageLen -= stageRead;
sawLF = 0;
consumedSomething = 1;
/*
* If all translated characters are written to the buffer,
* endEncoding is set to 0 because the escape sequence may be
* output.
*/
if ((stageLen + saved == 0) && (result == 0)) {
endEncoding = 0;
}
}
}
/* If nothing was written and it happened because there was no progress
* in the UTF conversion, we throw an error.
*/
if (!consumedSomething && (total == 0)) {
Tcl_SetErrno (EINVAL);
return -1;
}
return total;
}
/*
*---------------------------------------------------------------------------
*
* TranslateOutputEOL --
*
* Helper function for WriteBytes() and WriteChars(). Converts the
* '\n' characters in the source buffer into the appropriate EOL
* form specified by the output translation mode.
*
* EOL translation stops either when the source buffer is empty
* or the output buffer is full.
*
* When converting to CRLF mode and there is only 1 byte left in
* the output buffer, this routine stores the '\r' in the last
* byte and then stores the '\n' in the byte just past the end of the
* buffer. The caller is responsible for passing in a buffer that
* is large enough to hold the extra byte.
*
* Results:
* The return value is 1 if a '\n' was translated from the source
* buffer, or 0 otherwise -- this can be used by the caller to
* decide to flush a line-based channel even though the channel
* buffer is not full.
*
* *dstLenPtr is filled with how many bytes of the output buffer
* were used. As mentioned above, this can be one more that
* the output buffer's specified length if a CRLF was stored.
*
* *srcLenPtr is filled with how many bytes of the source buffer
* were consumed.
*
* Side effects:
* It may be obvious, but bears mentioning that when converting
* in CRLF mode (which requires two bytes of storage in the output
* buffer), the number of bytes consumed from the source buffer
* will be less than the number of bytes stored in the output buffer.
*
*---------------------------------------------------------------------------
*/
static int
TranslateOutputEOL(statePtr, dst, src, dstLenPtr, srcLenPtr)
ChannelState *statePtr; /* Channel being read, for translation and
* buffering modes. */
char *dst; /* Output buffer filled with UTF-8 chars by
* applying appropriate EOL translation to
* source characters. */
CONST char *src; /* Source UTF-8 characters. */
int *dstLenPtr; /* On entry, the maximum length of output
* buffer in bytes. On exit, the number of
* bytes actually used in output buffer. */
int *srcLenPtr; /* On entry, the length of source buffer.
* On exit, the number of bytes read from
* the source buffer. */
{
char *dstEnd;
int srcLen, newlineFound;
newlineFound = 0;
srcLen = *srcLenPtr;
switch (statePtr->outputTranslation) {
case TCL_TRANSLATE_LF: {
for (dstEnd = dst + srcLen; dst < dstEnd; ) {
if (*src == '\n') {
newlineFound = 1;
}
*dst++ = *src++;
}
*dstLenPtr = srcLen;
break;
}
case TCL_TRANSLATE_CR: {
for (dstEnd = dst + srcLen; dst < dstEnd;) {
if (*src == '\n') {
*dst++ = '\r';
newlineFound = 1;
src++;
} else {
*dst++ = *src++;
}
}
*dstLenPtr = srcLen;
break;
}
case TCL_TRANSLATE_CRLF: {
/*
* Since this causes the number of bytes to grow, we
* start off trying to put 'srcLen' bytes into the
* output buffer, but allow it to store more bytes, as
* long as there's still source bytes and room in the
* output buffer.
*/
char *dstStart, *dstMax;
CONST char *srcStart;
dstStart = dst;
dstMax = dst + *dstLenPtr;
srcStart = src;
if (srcLen < *dstLenPtr) {
dstEnd = dst + srcLen;
} else {
dstEnd = dst + *dstLenPtr;
}
while (dst < dstEnd) {
if (*src == '\n') {
if (dstEnd < dstMax) {
dstEnd++;
}
*dst++ = '\r';
newlineFound = 1;
}
*dst++ = *src++;
}
*srcLenPtr = src - srcStart;
*dstLenPtr = dst - dstStart;
break;
}
default: {
break;
}
}
return newlineFound;
}
/*
*---------------------------------------------------------------------------
*
* CheckFlush --
*
* Helper function for WriteBytes() and WriteChars(). If the
* channel buffer is ready to be flushed, flush it.
*
* Results:
* The return value is -1 if there was a problem flushing the
* channel buffer, or 0 otherwise.
*
* Side effects:
* The buffer will be recycled if it is flushed.
*
*---------------------------------------------------------------------------
*/
static int
CheckFlush(chanPtr, bufPtr, newlineFlag)
Channel *chanPtr; /* Channel being read, for buffering mode. */
ChannelBuffer *bufPtr; /* Channel buffer to possibly flush. */
int newlineFlag; /* Non-zero if a the channel buffer
* contains a newline. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
/*
* The current buffer is ready for output:
* 1. if it is full.
* 2. if it contains a newline and this channel is line-buffered.
* 3. if it contains any output and this channel is unbuffered.
*/
if ((statePtr->flags & BUFFER_READY) == 0) {
if (bufPtr->nextAdded == bufPtr->bufLength) {
statePtr->flags |= BUFFER_READY;
} else if (statePtr->flags & CHANNEL_LINEBUFFERED) {
if (newlineFlag != 0) {
statePtr->flags |= BUFFER_READY;
}
} else if (statePtr->flags & CHANNEL_UNBUFFERED) {
statePtr->flags |= BUFFER_READY;
}
}
if (statePtr->flags & BUFFER_READY) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
}
return 0;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_Gets --
*
* Reads a complete line of input from the channel into a Tcl_DString.
*
* Results:
* Length of line read (in characters) or -1 if error, EOF, or blocked.
* If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the
* error or condition that occurred.
*
* Side effects:
* May flush output on the channel. May cause input to be consumed
* from the channel.
*
*---------------------------------------------------------------------------
*/
int
Tcl_Gets(chan, lineRead)
Tcl_Channel chan; /* Channel from which to read. */
Tcl_DString *lineRead; /* The line read will be appended to this
* DString as UTF-8 characters. The caller
* must have initialized it and is responsible
* for managing the storage. */
{
Tcl_Obj *objPtr;
int charsStored, length;
char *string;
objPtr = Tcl_NewObj();
charsStored = Tcl_GetsObj(chan, objPtr);
if (charsStored > 0) {
string = Tcl_GetStringFromObj(objPtr, &length);
Tcl_DStringAppend(lineRead, string, length);
}
Tcl_DecrRefCount(objPtr);
return charsStored;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_GetsObj --
*
* Accumulate input from the input channel until end-of-line or
* end-of-file has been seen. Bytes read from the input channel
* are converted to UTF-8 using the encoding specified by the
* channel.
*
* Results:
* Number of characters accumulated in the object or -1 if error,
* blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the
* POSIX error code for the error or condition that occurred.
*
* Side effects:
* Consumes input from the channel.
*
* On reading EOF, leave channel pointing at EOF char.
* On reading EOL, leave channel pointing after EOL, but don't
* return EOL in dst buffer.
*
*---------------------------------------------------------------------------
*/
int
Tcl_GetsObj(chan, objPtr)
Tcl_Channel chan; /* Channel from which to read. */
Tcl_Obj *objPtr; /* The line read will be appended to this
* object as UTF-8 characters. */
{
GetsState gs;
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved;
Tcl_Encoding encoding;
char *dst, *dstEnd, *eol, *eof;
Tcl_EncodingState oldState;
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
copiedTotal = -1;
goto done;
}
bufPtr = statePtr->inQueueHead;
encoding = statePtr->encoding;
/*
* Preserved so we can restore the channel's state in case we don't
* find a newline in the available input.
*/
Tcl_GetStringFromObj(objPtr, &oldLength);
oldFlags = statePtr->inputEncodingFlags;
oldState = statePtr->inputEncodingState;
oldRemoved = BUFFER_PADDING;
if (bufPtr != NULL) {
oldRemoved = bufPtr->nextRemoved;
}
/*
* If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't
* produce ByteArray objects. To avoid circularity problems,
* "iso8859-1" is builtin to Tcl.
*/
if (encoding == NULL) {
encoding = Tcl_GetEncoding(NULL, "iso8859-1");
}
/*
* Object used by FilterInputBytes to keep track of how much data has
* been consumed from the channel buffers.
*/
gs.objPtr = objPtr;
gs.dstPtr = &dst;
gs.encoding = encoding;
gs.bufPtr = bufPtr;
gs.state = oldState;
gs.rawRead = 0;
gs.bytesWrote = 0;
gs.charsWrote = 0;
gs.totalChars = 0;
dst = objPtr->bytes + oldLength;
dstEnd = dst;
skip = 0;
eof = NULL;
inEofChar = statePtr->inEofChar;
while (1) {
if (dst >= dstEnd) {
if (FilterInputBytes(chanPtr, &gs) != 0) {
goto restore;
}
dstEnd = dst + gs.bytesWrote;
}
/*
* Remember if EOF char is seen, then look for EOL anyhow, because
* the EOL might be before the EOF char.
*/
if (inEofChar != '\0') {
for (eol = dst; eol < dstEnd; eol++) {
if (*eol == inEofChar) {
dstEnd = eol;
eof = eol;
break;
}
}
}
/*
* On EOL, leave current file position pointing after the EOL, but
* don't store the EOL in the output string.
*/
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF: {
for (eol = dst; eol < dstEnd; eol++) {
if (*eol == '\n') {
skip = 1;
goto goteol;
}
}
break;
}
case TCL_TRANSLATE_CR: {
for (eol = dst; eol < dstEnd; eol++) {
if (*eol == '\r') {
skip = 1;
goto goteol;
}
}
break;
}
case TCL_TRANSLATE_CRLF: {
for (eol = dst; eol < dstEnd; eol++) {
if (*eol == '\r') {
eol++;
if (eol >= dstEnd) {
int offset;
offset = eol - objPtr->bytes;
dst = dstEnd;
if (FilterInputBytes(chanPtr, &gs) != 0) {
goto restore;
}
dstEnd = dst + gs.bytesWrote;
eol = objPtr->bytes + offset;
if (eol >= dstEnd) {
skip = 0;
goto goteol;
}
}
if (*eol == '\n') {
eol--;
skip = 2;
goto goteol;
}
}
}
break;
}
case TCL_TRANSLATE_AUTO: {
eol = dst;
skip = 1;
if (statePtr->flags & INPUT_SAW_CR) {
statePtr->flags &= ~INPUT_SAW_CR;
if (*eol == '\n') {
/*
* Skip the raw bytes that make up the '\n'.
*/
char tmp[1 + TCL_UTF_MAX];
int rawRead;
bufPtr = gs.bufPtr;
Tcl_ExternalToUtf(NULL, gs.encoding,
bufPtr->buf + bufPtr->nextRemoved,
gs.rawRead, statePtr->inputEncodingFlags,
&gs.state, tmp, 1 + TCL_UTF_MAX, &rawRead,
NULL, NULL);
bufPtr->nextRemoved += rawRead;
gs.rawRead -= rawRead;
gs.bytesWrote--;
gs.charsWrote--;
memmove(dst, dst + 1, (size_t) (dstEnd - dst));
dstEnd--;
}
}
for (eol = dst; eol < dstEnd; eol++) {
if (*eol == '\r') {
eol++;
if (eol == dstEnd) {
/*
* If buffer ended on \r, peek ahead to see if a
* \n is available.
*/
int offset;
offset = eol - objPtr->bytes;
dst = dstEnd;
PeekAhead(chanPtr, &dstEnd, &gs);
eol = objPtr->bytes + offset;
if (eol >= dstEnd) {
eol--;
statePtr->flags |= INPUT_SAW_CR;
goto goteol;
}
}
if (*eol == '\n') {
skip++;
}
eol--;
goto goteol;
} else if (*eol == '\n') {
goto goteol;
}
}
}
}
if (eof != NULL) {
/*
* EOF character was seen. On EOF, leave current file position
* pointing at the EOF character, but don't store the EOF
* character in the output string.
*/
dstEnd = eof;
statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
}
if (statePtr->flags & CHANNEL_EOF) {
skip = 0;
eol = dstEnd;
if (eol == objPtr->bytes + oldLength) {
/*
* If we didn't append any bytes before encountering EOF,
* caller needs to see -1.
*/
Tcl_SetObjLength(objPtr, oldLength);
CommonGetsCleanup(chanPtr, encoding);
copiedTotal = -1;
goto done;
}
goto goteol;
}
dst = dstEnd;
}
/*
* Found EOL or EOF, but the output buffer may now contain too many
* UTF-8 characters. We need to know how many raw bytes correspond to
* the number of UTF-8 characters we want, plus how many raw bytes
* correspond to the character(s) making up EOL (if any), so we can
* remove the correct number of bytes from the channel buffer.
*/
goteol:
bufPtr = gs.bufPtr;
statePtr->inputEncodingState = gs.state;
Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved,
gs.rawRead, statePtr->inputEncodingFlags,
&statePtr->inputEncodingState, dst,
eol - dst + skip + TCL_UTF_MAX, &gs.rawRead, NULL,
&gs.charsWrote);
bufPtr->nextRemoved += gs.rawRead;
/*
* Recycle all the emptied buffers.
*/
Tcl_SetObjLength(objPtr, eol - objPtr->bytes);
CommonGetsCleanup(chanPtr, encoding);
statePtr->flags &= ~CHANNEL_BLOCKED;
copiedTotal = gs.totalChars + gs.charsWrote - skip;
goto done;
/*
* Couldn't get a complete line. This only happens if we get a error
* reading from the channel or we are non-blocking and there wasn't
* an EOL or EOF in the data available.
*/
restore:
bufPtr = statePtr->inQueueHead;
bufPtr->nextRemoved = oldRemoved;
for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
bufPtr->nextRemoved = BUFFER_PADDING;
}
CommonGetsCleanup(chanPtr, encoding);
statePtr->inputEncodingState = oldState;
statePtr->inputEncodingFlags = oldFlags;
Tcl_SetObjLength(objPtr, oldLength);
/*
* We didn't get a complete line so we need to indicate to UpdateInterest
* that the gets blocked. It will wait for more data instead of firing
* a timer, avoiding a busy wait. This is where we are assuming that the
* next operation is a gets. No more file events will be delivered on
* this channel until new data arrives or some operation is performed
* on the channel (e.g. gets, read, fconfigure) that changes the blocking
* state. Note that this means a file event will not be delivered even
* though a read would be able to consume the buffered data.
*/
statePtr->flags |= CHANNEL_NEED_MORE_DATA;
copiedTotal = -1;
done:
/*
* Update the notifier state so we don't block while there is still
* data in the buffers.
*/
UpdateInterest(chanPtr);
return copiedTotal;
}
/*
*---------------------------------------------------------------------------
*
* FilterInputBytes --
*
* Helper function for Tcl_GetsObj. Produces UTF-8 characters from
* raw bytes read from the channel.
*
* Consumes available bytes from channel buffers. When channel
* buffers are exhausted, reads more bytes from channel device into
* a new channel buffer. It is the caller's responsibility to
* free the channel buffers that have been exhausted.
*
* Results:
* The return value is -1 if there was an error reading from the
* channel, 0 otherwise.
*
* Side effects:
* Status object keeps track of how much data from channel buffers
* has been consumed and where UTF-8 bytes should be stored.
*
*---------------------------------------------------------------------------
*/
static int
FilterInputBytes(chanPtr, gsPtr)
Channel *chanPtr; /* Channel to read. */
GetsState *gsPtr; /* Current state of gets operation. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
char *raw, *rawStart, *rawEnd;
char *dst;
int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length;
Tcl_Obj *objPtr;
#define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert
* at a time. Since we don't know a priori
* how many bytes of storage this many source
* bytes will use, we actually need at least
* ENCODING_LINESIZE * TCL_MAX_UTF bytes of
* room. */
objPtr = gsPtr->objPtr;
/*
* Subtract the number of bytes that were removed from channel buffer
* during last call.
*/
bufPtr = gsPtr->bufPtr;
if (bufPtr != NULL) {
bufPtr->nextRemoved += gsPtr->rawRead;
if (bufPtr->nextRemoved >= bufPtr->nextAdded) {
bufPtr = bufPtr->nextPtr;
}
}
gsPtr->totalChars += gsPtr->charsWrote;
if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) {
/*
* All channel buffers were exhausted and the caller still hasn't
* seen EOL. Need to read more bytes from the channel device.
* Side effect is to allocate another channel buffer.
*/
read:
if (statePtr->flags & CHANNEL_BLOCKED) {
if (statePtr->flags & CHANNEL_NONBLOCKING) {
gsPtr->charsWrote = 0;
gsPtr->rawRead = 0;
return -1;
}
statePtr->flags &= ~CHANNEL_BLOCKED;
}
if (GetInput(chanPtr) != 0) {
gsPtr->charsWrote = 0;
gsPtr->rawRead = 0;
return -1;
}
bufPtr = statePtr->inQueueTail;
gsPtr->bufPtr = bufPtr;
}
/*
* Convert some of the bytes from the channel buffer to UTF-8. Space in
* objPtr's string rep is used to hold the UTF-8 characters. Grow the
* string rep if we need more space.
*/
rawStart = bufPtr->buf + bufPtr->nextRemoved;
raw = rawStart;
rawEnd = bufPtr->buf + bufPtr->nextAdded;
rawLen = rawEnd - rawStart;
dst = *gsPtr->dstPtr;
offset = dst - objPtr->bytes;
toRead = ENCODING_LINESIZE;
if (toRead > rawLen) {
toRead = rawLen;
}
dstNeeded = toRead * TCL_UTF_MAX + 1;
spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1;
if (dstNeeded > spaceLeft) {
length = offset * 2;
if (offset < dstNeeded) {
length = offset + dstNeeded;
}
length += TCL_UTF_MAX + 1;
Tcl_SetObjLength(objPtr, length);
spaceLeft = length - offset;
dst = objPtr->bytes + offset;
*gsPtr->dstPtr = dst;
}
gsPtr->state = statePtr->inputEncodingState;
result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen,
statePtr->inputEncodingFlags, &statePtr->inputEncodingState,
dst, spaceLeft, &gsPtr->rawRead, &gsPtr->bytesWrote,
&gsPtr->charsWrote);
/*
* Make sure that if we go through 'gets', that we reset the
* TCL_ENCODING_START flag still. [Bug #523988]
*/
statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;
if (result == TCL_CONVERT_MULTIBYTE) {
/*
* The last few bytes in this channel buffer were the start of a
* multibyte sequence. If this buffer was full, then move them to
* the next buffer so the bytes will be contiguous.
*/
ChannelBuffer *nextPtr;
int extra;
nextPtr = bufPtr->nextPtr;
if (bufPtr->nextAdded < bufPtr->bufLength) {
if (gsPtr->rawRead > 0) {
/*
* Some raw bytes were converted to UTF-8. Fall through,
* returning those UTF-8 characters because a EOL might be
* present in them.
*/
} else if (statePtr->flags & CHANNEL_EOF) {
/*
* There was a partial character followed by EOF on the
* device. Fall through, returning that nothing was found.
*/
bufPtr->nextRemoved = bufPtr->nextAdded;
} else {
/*
* There are no more cached raw bytes left. See if we can
* get some more.
*/
goto read;
}
} else {
if (nextPtr == NULL) {
nextPtr = AllocChannelBuffer(statePtr->bufSize);
bufPtr->nextPtr = nextPtr;
statePtr->inQueueTail = nextPtr;
}
extra = rawLen - gsPtr->rawRead;
memcpy((VOID *) (nextPtr->buf + BUFFER_PADDING - extra),
(VOID *) (raw + gsPtr->rawRead), (size_t) extra);
nextPtr->nextRemoved -= extra;
bufPtr->nextAdded -= extra;
}
}
gsPtr->bufPtr = bufPtr;
return 0;
}
/*
*---------------------------------------------------------------------------
*
* PeekAhead --
*
* Helper function used by Tcl_GetsObj(). Called when we've seen a
* \r at the end of the UTF-8 string and want to look ahead one
* character to see if it is a \n.
*
* Results:
* *gsPtr->dstPtr is filled with a pointer to the start of the range of
* UTF-8 characters that were found by peeking and *dstEndPtr is filled
* with a pointer to the bytes just after the end of the range.
*
* Side effects:
* If no more raw bytes were available in one of the channel buffers,
* tries to perform a non-blocking read to get more bytes from the
* channel device.
*
*---------------------------------------------------------------------------
*/
static void
PeekAhead(chanPtr, dstEndPtr, gsPtr)
Channel *chanPtr; /* The channel to read. */
char **dstEndPtr; /* Filled with pointer to end of new range
* of UTF-8 characters. */
GetsState *gsPtr; /* Current state of gets operation. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
Tcl_DriverBlockModeProc *blockModeProc;
int bytesLeft;
bufPtr = gsPtr->bufPtr;
/*
* If there's any more raw input that's still buffered, we'll peek into
* that. Otherwise, only get more data from the channel driver if it
* looks like there might actually be more data. The assumption is that
* if the channel buffer is filled right up to the end, then there
* might be more data to read.
*/
blockModeProc = NULL;
if (bufPtr->nextPtr == NULL) {
bytesLeft = bufPtr->nextAdded - (bufPtr->nextRemoved + gsPtr->rawRead);
if (bytesLeft == 0) {
if (bufPtr->nextAdded < bufPtr->bufLength) {
/*
* Don't peek ahead if last read was short read.
*/
goto cleanup;
}
if ((statePtr->flags & CHANNEL_NONBLOCKING) == 0) {
blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr);
if (blockModeProc == NULL) {
/*
* Don't peek ahead if cannot set non-blocking mode.
*/
goto cleanup;
}
StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING);
}
}
}
if (FilterInputBytes(chanPtr, gsPtr) == 0) {
*dstEndPtr = *gsPtr->dstPtr + gsPtr->bytesWrote;
}
if (blockModeProc != NULL) {
StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
}
return;
cleanup:
bufPtr->nextRemoved += gsPtr->rawRead;
gsPtr->rawRead = 0;
gsPtr->totalChars += gsPtr->charsWrote;
gsPtr->bytesWrote = 0;
gsPtr->charsWrote = 0;
}
/*
*---------------------------------------------------------------------------
*
* CommonGetsCleanup --
*
* Helper function for Tcl_GetsObj() to restore the channel after
* a "gets" operation.
*
* Results:
* None.
*
* Side effects:
* Encoding may be freed.
*
*---------------------------------------------------------------------------
*/
static void
CommonGetsCleanup(chanPtr, encoding)
Channel *chanPtr;
Tcl_Encoding encoding;
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr, *nextPtr;
bufPtr = statePtr->inQueueHead;
for ( ; bufPtr != NULL; bufPtr = nextPtr) {
nextPtr = bufPtr->nextPtr;
if (bufPtr->nextRemoved < bufPtr->nextAdded) {
break;
}
RecycleBuffer(statePtr, bufPtr, 0);
}
statePtr->inQueueHead = bufPtr;
if (bufPtr == NULL) {
statePtr->inQueueTail = NULL;
} else {
/*
* If any multi-byte characters were split across channel buffer
* boundaries, the split-up bytes were moved to the next channel
* buffer by FilterInputBytes(). Move the bytes back to their
* original buffer because the caller could change the channel's
* encoding which could change the interpretation of whether those
* bytes really made up multi-byte characters after all.
*/
nextPtr = bufPtr->nextPtr;
for ( ; nextPtr != NULL; nextPtr = bufPtr->nextPtr) {
int extra;
extra = bufPtr->bufLength - bufPtr->nextAdded;
if (extra > 0) {
memcpy((VOID *) (bufPtr->buf + bufPtr->nextAdded),
(VOID *) (nextPtr->buf + BUFFER_PADDING - extra),
(size_t) extra);
bufPtr->nextAdded += extra;
nextPtr->nextRemoved = BUFFER_PADDING;
}
bufPtr = nextPtr;
}
}
if (statePtr->encoding == NULL) {
Tcl_FreeEncoding(encoding);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_Read --
*
* Reads a given number of bytes from a channel. EOL and EOF
* translation is done on the bytes being read, so the the number
* of bytes consumed from the channel may not be equal to the
* number of bytes stored in the destination buffer.
*
* No encoding conversions are applied to the bytes being read.
*
* Results:
* The number of bytes read, or -1 on error. Use Tcl_GetErrno()
* to retrieve the error code for the error that occurred.
*
* Side effects:
* May cause input to be buffered.
*
*----------------------------------------------------------------------
*/
int
Tcl_Read(chan, dst, bytesToRead)
Tcl_Channel chan; /* The channel from which to read. */
char *dst; /* Where to store input read. */
int bytesToRead; /* Maximum number of bytes to read. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state; /* state info for channel */
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
return -1;
}
return DoRead(chanPtr, dst, bytesToRead);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ReadRaw --
*
* Reads a given number of bytes from a channel. EOL and EOF
* translation is done on the bytes being read, so the the number
* of bytes consumed from the channel may not be equal to the
* number of bytes stored in the destination buffer.
*
* No encoding conversions are applied to the bytes being read.
*
* Results:
* The number of bytes read, or -1 on error. Use Tcl_GetErrno()
* to retrieve the error code for the error that occurred.
*
* Side effects:
* May cause input to be buffered.
*
*----------------------------------------------------------------------
*/
int
Tcl_ReadRaw(chan, bufPtr, bytesToRead)
Tcl_Channel chan; /* The channel from which to read. */
char *bufPtr; /* Where to store input read. */
int bytesToRead; /* Maximum number of bytes to read. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state; /* state info for channel */
int nread, result;
int copied, copiedNow;
/*
* The check below does too much because it will reject a call to this
* function with a channel which is part of an 'fcopy'. But we have to
* allow this here or else the chaining in the transformation drivers
* will fail with 'file busy' error instead of retrieving and
* transforming the data to copy.
*
* We let the check procedure now believe that there is no fcopy in
* progress. A better solution than this might be an additional flag
* argument to switch off specific checks.
*/
if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) {
return -1;
}
/*
* Check for information in the push-back buffers. If there is
* some, use it. Go to the driver only if there is none (anymore)
* and the caller requests more bytes.
*/
for (copied = 0; copied < bytesToRead; copied += copiedNow) {
copiedNow = CopyBuffer(chanPtr, bufPtr + copied,
bytesToRead - copied);
if (copiedNow == 0) {
if (statePtr->flags & CHANNEL_EOF) {
goto done;
}
if (statePtr->flags & CHANNEL_BLOCKED) {
if (statePtr->flags & CHANNEL_NONBLOCKING) {
goto done;
}
statePtr->flags &= (~(CHANNEL_BLOCKED));
}
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
/* [SF Tcl Bug 943274]. Better emulation of non-blocking
* channels for channels without BlockModeProc, by keeping
* track of true fileevents generated by the OS == Data
* waiting and reading if and only if we are sure to have
* data.
*/
if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
!(statePtr->flags & CHANNEL_HAS_MORE_DATA)) {
/* We bypass the driver, it would block, as no data is available */
nread = -1;
result = EWOULDBLOCK;
} else {
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
/*
* Now go to the driver to get as much as is possible to
* fill the remaining request. Do all the error handling
* by ourselves. The code was stolen from 'GetInput' and
* slightly adapted (different return value here).
*
* The case of 'bytesToRead == 0' at this point cannot happen.
*/
nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
bufPtr + copied, bytesToRead - copied, &result);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
if (nread > 0) {
/*
* If we get a short read, signal up that we may be
* BLOCKED. We should avoid calling the driver because
* on some platforms we will block in the low level
* reading code even though the channel is set into
* nonblocking mode.
*/
if (nread < (bytesToRead - copied)) {
statePtr->flags |= CHANNEL_BLOCKED;
}
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
if (nread <= (bytesToRead - copied)) {
/* [SF Tcl Bug 943274] We have read the available
* data, clear flag */
statePtr->flags &= ~CHANNEL_HAS_MORE_DATA;
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
} else if (nread == 0) {
statePtr->flags |= CHANNEL_EOF;
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
} else if (nread < 0) {
if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
if (copied > 0) {
/*
* Information that was copied earlier has precedence
* over EAGAIN/WOULDBLOCK handling.
*/
return copied;
}
statePtr->flags |= CHANNEL_BLOCKED;
result = EAGAIN;
}
Tcl_SetErrno(result);
return -1;
}
return copied + nread;
}
}
done:
return copied;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_ReadChars --
*
* Reads from the channel until the requested number of characters
* have been seen, EOF is seen, or the channel would block. EOL
* and EOF translation is done. If reading binary data, the raw
* bytes are wrapped in a Tcl byte array object. Otherwise, the raw
* bytes are converted to UTF-8 using the channel's current encoding
* and stored in a Tcl string object.
*
* Results:
* The number of characters read, or -1 on error. Use Tcl_GetErrno()
* to retrieve the error code for the error that occurred.
*
* Side effects:
* May cause input to be buffered.
*
*---------------------------------------------------------------------------
*/
int
Tcl_ReadChars(chan, objPtr, toRead, appendFlag)
Tcl_Channel chan; /* The channel to read. */
Tcl_Obj *objPtr; /* Input data is stored in this object. */
int toRead; /* Maximum number of characters to store,
* or -1 to read all available data (up to EOF
* or when channel blocks). */
int appendFlag; /* If non-zero, data read from the channel
* will be appended to the object. Otherwise,
* the data will replace the existing contents
* of the object. */
{
Channel* chanPtr = (Channel *) chan;
ChannelState* statePtr = chanPtr->state; /* state info for channel */
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
/*
* Update the notifier state so we don't block while there is still
* data in the buffers.
*/
UpdateInterest(chanPtr);
return -1;
}
return DoReadChars (chanPtr, objPtr, toRead, appendFlag);
}
/*
*---------------------------------------------------------------------------
*
* DoReadChars --
*
* Reads from the channel until the requested number of characters
* have been seen, EOF is seen, or the channel would block. EOL
* and EOF translation is done. If reading binary data, the raw
* bytes are wrapped in a Tcl byte array object. Otherwise, the raw
* bytes are converted to UTF-8 using the channel's current encoding
* and stored in a Tcl string object.
*
* Results:
* The number of characters read, or -1 on error. Use Tcl_GetErrno()
* to retrieve the error code for the error that occurred.
*
* Side effects:
* May cause input to be buffered.
*
*---------------------------------------------------------------------------
*/
static int
DoReadChars(chanPtr, objPtr, toRead, appendFlag)
Channel* chanPtr; /* The channel to read. */
Tcl_Obj *objPtr; /* Input data is stored in this object. */
int toRead; /* Maximum number of characters to store,
* or -1 to read all available data (up to EOF
* or when channel blocks). */
int appendFlag; /* If non-zero, data read from the channel
* will be appended to the object. Otherwise,
* the data will replace the existing contents
* of the object. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
int offset, factor, copied, copiedNow, result;
Tcl_Encoding encoding;
#define UTF_EXPANSION_FACTOR 1024
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
encoding = statePtr->encoding;
factor = UTF_EXPANSION_FACTOR;
if (appendFlag == 0) {
if (encoding == NULL) {
Tcl_SetByteArrayLength(objPtr, 0);
} else {
Tcl_SetObjLength(objPtr, 0);
/*
* We're going to access objPtr->bytes directly, so
* we must ensure that this is actually a string
* object (otherwise it might have been pure Unicode).
*/
Tcl_GetString(objPtr);
}
offset = 0;
} else {
if (encoding == NULL) {
Tcl_GetByteArrayFromObj(objPtr, &offset);
} else {
Tcl_GetStringFromObj(objPtr, &offset);
}
}
for (copied = 0; (unsigned) toRead > 0; ) {
copiedNow = -1;
if (statePtr->inQueueHead != NULL) {
if (encoding == NULL) {
copiedNow = ReadBytes(statePtr, objPtr, toRead, &offset);
} else {
copiedNow = ReadChars(statePtr, objPtr, toRead, &offset,
&factor);
}
/*
* If the current buffer is empty recycle it.
*/
bufPtr = statePtr->inQueueHead;
if (bufPtr->nextRemoved == bufPtr->nextAdded) {
ChannelBuffer *nextPtr;
nextPtr = bufPtr->nextPtr;
RecycleBuffer(statePtr, bufPtr, 0);
statePtr->inQueueHead = nextPtr;
if (nextPtr == NULL) {
statePtr->inQueueTail = NULL;
}
}
}
if (copiedNow < 0) {
if (statePtr->flags & CHANNEL_EOF) {
break;
}
if (statePtr->flags & CHANNEL_BLOCKED) {
if (statePtr->flags & CHANNEL_NONBLOCKING) {
break;
}
statePtr->flags &= ~CHANNEL_BLOCKED;
}
result = GetInput(chanPtr);
if (result != 0) {
if (result == EAGAIN) {
break;
}
copied = -1;
goto done;
}
} else {
copied += copiedNow;
toRead -= copiedNow;
}
}
statePtr->flags &= ~CHANNEL_BLOCKED;
if (encoding == NULL) {
Tcl_SetByteArrayLength(objPtr, offset);
} else {
Tcl_SetObjLength(objPtr, offset);
}
done:
/*
* Update the notifier state so we don't block while there is still
* data in the buffers.
*/
UpdateInterest(chanPtr);
return copied;
}
/*
*---------------------------------------------------------------------------
*
* ReadBytes --
*
* Reads from the channel until the requested number of bytes have
* been seen, EOF is seen, or the channel would block. Bytes from
* the channel are stored in objPtr as a ByteArray object. EOL
* and EOF translation are done.
*
* 'bytesToRead' can safely be a very large number because
* space is only allocated to hold data read from the channel
* as needed.
*
* Results:
* The return value is the number of bytes appended to the object
* and *offsetPtr is filled with the total number of bytes in the
* object (greater than the return value if there were already bytes
* in the object).
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static int
ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr)
ChannelState *statePtr; /* State of the channel to read. */
Tcl_Obj *objPtr; /* Input data is appended to this ByteArray
* object. Its length is how much space
* has been allocated to hold data, not how
* many bytes of data have been stored in the
* object. */
int bytesToRead; /* Maximum number of bytes to store,
* or < 0 to get all available bytes.
* Bytes are obtained from the first
* buffer in the queue -- even if this number
* is larger than the number of bytes
* available in the first buffer, only the
* bytes from the first buffer are
* returned. */
int *offsetPtr; /* On input, contains how many bytes of
* objPtr have been used to hold data. On
* output, filled with how many bytes are now
* being used. */
{
int toRead, srcLen, offset, length, srcRead, dstWrote;
ChannelBuffer *bufPtr;
char *src, *dst;
offset = *offsetPtr;
bufPtr = statePtr->inQueueHead;
src = bufPtr->buf + bufPtr->nextRemoved;
srcLen = bufPtr->nextAdded - bufPtr->nextRemoved;
toRead = bytesToRead;
if ((unsigned) toRead > (unsigned) srcLen) {
toRead = srcLen;
}
dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length);
if (toRead > length - offset - 1) {
/*
* Double the existing size of the object or make enough room to
* hold all the characters we may get from the source buffer,
* whichever is larger.
*/
length = offset * 2;
if (offset < toRead) {
length = offset + toRead + 1;
}
dst = (char *) Tcl_SetByteArrayLength(objPtr, length);
}
dst += offset;
if (statePtr->flags & INPUT_NEED_NL) {
statePtr->flags &= ~INPUT_NEED_NL;
if ((srcLen == 0) || (*src != '\n')) {
*dst = '\r';
*offsetPtr += 1;
return 1;
}
*dst++ = '\n';
src++;
srcLen--;
toRead--;
}
srcRead = srcLen;
dstWrote = toRead;
if (TranslateInputEOL(statePtr, dst, src, &dstWrote, &srcRead) != 0) {
if (dstWrote == 0) {
return -1;
}
}
bufPtr->nextRemoved += srcRead;
*offsetPtr += dstWrote;
return dstWrote;
}
/*
*---------------------------------------------------------------------------
*
* ReadChars --
*
* Reads from the channel until the requested number of UTF-8
* characters have been seen, EOF is seen, or the channel would
* block. Raw bytes from the channel are converted to UTF-8
* and stored in objPtr. EOL and EOF translation is done.
*
* 'charsToRead' can safely be a very large number because
* space is only allocated to hold data read from the channel
* as needed.
*
* Results:
* The return value is the number of characters appended to
* the object, *offsetPtr is filled with the number of bytes that
* were appended, and *factorPtr is filled with the expansion
* factor used to guess how many bytes of UTF-8 to allocate to
* hold N source bytes.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static int
ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr)
ChannelState *statePtr; /* State of channel to read. */
Tcl_Obj *objPtr; /* Input data is appended to this object.
* objPtr->length is how much space has been
* allocated to hold data, not how many bytes
* of data have been stored in the object. */
int charsToRead; /* Maximum number of characters to store,
* or -1 to get all available characters.
* Characters are obtained from the first
* buffer in the queue -- even if this number
* is larger than the number of characters
* available in the first buffer, only the
* characters from the first buffer are
* returned. */
int *offsetPtr; /* On input, contains how many bytes of
* objPtr have been used to hold data. On
* output, filled with how many bytes are now
* being used. */
int *factorPtr; /* On input, contains a guess of how many
* bytes need to be allocated to hold the
* result of converting N source bytes to
* UTF-8. On output, contains another guess
* based on the data seen so far. */
{
int toRead, factor, offset, spaceLeft, length, srcLen, dstNeeded;
int srcRead, dstWrote, numChars, dstRead;
ChannelBuffer *bufPtr;
char *src, *dst;
Tcl_EncodingState oldState;
int encEndFlagSuppressed = 0;
factor = *factorPtr;
offset = *offsetPtr;
bufPtr = statePtr->inQueueHead;
src = bufPtr->buf + bufPtr->nextRemoved;
srcLen = bufPtr->nextAdded - bufPtr->nextRemoved;
toRead = charsToRead;
if ((unsigned)toRead > (unsigned)srcLen) {
toRead = srcLen;
}
/*
* 'factor' is how much we guess that the bytes in the source buffer
* will expand when converted to UTF-8 chars. This guess comes from
* analyzing how many characters were produced by the previous
* pass.
*/
dstNeeded = toRead * factor / UTF_EXPANSION_FACTOR;
spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1;
if (dstNeeded > spaceLeft) {
/*
* Double the existing size of the object or make enough room to
* hold all the characters we want from the source buffer,
* whichever is larger.
*/
length = offset * 2;
if (offset < dstNeeded) {
length = offset + dstNeeded;
}
spaceLeft = length - offset;
length += TCL_UTF_MAX + 1;
Tcl_SetObjLength(objPtr, length);
}
if (toRead == srcLen) {
/*
* Want to convert the whole buffer in one pass. If we have
* enough space, convert it using all available space in object
* rather than using the factor.
*/
dstNeeded = spaceLeft;
}
dst = objPtr->bytes + offset;
/*
* SF Tcl Bug 1462248
* The cause of the crash reported in the referenced bug is this:
*
* - ReadChars, called with a single buffer, with a incomplete
* multi-byte character at the end (only the first byte of it).
* - Encoding translation fails, asks for more data
* - Data is read, and eof is reached, TCL_ENCODING_END (TEE) is set.
* - ReadChar is called again, converts the first buffer, but due
* to TEE it does not check for incomplete multi-byte data, and the
* character just after the end of the first buffer is a valid
* completion of the multi-byte header in the actual buffer. The
* conversion reads more characters from the buffer then present.
* This causes nextRemoved to overshoot nextAdded and the next
* reads compute a negative srcLen, cause further translations to
* fail, causing copying of data into the next buffer using bad
* arguments, causing the mecpy for to eventually fail.
*
* In the end it is a memory access bug spiraling out of control
* if the conditions are _just so_. And ultimate cause is that TEE
* is given to a conversion where it should not. TEE signals that
* this is the last buffer. Except in our case it is not.
*
* My solution is to suppress TEE if the first buffer is not the
* last. We will eventually need it given that EOF has been
* reached, but not right now. This is what the new flag
* "endEncSuppressFlag" is for.
*
* The bug in 'Tcl_Utf2UtfProc' where it read from memory behind
* the actual buffer has been fixed as well, and fixes the problem
* with the crash too, but this would still allow the generic
* layer to accidentially break a multi-byte sequence if the
* conditions are just right, because again the ExternalToUtf
* would be successful where it should not.
*/
if ((statePtr->inputEncodingFlags & TCL_ENCODING_END) &&
(bufPtr->nextPtr != NULL)) {
/* TEE is set for a buffer which is not the last. Squash it
* for now, and restore it later, before yielding control to
* our caller.
*/
statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
encEndFlagSuppressed = 1;
}
oldState = statePtr->inputEncodingState;
if (statePtr->flags & INPUT_NEED_NL) {
/*
* We want a '\n' because the last character we saw was '\r'.
*/
statePtr->flags &= ~INPUT_NEED_NL;
Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
statePtr->inputEncodingFlags, &statePtr->inputEncodingState,
dst, TCL_UTF_MAX + 1, &srcRead, &dstWrote, &numChars);
if ((dstWrote > 0) && (*dst == '\n')) {
/*
* The next char was a '\n'. Consume it and produce a '\n'.
*/
bufPtr->nextRemoved += srcRead;
} else {
/*
* The next char was not a '\n'. Produce a '\r'.
*/
*dst = '\r';
}
statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;
*offsetPtr += 1;
if (encEndFlagSuppressed) {
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
}
return 1;
}
Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst,
dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
if (encEndFlagSuppressed) {
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
}
if (srcRead == 0) {
/*
* Not enough bytes in src buffer to make a complete char. Copy
* the bytes to the next buffer to make a new contiguous string,
* then tell the caller to fill the buffer with more bytes.
*/
ChannelBuffer *nextPtr;
nextPtr = bufPtr->nextPtr;
if (nextPtr == NULL) {
if (srcLen > 0) {
/*
* There isn't enough data in the buffers to complete the next
* character, so we need to wait for more data before the next
* file event can be delivered.
*
* SF #478856.
*
* The exception to this is if the input buffer was
* completely empty before we tried to convert its
* contents. Nothing in, nothing out, and no incomplete
* character data. The conversion before the current one
* was complete.
*/
statePtr->flags |= CHANNEL_NEED_MORE_DATA;
}
return -1;
}
/* Space is made at the beginning of the buffer to copy the
* previous unused bytes there. Check first if the buffer we
* are using actually has enough space at its beginning for
* the data we are copying. Because if not we will write over the
* buffer management information, especially the 'nextPtr'.
*
* Note that the BUFFER_PADDING (See AllocChannelBuffer) is
* used to prevent exactly this situation. I.e. it should
* never happen. Therefore it is ok to panic should it happen
* despite the precautions.
*/
if (nextPtr->nextRemoved - srcLen < 0) {
Tcl_Panic ("Buffer Underflow, BUFFER_PADDING not enough");
}
nextPtr->nextRemoved -= srcLen;
memcpy((VOID *) (nextPtr->buf + nextPtr->nextRemoved), (VOID *) src,
(size_t) srcLen);
RecycleBuffer(statePtr, bufPtr, 0);
statePtr->inQueueHead = nextPtr;
return ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr);
}
dstRead = dstWrote;
if (TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead) != 0) {
/*
* Hit EOF char. How many bytes of src correspond to where the
* EOF was located in dst? Run the conversion again with an
* output buffer just big enough to hold the data so we can
* get the correct value for srcRead.
*/
if (dstWrote == 0) {
return -1;
}
statePtr->inputEncodingState = oldState;
Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
statePtr->inputEncodingFlags, &statePtr->inputEncodingState,
dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead);
}
/*
* The number of characters that we got may be less than the number
* that we started with because "\r\n" sequences may have been
* turned into just '\n' in dst.
*/
numChars -= (dstRead - dstWrote);
if ((unsigned) numChars > (unsigned) toRead) {
/*
* Got too many chars.
*/
CONST char *eof;
eof = Tcl_UtfAtIndex(dst, toRead);
statePtr->inputEncodingState = oldState;
Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
statePtr->inputEncodingFlags, &statePtr->inputEncodingState,
dst, eof - dst + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
dstRead = dstWrote;
TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead);
numChars -= (dstRead - dstWrote);
}
statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;
bufPtr->nextRemoved += srcRead;
if (dstWrote > srcRead + 1) {
*factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead;
}
*offsetPtr += dstWrote;
return numChars;
}
/*
*---------------------------------------------------------------------------
*
* TranslateInputEOL --
*
* Perform input EOL and EOF translation on the source buffer,
* leaving the translated result in the destination buffer.
*
* Results:
* The return value is 1 if the EOF character was found when copying
* bytes to the destination buffer, 0 otherwise.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static int
TranslateInputEOL(statePtr, dstStart, srcStart, dstLenPtr, srcLenPtr)
ChannelState *statePtr; /* Channel being read, for EOL translation
* and EOF character. */
char *dstStart; /* Output buffer filled with chars by
* applying appropriate EOL translation to
* source characters. */
CONST char *srcStart; /* Source characters. */
int *dstLenPtr; /* On entry, the maximum length of output
* buffer in bytes; must be <= *srcLenPtr. On
* exit, the number of bytes actually used in
* output buffer. */
int *srcLenPtr; /* On entry, the length of source buffer.
* On exit, the number of bytes read from
* the source buffer. */
{
int dstLen, srcLen, inEofChar;
CONST char *eof;
dstLen = *dstLenPtr;
eof = NULL;
inEofChar = statePtr->inEofChar;
if (inEofChar != '\0') {
/*
* Find EOF in translated buffer then compress out the EOL. The
* source buffer may be much longer than the destination buffer --
* we only want to return EOF if the EOF has been copied to the
* destination buffer.
*/
CONST char *src, *srcMax;
srcMax = srcStart + *srcLenPtr;
for (src = srcStart; src < srcMax; src++) {
if (*src == inEofChar) {
eof = src;
srcLen = src - srcStart;
if (srcLen < dstLen) {
dstLen = srcLen;
}
*srcLenPtr = srcLen;
break;
}
}
}
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF: {
if (dstStart != srcStart) {
memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen);
}
srcLen = dstLen;
break;
}
case TCL_TRANSLATE_CR: {
char *dst, *dstEnd;
if (dstStart != srcStart) {
memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen);
}
dstEnd = dstStart + dstLen;
for (dst = dstStart; dst < dstEnd; dst++) {
if (*dst == '\r') {
*dst = '\n';
}
}
srcLen = dstLen;
break;
}
case TCL_TRANSLATE_CRLF: {
char *dst;
CONST char *src, *srcEnd, *srcMax;
dst = dstStart;
src = srcStart;
srcEnd = srcStart + dstLen;
srcMax = srcStart + *srcLenPtr;
for ( ; src < srcEnd; ) {
if (*src == '\r') {
src++;
if (src >= srcMax) {
statePtr->flags |= INPUT_NEED_NL;
} else if (*src == '\n') {
*dst++ = *src++;
} else {
*dst++ = '\r';
}
} else {
*dst++ = *src++;
}
}
srcLen = src - srcStart;
dstLen = dst - dstStart;
break;
}
case TCL_TRANSLATE_AUTO: {
char *dst;
CONST char *src, *srcEnd, *srcMax;
dst = dstStart;
src = srcStart;
srcEnd = srcStart + dstLen;
srcMax = srcStart + *srcLenPtr;
if ((statePtr->flags & INPUT_SAW_CR) && (src < srcMax)) {
if (*src == '\n') {
src++;
}
statePtr->flags &= ~INPUT_SAW_CR;
}
for ( ; src < srcEnd; ) {
if (*src == '\r') {
src++;
if (src >= srcMax) {
statePtr->flags |= INPUT_SAW_CR;
} else if (*src == '\n') {
if (srcEnd < srcMax) {
srcEnd++;
}
src++;
}
*dst++ = '\n';
} else {
*dst++ = *src++;
}
}
srcLen = src - srcStart;
dstLen = dst - dstStart;
break;
}
default: { /* lint. */
return 0;
}
}
*dstLenPtr = dstLen;
if ((eof != NULL) && (srcStart + srcLen >= eof)) {
/*
* EOF character was seen in EOL translated range. Leave current
* file position pointing at the EOF character, but don't store the
* EOF character in the output string.
*/
statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
statePtr->flags &= ~(INPUT_SAW_CR | INPUT_NEED_NL);
return 1;
}
*srcLenPtr = srcLen;
return 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Ungets --
*
* Causes the supplied string to be added to the input queue of
* the channel, at either the head or tail of the queue.
*
* Results:
* The number of bytes stored in the channel, or -1 on error.
*
* Side effects:
* Adds input to the input queue of a channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_Ungets(chan, str, len, atEnd)
Tcl_Channel chan; /* The channel for which to add the input. */
CONST char *str; /* The input itself. */
int len; /* The length of the input. */
int atEnd; /* If non-zero, add at end of queue; otherwise
* add at head of queue. */
{
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of actual channel. */
ChannelBuffer *bufPtr; /* Buffer to contain the data. */
int i, flags;
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
/*
* CheckChannelErrors clears too many flag bits in this one case.
*/
flags = statePtr->flags;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
len = -1;
goto done;
}
statePtr->flags = flags;
/*
* If we have encountered a sticky EOF, just punt without storing.
* (sticky EOF is set if we have seen the input eofChar, to prevent
* reading beyond the eofChar). Otherwise, clear the EOF flags, and
* clear the BLOCKED bit. We want to discover these conditions anew
* in each operation.
*/
if (statePtr->flags & CHANNEL_STICKY_EOF) {
goto done;
}
statePtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF));
bufPtr = AllocChannelBuffer(len);
for (i = 0; i < len; i++) {
bufPtr->buf[bufPtr->nextAdded++] = str[i];
}
if (statePtr->inQueueHead == (ChannelBuffer *) NULL) {
bufPtr->nextPtr = (ChannelBuffer *) NULL;
statePtr->inQueueHead = bufPtr;
statePtr->inQueueTail = bufPtr;
} else if (atEnd) {
bufPtr->nextPtr = (ChannelBuffer *) NULL;
statePtr->inQueueTail->nextPtr = bufPtr;
statePtr->inQueueTail = bufPtr;
} else {
bufPtr->nextPtr = statePtr->inQueueHead;
statePtr->inQueueHead = bufPtr;
}
done:
/*
* Update the notifier state so we don't block while there is still
* data in the buffers.
*/
UpdateInterest(chanPtr);
return len;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Flush --
*
* Flushes output data on a channel.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May flush output queued on this channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_Flush(chan)
Tcl_Channel chan; /* The Channel to flush. */
{
int result; /* Of calling FlushChannel. */
Channel *chanPtr = (Channel *) chan; /* The actual channel. */
ChannelState *statePtr = chanPtr->state; /* State of actual channel. */
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return -1;
}
/*
* Force current output buffer to be output also.
*/
if ((statePtr->curOutPtr != NULL)
&& (statePtr->curOutPtr->nextAdded > 0)) {
statePtr->flags |= BUFFER_READY;
}
result = FlushChannel(NULL, chanPtr, 0);
if (result != 0) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DiscardInputQueued --
*
* Discards any input read from the channel but not yet consumed
* by Tcl reading commands.
*
* Results:
* None.
*
* Side effects:
* May discard input from the channel. If discardLastBuffer is zero,
* leaves one buffer in place for back-filling.
*
*----------------------------------------------------------------------
*/
static void
DiscardInputQueued(statePtr, discardSavedBuffers)
ChannelState *statePtr; /* Channel on which to discard
* the queued input. */
int discardSavedBuffers; /* If non-zero, discard all buffers including
* last one. */
{
ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */
bufPtr = statePtr->inQueueHead;
statePtr->inQueueHead = (ChannelBuffer *) NULL;
statePtr->inQueueTail = (ChannelBuffer *) NULL;
for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) {
nxtPtr = bufPtr->nextPtr;
RecycleBuffer(statePtr, bufPtr, discardSavedBuffers);
}
/*
* If discardSavedBuffers is nonzero, must also discard any previously
* saved buffer in the saveInBufPtr field.
*/
if (discardSavedBuffers) {
if (statePtr->saveInBufPtr != (ChannelBuffer *) NULL) {
ckfree((char *) statePtr->saveInBufPtr);
statePtr->saveInBufPtr = (ChannelBuffer *) NULL;
}
}
}
/*
*---------------------------------------------------------------------------
*
* GetInput --
*
* Reads input data from a device into a channel buffer.
*
* Results:
* The return value is the Posix error code if an error occurred while
* reading from the file, or 0 otherwise.
*
* Side effects:
* Reads from the underlying device.
*
*---------------------------------------------------------------------------
*/
static int
GetInput(chanPtr)
Channel *chanPtr; /* Channel to read input from. */
{
int toRead; /* How much to read? */
int result; /* Of calling driver. */
int nread; /* How much was read from channel? */
ChannelBuffer *bufPtr; /* New buffer to add to input queue. */
ChannelState *statePtr = chanPtr->state; /* state info for channel */
/*
* Prevent reading from a dead channel -- a channel that has been closed
* but not yet deallocated, which can happen if the exit handler for
* channel cleanup has run but the channel is still registered in some
* interpreter.
*/
if (CheckForDeadChannel(NULL, statePtr)) {
return EINVAL;
}
/*
* First check for more buffers in the pushback area of the
* topmost channel in the stack and use them. They can be the
* result of a transformation which went away without reading all
* the information placed in the area when it was stacked.
*
* Two possibilities for the state: No buffers in it, or a single
* empty buffer. In the latter case we can recycle it now.
*/
if (chanPtr->inQueueHead != (ChannelBuffer*) NULL) {
if (statePtr->inQueueHead != (ChannelBuffer*) NULL) {
RecycleBuffer(statePtr, statePtr->inQueueHead, 0);
statePtr->inQueueHead = (ChannelBuffer*) NULL;
}
statePtr->inQueueHead = chanPtr->inQueueHead;
statePtr->inQueueTail = chanPtr->inQueueTail;
chanPtr->inQueueHead = (ChannelBuffer*) NULL;
chanPtr->inQueueTail = (ChannelBuffer*) NULL;
return 0;
}
/*
* Nothing in the pushback area, fall back to the usual handling
* (driver, etc.)
*/
/*
* See if we can fill an existing buffer. If we can, read only
* as much as will fit in it. Otherwise allocate a new buffer,
* add it to the input queue and attempt to fill it to the max.
*/
bufPtr = statePtr->inQueueTail;
if ((bufPtr != NULL) && (bufPtr->nextAdded < bufPtr->bufLength)) {
toRead = bufPtr->bufLength - bufPtr->nextAdded;
} else {
bufPtr = statePtr->saveInBufPtr;
statePtr->saveInBufPtr = NULL;
/*
* Check the actual buffersize against the requested
* buffersize. Buffers which are smaller than requested are
* squashed. This is done to honor dynamic changes of the
* buffersize made by the user.
*/
if ((bufPtr != NULL) && ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize)) {
ckfree((char *) bufPtr);
bufPtr = NULL;
}
if (bufPtr == NULL) {
bufPtr = AllocChannelBuffer(statePtr->bufSize);
}
bufPtr->nextPtr = (ChannelBuffer *) NULL;
/* SF #427196: Use the actual size of the buffer to determine
* the number of bytes to read from the channel and not the
* size for new buffers. They can be different if the
* buffersize was changed between reads.
*
* Note: This affects performance negatively if the buffersize
* was extended but this small buffer is reused for all
* subsequent reads. The system never uses buffers with the
* requested bigger size in that case. An adjunct patch could
* try and delete all unused buffers it encounters and which
* are smaller than the formally requested buffersize.
*/
toRead = bufPtr->bufLength - bufPtr->nextAdded;
if (statePtr->inQueueTail == NULL) {
statePtr->inQueueHead = bufPtr;
} else {
statePtr->inQueueTail->nextPtr = bufPtr;
}
statePtr->inQueueTail = bufPtr;
}
/*
* If EOF is set, we should avoid calling the driver because on some
* platforms it is impossible to read from a device after EOF.
*/
if (statePtr->flags & CHANNEL_EOF) {
return 0;
}
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
/* [SF Tcl Bug 943274]. Better emulation of non-blocking channels
* for channels without BlockModeProc, by keeping track of true
* fileevents generated by the OS == Data waiting and reading if
* and only if we are sure to have data.
*/
if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
!(statePtr->flags & CHANNEL_HAS_MORE_DATA)) {
/* Bypass the driver, it would block, as no data is available */
nread = -1;
result = EWOULDBLOCK;
} else {
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
bufPtr->buf + bufPtr->nextAdded, toRead, &result);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
if (nread > 0) {
bufPtr->nextAdded += nread;
/*
* If we get a short read, signal up that we may be BLOCKED. We
* should avoid calling the driver because on some platforms we
* will block in the low level reading code even though the
* channel is set into nonblocking mode.
*/
if (nread < toRead) {
statePtr->flags |= CHANNEL_BLOCKED;
}
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
if (nread <= toRead) {
/* [SF Tcl Bug 943274] We have read the available data,
* clear flag */
statePtr->flags &= ~CHANNEL_HAS_MORE_DATA;
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
} else if (nread == 0) {
statePtr->flags |= CHANNEL_EOF;
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
} else if (nread < 0) {
if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
statePtr->flags |= CHANNEL_BLOCKED;
result = EAGAIN;
}
Tcl_SetErrno(result);
return result;
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Seek --
*
* Implements seeking on Tcl Channels. This is a public function
* so that other C facilities may be implemented on top of it.
*
* Results:
* The new access point or -1 on error. If error, use Tcl_GetErrno()
* to retrieve the POSIX error code for the error that occurred.
*
* Side effects:
* May flush output on the channel. May discard queued input.
*
*----------------------------------------------------------------------
*/
Tcl_WideInt
Tcl_Seek(chan, offset, mode)
Tcl_Channel chan; /* The channel on which to seek. */
Tcl_WideInt offset; /* Offset to seek to. */
int mode; /* Relative to which location to seek? */
{
Channel *chanPtr = (Channel *) chan; /* The real IO channel. */
ChannelState *statePtr = chanPtr->state; /* state info for channel */
int inputBuffered, outputBuffered;
/* # bytes held in buffers. */
int result; /* Of device driver operations. */
Tcl_WideInt curPos; /* Position on the device. */
int wasAsync; /* Was the channel nonblocking before the
* seek operation? If so, must restore to
* nonblocking mode after the seek. */
if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
return Tcl_LongAsWide(-1);
}
/*
* Disallow seek on dead channels -- channels that have been closed but
* not yet been deallocated. Such channels can be found if the exit
* handler for channel cleanup has run but the channel is still
* registered in an interpreter.
*/
if (CheckForDeadChannel(NULL, statePtr)) {
return Tcl_LongAsWide(-1);
}
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
/*
* Disallow seek on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) {
Tcl_SetErrno(EINVAL);
return Tcl_LongAsWide(-1);
}
/*
* Compute how much input and output is buffered. If both input and
* output is buffered, cannot compute the current position.
*/
inputBuffered = Tcl_InputBuffered(chan);
outputBuffered = Tcl_OutputBuffered(chan);
if ((inputBuffered != 0) && (outputBuffered != 0)) {
Tcl_SetErrno(EFAULT);
return Tcl_LongAsWide(-1);
}
/*
* If we are seeking relative to the current position, compute the
* corrected offset taking into account the amount of unread input.
*/
if (mode == SEEK_CUR) {
offset -= inputBuffered;
}
/*
* Discard any queued input - this input should not be read after
* the seek.
*/
DiscardInputQueued(statePtr, 0);
/*
* Reset EOF and BLOCKED flags. We invalidate them by moving the
* access point. Also clear CR related flags.
*/
statePtr->flags &=
(~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR));
/*
* If the channel is in asynchronous output mode, switch it back
* to synchronous mode and cancel any async flush that may be
* scheduled. After the flush, the channel will be put back into
* asynchronous output mode.
*/
wasAsync = 0;
if (statePtr->flags & CHANNEL_NONBLOCKING) {
wasAsync = 1;
result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
if (result != 0) {
return Tcl_LongAsWide(-1);
}
statePtr->flags &= (~(CHANNEL_NONBLOCKING));
if (statePtr->flags & BG_FLUSH_SCHEDULED) {
statePtr->flags &= (~(BG_FLUSH_SCHEDULED));
}
}
/*
* If the flush fails we cannot recover the original position. In
* that case the seek is not attempted because we do not know where
* the access position is - instead we return the error. FlushChannel
* has already called Tcl_SetErrno() to report the error upwards.
* If the flush succeeds we do the seek also.
*/
if (FlushChannel(NULL, chanPtr, 0) != 0) {
curPos = -1;
} else {
/*
* Now seek to the new position in the channel as requested by the
* caller. Note that we prefer the wideSeekProc if that is
* available and non-NULL...
*/
if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
chanPtr->typePtr->wideSeekProc != NULL) {
curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
offset, mode, &result);
} else if (offset < Tcl_LongAsWide(LONG_MIN) ||
offset > Tcl_LongAsWide(LONG_MAX)) {
result = EOVERFLOW;
curPos = Tcl_LongAsWide(-1);
} else {
curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) (
chanPtr->instanceData, Tcl_WideAsLong(offset), mode,
&result));
}
if (curPos == Tcl_LongAsWide(-1)) {
Tcl_SetErrno(result);
}
}
/*
* Restore to nonblocking mode if that was the previous behavior.
*
* NOTE: Even if there was an async flush active we do not restore
* it now because we already flushed all the queued output, above.
*/
if (wasAsync) {
statePtr->flags |= CHANNEL_NONBLOCKING;
result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING);
if (result != 0) {
return Tcl_LongAsWide(-1);
}
}
return curPos;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Tell --
*
* Returns the position of the next character to be read/written on
* this channel.
*
* Results:
* A nonnegative integer on success, -1 on failure. If failed,
* use Tcl_GetErrno() to retrieve the POSIX error code for the
* error that occurred.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_WideInt
Tcl_Tell(chan)
Tcl_Channel chan; /* The channel to return pos for. */
{
Channel *chanPtr = (Channel *) chan; /* The real IO channel. */
ChannelState *statePtr = chanPtr->state; /* state info for channel */
int inputBuffered, outputBuffered; /* # bytes held in buffers. */
int result; /* Of calling device driver. */
Tcl_WideInt curPos; /* Position on device. */
if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
return Tcl_LongAsWide(-1);
}
/*
* Disallow tell on dead channels -- channels that have been closed but
* not yet been deallocated. Such channels can be found if the exit
* handler for channel cleanup has run but the channel is still
* registered in an interpreter.
*/
if (CheckForDeadChannel(NULL, statePtr)) {
return Tcl_LongAsWide(-1);
}
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
/*
* Disallow tell on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) {
Tcl_SetErrno(EINVAL);
return Tcl_LongAsWide(-1);
}
/*
* Compute how much input and output is buffered. If both input and
* output is buffered, cannot compute the current position.
*/
inputBuffered = Tcl_InputBuffered(chan);
outputBuffered = Tcl_OutputBuffered(chan);
if ((inputBuffered != 0) && (outputBuffered != 0)) {
Tcl_SetErrno(EFAULT);
return Tcl_LongAsWide(-1);
}
/*
* Get the current position in the device and compute the position
* where the next character will be read or written. Note that we
* prefer the wideSeekProc if that is available and non-NULL...
*/
if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
chanPtr->typePtr->wideSeekProc != NULL) {
curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
Tcl_LongAsWide(0), SEEK_CUR, &result);
} else {
curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) (
chanPtr->instanceData, 0, SEEK_CUR, &result));
}
if (curPos == Tcl_LongAsWide(-1)) {
Tcl_SetErrno(result);
return Tcl_LongAsWide(-1);
}
if (inputBuffered != 0) {
return curPos - inputBuffered;
}
return curPos + outputBuffered;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_SeekOld, Tcl_TellOld --
*
* Backward-compatability versions of the seek/tell interface that
* do not support 64-bit offsets. This interface is not documented
* or expected to be supported indefinitely.
*
* Results:
* As for Tcl_Seek and Tcl_Tell respectively, except truncated to
* whatever value will fit in an 'int'.
*
* Side effects:
* As for Tcl_Seek and Tcl_Tell respectively.
*
*---------------------------------------------------------------------------
*/
int
Tcl_SeekOld(chan, offset, mode)
Tcl_Channel chan; /* The channel on which to seek. */
int offset; /* Offset to seek to. */
int mode; /* Relative to which location to seek? */
{
Tcl_WideInt wOffset, wResult;
wOffset = Tcl_LongAsWide((long)offset);
wResult = Tcl_Seek(chan, wOffset, mode);
return (int)Tcl_WideAsLong(wResult);
}
int
Tcl_TellOld(chan)
Tcl_Channel chan; /* The channel to return pos for. */
{
Tcl_WideInt wResult;
wResult = Tcl_Tell(chan);
return (int)Tcl_WideAsLong(wResult);
}
/*
*---------------------------------------------------------------------------
*
* CheckChannelErrors --
*
* See if the channel is in an ready state and can perform the
* desired operation.
*
* Results:
* The return value is 0 if the channel is OK, otherwise the
* return value is -1 and errno is set to indicate the error.
*
* Side effects:
* May clear the EOF and/or BLOCKED bits if reading from channel.
*
*---------------------------------------------------------------------------
*/
static int
CheckChannelErrors(statePtr, flags)
ChannelState *statePtr; /* Channel to check. */
int flags; /* Test if channel supports desired operation:
* TCL_READABLE, TCL_WRITABLE. Also indicates
* Raw read or write for special close
* processing*/
{
int direction = flags & (TCL_READABLE|TCL_WRITABLE);
/*
* Check for unreported error.
*/
if (statePtr->unreportedError != 0) {
Tcl_SetErrno(statePtr->unreportedError);
statePtr->unreportedError = 0;
return -1;
}
/*
* Only the raw read and write operations are allowed during close
* in order to drain data from stacked channels.
*/
if ((statePtr->flags & CHANNEL_CLOSED) &&
((flags & CHANNEL_RAW_MODE) == 0)) {
Tcl_SetErrno(EACCES);
return -1;
}
/*
* Fail if the channel is not opened for desired operation.
*/
if ((statePtr->flags & direction) == 0) {
Tcl_SetErrno(EACCES);
return -1;
}
/*
* Fail if the channel is in the middle of a background copy.
*
* Don't do this tests for raw channels here or else the chaining in the
* transformation drivers will fail with 'file busy' error instead of
* retrieving and transforming the data to copy.
*/
if (BUSY_STATE(statePtr,flags) && ((flags & CHANNEL_RAW_MODE) == 0)) {
Tcl_SetErrno(EBUSY);
return -1;
}
if (direction == TCL_READABLE) {
/*
* If we have not encountered a sticky EOF, clear the EOF bit
* (sticky EOF is set if we have seen the input eofChar, to prevent
* reading beyond the eofChar). Also, always clear the BLOCKED bit.
* We want to discover these conditions anew in each operation.
*/
if ((statePtr->flags & CHANNEL_STICKY_EOF) == 0) {
statePtr->flags &= ~CHANNEL_EOF;
}
statePtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Eof --
*
* Returns 1 if the channel is at EOF, 0 otherwise.
*
* Results:
* 1 or 0, always.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_Eof(chan)
Tcl_Channel chan; /* Does this channel have EOF? */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
return ((statePtr->flags & CHANNEL_STICKY_EOF) ||
((statePtr->flags & CHANNEL_EOF) &&
(Tcl_InputBuffered(chan) == 0))) ? 1 : 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_InputBlocked --
*
* Returns 1 if input is blocked on this channel, 0 otherwise.
*
* Results:
* 0 or 1, always.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_InputBlocked(chan)
Tcl_Channel chan; /* Is this channel blocked? */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
return (statePtr->flags & CHANNEL_BLOCKED) ? 1 : 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_InputBuffered --
*
* Returns the number of bytes of input currently buffered in the
* common internal buffer of a channel.
*
* Results:
* The number of input bytes buffered, or zero if the channel is not
* open for reading.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_InputBuffered(chan)
Tcl_Channel chan; /* The channel to query. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
ChannelBuffer *bufPtr;
int bytesBuffered;
for (bytesBuffered = 0, bufPtr = statePtr->inQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
bytesBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved);
}
/*
* Don't forget the bytes in the topmost pushback area.
*/
for (bufPtr = statePtr->topChanPtr->inQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
bytesBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved);
}
return bytesBuffered;
}
/*
*----------------------------------------------------------------------
*
* Tcl_OutputBuffered --
*
* Returns the number of bytes of output currently buffered in the
* common internal buffer of a channel.
*
* Results:
* The number of output bytes buffered, or zero if the channel is not
* open for writing.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_OutputBuffered(chan)
Tcl_Channel chan; /* The channel to query. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
ChannelBuffer *bufPtr;
int bytesBuffered;
for (bytesBuffered = 0, bufPtr = statePtr->outQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
bytesBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved);
}
if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
(statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) {
statePtr->flags |= BUFFER_READY;
bytesBuffered +=
(statePtr->curOutPtr->nextAdded - statePtr->curOutPtr->nextRemoved);
}
return bytesBuffered;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelBuffered --
*
* Returns the number of bytes of input currently buffered in the
* internal buffer (push back area) of a channel.
*
* Results:
* The number of input bytes buffered, or zero if the channel is not
* open for reading.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ChannelBuffered(chan)
Tcl_Channel chan; /* The channel to query. */
{
Channel *chanPtr = (Channel *) chan;
/* real channel structure. */
ChannelBuffer *bufPtr;
int bytesBuffered;
for (bytesBuffered = 0, bufPtr = chanPtr->inQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
bytesBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved);
}
return bytesBuffered;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetChannelBufferSize --
*
* Sets the size of buffers to allocate to store input or output
* in the channel. The size must be between 1 byte and 1 MByte.
*
* Results:
* None.
*
* Side effects:
* Sets the size of buffers subsequently allocated for this channel.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetChannelBufferSize(chan, sz)
Tcl_Channel chan; /* The channel whose buffer size
* to set. */
int sz; /* The size to set. */
{
ChannelState *statePtr; /* State of real channel structure. */
/*
* Clip the buffer size to force it into the [1,1M] range
*/
if (sz < 1) {
sz = 1;
} else if (sz > MAX_CHANNEL_BUFFER_SIZE) {
sz = MAX_CHANNEL_BUFFER_SIZE;
}
statePtr = ((Channel *) chan)->state;
statePtr->bufSize = sz;
if (statePtr->outputStage != NULL) {
ckfree((char *) statePtr->outputStage);
statePtr->outputStage = NULL;
}
if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
statePtr->outputStage = (char *)
ckalloc((unsigned) (statePtr->bufSize + 2));
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelBufferSize --
*
* Retrieves the size of buffers to allocate for this channel.
*
* Results:
* The size.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetChannelBufferSize(chan)
Tcl_Channel chan; /* The channel for which to find the
* buffer size. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
return statePtr->bufSize;
}
/*
*----------------------------------------------------------------------
*
* Tcl_BadChannelOption --
*
* This procedure generates a "bad option" error message in an
* (optional) interpreter. It is used by channel drivers when
* a invalid Set/Get option is requested. Its purpose is to concatenate
* the generic options list to the specific ones and factorize
* the generic options error message string.
*
* Results:
* TCL_ERROR.
*
* Side effects:
* An error message is generated in interp's result object to
* indicate that a command was invoked with the a bad option
* The message has the form
* bad option "blah": should be one of
* <...generic options...>+<...specific options...>
* "blah" is the optionName argument and ""
* is a space separated list of specific option words.
* The function takes good care of inserting minus signs before
* each option, commas after, and an "or" before the last option.
*
*----------------------------------------------------------------------
*/
int
Tcl_BadChannelOption(interp, optionName, optionList)
Tcl_Interp *interp; /* Current interpreter. (can be NULL)*/
CONST char *optionName; /* 'bad option' name */
CONST char *optionList; /* Specific options list to append
* to the standard generic options.
* can be NULL for generic options
* only.
*/
{
if (interp) {
CONST char *genericopt =
"blocking buffering buffersize encoding eofchar translation";
CONST char **argv;
int argc, i;
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, genericopt, -1);
if (optionList && (*optionList)) {
Tcl_DStringAppend(&ds, " ", 1);
Tcl_DStringAppend(&ds, optionList, -1);
}
if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
&argc, &argv) != TCL_OK) {
panic("malformed option list in channel driver");
}
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad option \"", optionName,
"\": should be one of ", (char *) NULL);
argc--;
for (i = 0; i < argc; i++) {
Tcl_AppendResult(interp, "-", argv[i], ", ", (char *) NULL);
}
Tcl_AppendResult(interp, "or -", argv[i], (char *) NULL);
Tcl_DStringFree(&ds);
ckfree((char *) argv);
}
Tcl_SetErrno(EINVAL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelOption --
*
* Gets a mode associated with an IO channel. If the optionName arg
* is non NULL, retrieves the value of that option. If the optionName
* arg is NULL, retrieves a list of alternating option names and
* values for the given channel.
*
* Results:
* A standard Tcl result. Also sets the supplied DString to the
* string value of the option(s) returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetChannelOption(interp, chan, optionName, dsPtr)
Tcl_Interp *interp; /* For error reporting - can be NULL. */
Tcl_Channel chan; /* Channel on which to get option. */
CONST char *optionName; /* Option to get. */
Tcl_DString *dsPtr; /* Where to store value(s). */
{
size_t len; /* Length of optionName string. */
char optionVal[128]; /* Buffer for sprintf. */
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state; /* state info for channel */
int flags;
/*
* Disallow options on dead channels -- channels that have been closed but
* not yet been deallocated. Such channels can be found if the exit
* handler for channel cleanup has run but the channel is still
* registered in an interpreter.
*/
if (CheckForDeadChannel(interp, statePtr)) {
return TCL_ERROR;
}
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
/*
* If we are in the middle of a background copy, use the saved flags.
*/
if (statePtr->csPtrR) {
flags = statePtr->csPtrR->readFlags;
} else if (statePtr->csPtrW) {
flags = statePtr->csPtrW->writeFlags;
} else {
flags = statePtr->flags;
}
/*
* If the optionName is NULL it means that we want a list of all
* options and values.
*/
if (optionName == (char *) NULL) {
len = 0;
} else {
len = strlen(optionName);
}
if ((len == 0) || ((len > 2) && (optionName[1] == 'b') &&
(strncmp(optionName, "-blocking", len) == 0))) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-blocking");
}
Tcl_DStringAppendElement(dsPtr,
(flags & CHANNEL_NONBLOCKING) ? "0" : "1");
if (len > 0) {
return TCL_OK;
}
}
if ((len == 0) || ((len > 7) && (optionName[1] == 'b') &&
(strncmp(optionName, "-buffering", len) == 0))) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-buffering");
}
if (flags & CHANNEL_LINEBUFFERED) {
Tcl_DStringAppendElement(dsPtr, "line");
} else if (flags & CHANNEL_UNBUFFERED) {
Tcl_DStringAppendElement(dsPtr, "none");
} else {
Tcl_DStringAppendElement(dsPtr, "full");
}
if (len > 0) {
return TCL_OK;
}
}
if ((len == 0) || ((len > 7) && (optionName[1] == 'b') &&
(strncmp(optionName, "-buffersize", len) == 0))) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-buffersize");
}
TclFormatInt(optionVal, statePtr->bufSize);
Tcl_DStringAppendElement(dsPtr, optionVal);
if (len > 0) {
return TCL_OK;
}
}
if ((len == 0) ||
((len > 2) && (optionName[1] == 'e') &&
(strncmp(optionName, "-encoding", len) == 0))) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-encoding");
}
if (statePtr->encoding == NULL) {
Tcl_DStringAppendElement(dsPtr, "binary");
} else {
Tcl_DStringAppendElement(dsPtr,
Tcl_GetEncodingName(statePtr->encoding));
}
if (len > 0) {
return TCL_OK;
}
}
if ((len == 0) ||
((len > 2) && (optionName[1] == 'e') &&
(strncmp(optionName, "-eofchar", len) == 0))) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-eofchar");
}
if (((flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringStartSublist(dsPtr);
}
if (flags & TCL_READABLE) {
if (statePtr->inEofChar == 0) {
Tcl_DStringAppendElement(dsPtr, "");
} else {
char buf[4];
sprintf(buf, "%c", statePtr->inEofChar);
Tcl_DStringAppendElement(dsPtr, buf);
}
}
if (flags & TCL_WRITABLE) {
if (statePtr->outEofChar == 0) {
Tcl_DStringAppendElement(dsPtr, "");
} else {
char buf[4];
sprintf(buf, "%c", statePtr->outEofChar);
Tcl_DStringAppendElement(dsPtr, buf);
}
}
if ( !(flags & (TCL_READABLE|TCL_WRITABLE))) {
/* Not readable or writable (server socket) */
Tcl_DStringAppendElement(dsPtr, "");
}
if (((flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringEndSublist(dsPtr);
}
if (len > 0) {
return TCL_OK;
}
}
if ((len == 0) ||
((len > 1) && (optionName[1] == 't') &&
(strncmp(optionName, "-translation", len) == 0))) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-translation");
}
if (((flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringStartSublist(dsPtr);
}
if (flags & TCL_READABLE) {
if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) {
Tcl_DStringAppendElement(dsPtr, "auto");
} else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {
Tcl_DStringAppendElement(dsPtr, "cr");
} else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) {
Tcl_DStringAppendElement(dsPtr, "crlf");
} else {
Tcl_DStringAppendElement(dsPtr, "lf");
}
}
if (flags & TCL_WRITABLE) {
if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) {
Tcl_DStringAppendElement(dsPtr, "auto");
} else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) {
Tcl_DStringAppendElement(dsPtr, "cr");
} else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) {
Tcl_DStringAppendElement(dsPtr, "crlf");
} else {
Tcl_DStringAppendElement(dsPtr, "lf");
}
}
if ( !(flags & (TCL_READABLE|TCL_WRITABLE))) {
/* Not readable or writable (server socket) */
Tcl_DStringAppendElement(dsPtr, "auto");
}
if (((flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringEndSublist(dsPtr);
}
if (len > 0) {
return TCL_OK;
}
}
if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) {
/*
* let the driver specific handle additional options
* and result code and message.
*/
return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData,
interp, optionName, dsPtr);
} else {
/*
* no driver specific options case.
*/
if (len == 0) {
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName, NULL);
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_SetChannelOption --
*
* Sets an option on a channel.
*
* Results:
* A standard Tcl result. On error, sets interp's result object
* if interp is not NULL.
*
* Side effects:
* May modify an option on a device.
*
*---------------------------------------------------------------------------
*/
int
Tcl_SetChannelOption(interp, chan, optionName, newValue)
Tcl_Interp *interp; /* For error reporting - can be NULL. */
Tcl_Channel chan; /* Channel on which to set mode. */
CONST char *optionName; /* Which option to set? */
CONST char *newValue; /* New value for option. */
{
Channel *chanPtr = (Channel *) chan; /* The real IO channel. */
ChannelState *statePtr = chanPtr->state; /* state info for channel */
size_t len; /* Length of optionName string. */
int argc;
CONST char **argv;
/*
* If the channel is in the middle of a background copy, fail.
*/
if (statePtr->csPtrR || statePtr->csPtrW) {
if (interp) {
Tcl_AppendResult(interp,
"unable to set channel options: background copy in progress",
(char *) NULL);
}
return TCL_ERROR;
}
/*
* Disallow options on dead channels -- channels that have been closed but
* not yet been deallocated. Such channels can be found if the exit
* handler for channel cleanup has run but the channel is still
* registered in an interpreter.
*/
if (CheckForDeadChannel(NULL, statePtr)) {
return TCL_ERROR;
}
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
len = strlen(optionName);
if ((len > 2) && (optionName[1] == 'b') &&
(strncmp(optionName, "-blocking", len) == 0)) {
int newMode;
if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) {
return TCL_ERROR;
}
if (newMode) {
newMode = TCL_MODE_BLOCKING;
} else {
newMode = TCL_MODE_NONBLOCKING;
}
return SetBlockMode(interp, chanPtr, newMode);
} else if ((len > 7) && (optionName[1] == 'b') &&
(strncmp(optionName, "-buffering", len) == 0)) {
len = strlen(newValue);
if ((newValue[0] == 'f') && (strncmp(newValue, "full", len) == 0)) {
statePtr->flags &=
(~(CHANNEL_UNBUFFERED|CHANNEL_LINEBUFFERED));
} else if ((newValue[0] == 'l') &&
(strncmp(newValue, "line", len) == 0)) {
statePtr->flags &= (~(CHANNEL_UNBUFFERED));
statePtr->flags |= CHANNEL_LINEBUFFERED;
} else if ((newValue[0] == 'n') &&
(strncmp(newValue, "none", len) == 0)) {
statePtr->flags &= (~(CHANNEL_LINEBUFFERED));
statePtr->flags |= CHANNEL_UNBUFFERED;
} else {
if (interp) {
Tcl_AppendResult(interp, "bad value for -buffering: ",
"must be one of full, line, or none",
(char *) NULL);
return TCL_ERROR;
}
}
return TCL_OK;
} else if ((len > 7) && (optionName[1] == 'b') &&
(strncmp(optionName, "-buffersize", len) == 0)) {
int newBufferSize;
if (Tcl_GetInt(interp, newValue, &newBufferSize) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_SetChannelBufferSize(chan, newBufferSize);
} else if ((len > 2) && (optionName[1] == 'e') &&
(strncmp(optionName, "-encoding", len) == 0)) {
Tcl_Encoding encoding;
if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) {
encoding = NULL;
} else {
encoding = Tcl_GetEncoding(interp, newValue);
if (encoding == NULL) {
return TCL_ERROR;
}
}
/*
* When the channel has an escape sequence driven encoding such as
* iso2022, the terminated escape sequence must write to the buffer.
*/
if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)
&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
statePtr->outputEncodingFlags |= TCL_ENCODING_END;
WriteChars(chanPtr, "", 0);
}
Tcl_FreeEncoding(statePtr->encoding);
statePtr->encoding = encoding;
statePtr->inputEncodingState = NULL;
statePtr->inputEncodingFlags = TCL_ENCODING_START;
statePtr->outputEncodingState = NULL;
statePtr->outputEncodingFlags = TCL_ENCODING_START;
statePtr->flags &= ~CHANNEL_NEED_MORE_DATA;
UpdateInterest(chanPtr);
} else if ((len > 2) && (optionName[1] == 'e') &&
(strncmp(optionName, "-eofchar", len) == 0)) {
if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if (argc == 0) {
statePtr->inEofChar = 0;
statePtr->outEofChar = 0;
} else if (argc == 1) {
if (statePtr->flags & TCL_WRITABLE) {
statePtr->outEofChar = (int) argv[0][0];
}
if (statePtr->flags & TCL_READABLE) {
statePtr->inEofChar = (int) argv[0][0];
}
} else if (argc != 2) {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -eofchar: should be a list of zero,",
" one, or two elements", (char *) NULL);
}
ckfree((char *) argv);
return TCL_ERROR;
} else {
if (statePtr->flags & TCL_READABLE) {
statePtr->inEofChar = (int) argv[0][0];
}
if (statePtr->flags & TCL_WRITABLE) {
statePtr->outEofChar = (int) argv[1][0];
}
}
if (argv != NULL) {
ckfree((char *) argv);
}
/*
* [SF Tcl Bug 930851] Reset EOF and BLOCKED flags. Changing
* the character which signals eof can transform a current eof
* condition into a 'go ahead'. Ditto for blocked.
*/
statePtr->flags &= (~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED));
return TCL_OK;
} else if ((len > 1) && (optionName[1] == 't') &&
(strncmp(optionName, "-translation", len) == 0)) {
CONST char *readMode, *writeMode;
if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if (argc == 1) {
readMode = (statePtr->flags & TCL_READABLE) ? argv[0] : NULL;
writeMode = (statePtr->flags & TCL_WRITABLE) ? argv[0] : NULL;
} else if (argc == 2) {
readMode = (statePtr->flags & TCL_READABLE) ? argv[0] : NULL;
writeMode = (statePtr->flags & TCL_WRITABLE) ? argv[1] : NULL;
} else {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -translation: must be a one or two",
" element list", (char *) NULL);
}
ckfree((char *) argv);
return TCL_ERROR;
}
if (readMode) {
TclEolTranslation translation;
if (*readMode == '\0') {
translation = statePtr->inputTranslation;
} else if (strcmp(readMode, "auto") == 0) {
translation = TCL_TRANSLATE_AUTO;
} else if (strcmp(readMode, "binary") == 0) {
translation = TCL_TRANSLATE_LF;
statePtr->inEofChar = 0;
Tcl_FreeEncoding(statePtr->encoding);
statePtr->encoding = NULL;
} else if (strcmp(readMode, "lf") == 0) {
translation = TCL_TRANSLATE_LF;
} else if (strcmp(readMode, "cr") == 0) {
translation = TCL_TRANSLATE_CR;
} else if (strcmp(readMode, "crlf") == 0) {
translation = TCL_TRANSLATE_CRLF;
} else if (strcmp(readMode, "platform") == 0) {
translation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -translation: ",
"must be one of auto, binary, cr, lf, crlf,",
" or platform", (char *) NULL);
}
ckfree((char *) argv);
return TCL_ERROR;
}
/*
* Reset the EOL flags since we need to look at any buffered
* data to see if the new translation mode allows us to
* complete the line.
*/
if (translation != statePtr->inputTranslation) {
statePtr->inputTranslation = translation;
statePtr->flags &= ~(INPUT_SAW_CR);
statePtr->flags &= ~(CHANNEL_NEED_MORE_DATA);
UpdateInterest(chanPtr);
}
}
if (writeMode) {
if (*writeMode == '\0') {
/* Do nothing. */
} else if (strcmp(writeMode, "auto") == 0) {
/*
* This is a hack to get TCP sockets to produce output
* in CRLF mode if they are being set into AUTO mode.
* A better solution for achieving this effect will be
* coded later.
*/
if (strcmp(Tcl_ChannelName(chanPtr->typePtr), "tcp") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
} else {
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
}
} else if (strcmp(writeMode, "binary") == 0) {
statePtr->outEofChar = 0;
statePtr->outputTranslation = TCL_TRANSLATE_LF;
Tcl_FreeEncoding(statePtr->encoding);
statePtr->encoding = NULL;
} else if (strcmp(writeMode, "lf") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_LF;
} else if (strcmp(writeMode, "cr") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_CR;
} else if (strcmp(writeMode, "crlf") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
} else if (strcmp(writeMode, "platform") == 0) {
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -translation: ",
"must be one of auto, binary, cr, lf, crlf,",
" or platform", (char *) NULL);
}
ckfree((char *) argv);
return TCL_ERROR;
}
}
ckfree((char *) argv);
return TCL_OK;
} else if (chanPtr->typePtr->setOptionProc != NULL) {
return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData,
interp, optionName, newValue);
} else {
return Tcl_BadChannelOption(interp, optionName, (char *) NULL);
}
/*
* If bufsize changes, need to get rid of old utility buffer.
*/
if (statePtr->saveInBufPtr != NULL) {
RecycleBuffer(statePtr, statePtr->saveInBufPtr, 1);
statePtr->saveInBufPtr = NULL;
}
if (statePtr->inQueueHead != NULL) {
if ((statePtr->inQueueHead->nextPtr == NULL)
&& (statePtr->inQueueHead->nextAdded ==
statePtr->inQueueHead->nextRemoved)) {
RecycleBuffer(statePtr, statePtr->inQueueHead, 1);
statePtr->inQueueHead = NULL;
statePtr->inQueueTail = NULL;
}
}
/*
* If encoding or bufsize changes, need to update output staging buffer.
*/
if (statePtr->outputStage != NULL) {
ckfree((char *) statePtr->outputStage);
statePtr->outputStage = NULL;
}
if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
statePtr->outputStage = (char *)
ckalloc((unsigned) (statePtr->bufSize + 2));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* CleanupChannelHandlers --
*
* Removes channel handlers that refer to the supplied interpreter,
* so that if the actual channel is not closed now, these handlers
* will not run on subsequent events on the channel. This would be
* erroneous, because the interpreter no longer has a reference to
* this channel.
*
* Results:
* None.
*
* Side effects:
* Removes channel handlers.
*
*----------------------------------------------------------------------
*/
static void
CleanupChannelHandlers(interp, chanPtr)
Tcl_Interp *interp;
Channel *chanPtr;
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
EventScriptRecord *sPtr, *prevPtr, *nextPtr;
/*
* Remove fileevent records on this channel that refer to the
* given interpreter.
*/
for (sPtr = statePtr->scriptRecordPtr,
prevPtr = (EventScriptRecord *) NULL;
sPtr != (EventScriptRecord *) NULL;
sPtr = nextPtr) {
nextPtr = sPtr->nextPtr;
if (sPtr->interp == interp) {
if (prevPtr == (EventScriptRecord *) NULL) {
statePtr->scriptRecordPtr = nextPtr;
} else {
prevPtr->nextPtr = nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, (ClientData) sPtr);
Tcl_DecrRefCount(sPtr->scriptPtr);
ckfree((char *) sPtr);
} else {
prevPtr = sPtr;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_NotifyChannel --
*
* This procedure is called by a channel driver when a driver
* detects an event on a channel. This procedure is responsible
* for actually handling the event by invoking any channel
* handler callbacks.
*
* Results:
* None.
*
* Side effects:
* Whatever the channel handler callback procedure does.
*
*----------------------------------------------------------------------
*/
void
Tcl_NotifyChannel(channel, mask)
Tcl_Channel channel; /* Channel that detected an event. */
int mask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which events were detected. */
{
Channel *chanPtr = (Channel *) channel;
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelHandler *chPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
NextChannelHandler nh;
Channel* upChanPtr;
Tcl_ChannelType* upTypePtr;
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
/* [SF Tcl Bug 943274]
* For a non-blocking channel without blockmodeproc we keep track
* of actual input coming from the OS so that we can do a credible
* imitation of non-blocking behaviour.
*/
if ((mask & TCL_READABLE) &&
(statePtr->flags & CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
!(statePtr->flags & CHANNEL_TIMER_FEV)) {
statePtr->flags |= CHANNEL_HAS_MORE_DATA;
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
/*
* In contrast to the other API functions this procedure walks towards
* the top of a stack and not down from it.
*
* The channel calling this procedure is the one who generated the event,
* and thus does not take part in handling it. IOW, its HandlerProc is
* not called, instead we begin with the channel above it.
*
* This behaviour also allows the transformation channels to
* generate their own events and pass them upward.
*/
while (mask && (chanPtr->upChanPtr != ((Channel*) NULL))) {
Tcl_DriverHandlerProc* upHandlerProc;
upChanPtr = chanPtr->upChanPtr;
upTypePtr = upChanPtr->typePtr;
upHandlerProc = Tcl_ChannelHandlerProc(upTypePtr);
if (upHandlerProc != NULL) {
mask = (*upHandlerProc) (upChanPtr->instanceData, mask);
}
/* ELSE:
* Ignore transformations which are unable to handle the event
* coming from below. Assume that they don't change the mask and
* pass it on.
*/
chanPtr = upChanPtr;
}
channel = (Tcl_Channel) chanPtr;
/*
* Here we have either reached the top of the stack or the mask is
* empty. We break out of the procedure if it is the latter.
*/
if (!mask) {
return;
}
/*
* We are now above the topmost channel in a stack and have events
* left. Now call the channel handlers as usual.
*
* Preserve the channel struct in case the script closes it.
*/
Tcl_Preserve((ClientData) channel);
Tcl_Preserve((ClientData) statePtr);
/*
* If we are flushing in the background, be sure to call FlushChannel
* for writable events. Note that we have to discard the writable
* event so we don't call any write handlers before the flush is
* complete.
*/
if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
FlushChannel(NULL, chanPtr, 1);
mask &= ~TCL_WRITABLE;
}
/*
* Add this invocation to the list of recursive invocations of
* ChannelHandlerEventProc.
*/
nh.nextHandlerPtr = (ChannelHandler *) NULL;
nh.nestedHandlerPtr = tsdPtr->nestedHandlerPtr;
tsdPtr->nestedHandlerPtr = &nh;
for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; ) {
/*
* If this channel handler is interested in any of the events that
* have occurred on the channel, invoke its procedure.
*/
if ((chPtr->mask & mask) != 0) {
nh.nextHandlerPtr = chPtr->nextPtr;
(*(chPtr->proc))(chPtr->clientData, mask);
chPtr = nh.nextHandlerPtr;
} else {
chPtr = chPtr->nextPtr;
}
}
/*
* Update the notifier interest, since it may have changed after
* invoking event handlers. Skip that if the channel was deleted
* in the call to the channel handler.
*/
if (chanPtr->typePtr != NULL) {
UpdateInterest(chanPtr);
}
Tcl_Release((ClientData) statePtr);
Tcl_Release((ClientData) channel);
tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
}
/*
*----------------------------------------------------------------------
*
* UpdateInterest --
*
* Arrange for the notifier to call us back at appropriate times
* based on the current state of the channel.
*
* Results:
* None.
*
* Side effects:
* May schedule a timer or driver handler.
*
*----------------------------------------------------------------------
*/
static void
UpdateInterest(chanPtr)
Channel *chanPtr; /* Channel to update. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
int mask = statePtr->interestMask;
/*
* If there are flushed buffers waiting to be written, then
* we need to watch for the channel to become writable.
*/
if (statePtr->flags & BG_FLUSH_SCHEDULED) {
mask |= TCL_WRITABLE;
}
/*
* If there is data in the input queue, and we aren't waiting for more
* data, then we need to schedule a timer so we don't block in the
* notifier. Also, cancel the read interest so we don't get duplicate
* events.
*/
if (mask & TCL_READABLE) {
if (!(statePtr->flags & CHANNEL_NEED_MORE_DATA)
&& (statePtr->inQueueHead != (ChannelBuffer *) NULL)
&& (statePtr->inQueueHead->nextRemoved <
statePtr->inQueueHead->nextAdded)) {
mask &= ~TCL_READABLE;
/*
* Andreas Kupries, April 11, 2003
*
* Some operating systems (Solaris 2.6 and higher (but not
* Solaris 2.5, go figure)) generate READABLE and
* EXCEPTION events when select()'ing [*] on a plain file,
* even if EOF was not yet reached. This is a problem in
* the following situation:
*
* - An extension asks to get both READABLE and EXCEPTION
* events.
* - It reads data into a buffer smaller than the buffer
* used by Tcl itself.
* - It does not process all events in the event queue, but
* only only one, at least in some situations.
*
* In that case we can get into a situation where
*
* - Tcl drops READABLE here, because it has data in its own
* buffers waiting to be read by the extension.
* - A READABLE event is syntesized via timer.
* - The OS still reports the EXCEPTION condition on the file.
* - And the extension gets the EXCPTION event first, and
* handles this as EOF.
*
* End result ==> Premature end of reading from a file.
*
* The concrete example is 'Expect', and its [expect]
* command (and at the C-level, deep in the bowels of
* Expect, 'exp_get_next_event'. See marker 'SunOS' for
* commentary in that function too).
*
* [*] As the Tcl notifier does. See also for marker
* 'SunOS' in file 'exp_event.c' of Expect.
*
* Our solution here is to drop the interest in the
* EXCEPTION events too. This compiles on all platforms,
* and also passes the testsuite on all of them.
*/
mask &= ~TCL_EXCEPTION;
if (!statePtr->timer) {
statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
(ClientData) chanPtr);
}
}
}
(chanPtr->typePtr->watchProc)(chanPtr->instanceData, mask);
}
/*
*----------------------------------------------------------------------
*
* ChannelTimerProc --
*
* Timer handler scheduled by UpdateInterest to monitor the
* channel buffers until they are empty.
*
* Results:
* None.
*
* Side effects:
* May invoke channel handlers.
*
*----------------------------------------------------------------------
*/
static void
ChannelTimerProc(clientData)
ClientData clientData;
{
Channel *chanPtr = (Channel *) clientData;
ChannelState *statePtr = chanPtr->state; /* state info for channel */
if (!(statePtr->flags & CHANNEL_NEED_MORE_DATA)
&& (statePtr->interestMask & TCL_READABLE)
&& (statePtr->inQueueHead != (ChannelBuffer *) NULL)
&& (statePtr->inQueueHead->nextRemoved <
statePtr->inQueueHead->nextAdded)) {
/*
* Restart the timer in case a channel handler reenters the
* event loop before UpdateInterest gets called by Tcl_NotifyChannel.
*/
statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
(ClientData) chanPtr);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
/* Set the TIMER flag to notify the higher levels that the
* driver might have no data for us. We do this only if we are
* in non-blocking mode and the driver has no BlockModeProc
* because only then we really don't know if the driver will
* block or not. A similar test is done in "PeekAhead".
*/
if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) {
statePtr->flags |= CHANNEL_TIMER_FEV;
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
Tcl_Preserve((ClientData) statePtr);
Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
statePtr->flags &= ~CHANNEL_TIMER_FEV;
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
Tcl_Release((ClientData) statePtr);
} else {
statePtr->timer = NULL;
UpdateInterest(chanPtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateChannelHandler --
*
* Arrange for a given procedure to be invoked whenever the
* channel indicated by the chanPtr arg becomes readable or
* writable.
*
* Results:
* None.
*
* Side effects:
* From now on, whenever the I/O channel given by chanPtr becomes
* ready in the way indicated by mask, proc will be invoked.
* See the manual entry for details on the calling sequence
* to proc. If there is already an event handler for chan, proc
* and clientData, then the mask will be updated.
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateChannelHandler(chan, mask, proc, clientData)
Tcl_Channel chan; /* The channel to create the handler for. */
int mask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION:
* indicates conditions under which
* proc should be called. Use 0 to
* disable a registered handler. */
Tcl_ChannelProc *proc; /* Procedure to call for each
* selected event. */
ClientData clientData; /* Arbitrary data to pass to proc. */
{
ChannelHandler *chPtr;
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state; /* state info for channel */
/*
* Check whether this channel handler is not already registered. If
* it is not, create a new record, else reuse existing record (smash
* current values).
*/
for (chPtr = statePtr->chPtr;
chPtr != (ChannelHandler *) NULL;
chPtr = chPtr->nextPtr) {
if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) &&
(chPtr->clientData == clientData)) {
break;
}
}
if (chPtr == (ChannelHandler *) NULL) {
chPtr = (ChannelHandler *) ckalloc((unsigned) sizeof(ChannelHandler));
chPtr->mask = 0;
chPtr->proc = proc;
chPtr->clientData = clientData;
chPtr->chanPtr = chanPtr;
chPtr->nextPtr = statePtr->chPtr;
statePtr->chPtr = chPtr;
}
/*
* The remainder of the initialization below is done regardless of
* whether or not this is a new record or a modification of an old
* one.
*/
chPtr->mask = mask;
/*
* Recompute the interest mask for the channel - this call may actually
* be disabling an existing handler.
*/
statePtr->interestMask = 0;
for (chPtr = statePtr->chPtr;
chPtr != (ChannelHandler *) NULL;
chPtr = chPtr->nextPtr) {
statePtr->interestMask |= chPtr->mask;
}
UpdateInterest(statePtr->topChanPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteChannelHandler --
*
* Cancel a previously arranged callback arrangement for an IO
* channel.
*
* Results:
* None.
*
* Side effects:
* If a callback was previously registered for this chan, proc and
* clientData , it is removed and the callback will no longer be called
* when the channel becomes ready for IO.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteChannelHandler(chan, proc, clientData)
Tcl_Channel chan; /* The channel for which to remove the
* callback. */
Tcl_ChannelProc *proc; /* The procedure in the callback to delete. */
ClientData clientData; /* The client data in the callback
* to delete. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ChannelHandler *chPtr, *prevChPtr;
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state; /* state info for channel */
NextChannelHandler *nhPtr;
/*
* Find the entry and the previous one in the list.
*/
for (prevChPtr = (ChannelHandler *) NULL, chPtr = statePtr->chPtr;
chPtr != (ChannelHandler *) NULL;
chPtr = chPtr->nextPtr) {
if ((chPtr->chanPtr == chanPtr) && (chPtr->clientData == clientData)
&& (chPtr->proc == proc)) {
break;
}
prevChPtr = chPtr;
}
/*
* If not found, return without doing anything.
*/
if (chPtr == (ChannelHandler *) NULL) {
return;
}
/*
* If ChannelHandlerEventProc is about to process this handler, tell it to
* process the next one instead - we are going to delete *this* one.
*/
for (nhPtr = tsdPtr->nestedHandlerPtr;
nhPtr != (NextChannelHandler *) NULL;
nhPtr = nhPtr->nestedHandlerPtr) {
if (nhPtr->nextHandlerPtr == chPtr) {
nhPtr->nextHandlerPtr = chPtr->nextPtr;
}
}
/*
* Splice it out of the list of channel handlers.
*/
if (prevChPtr == (ChannelHandler *) NULL) {
statePtr->chPtr = chPtr->nextPtr;
} else {
prevChPtr->nextPtr = chPtr->nextPtr;
}
ckfree((char *) chPtr);
/*
* Recompute the interest list for the channel, so that infinite loops
* will not result if Tcl_DeleteChannelHandler is called inside an
* event.
*/
statePtr->interestMask = 0;
for (chPtr = statePtr->chPtr;
chPtr != (ChannelHandler *) NULL;
chPtr = chPtr->nextPtr) {
statePtr->interestMask |= chPtr->mask;
}
UpdateInterest(statePtr->topChanPtr);
}
/*
*----------------------------------------------------------------------
*
* DeleteScriptRecord --
*
* Delete a script record for this combination of channel, interp
* and mask.
*
* Results:
* None.
*
* Side effects:
* Deletes a script record and cancels a channel event handler.
*
*----------------------------------------------------------------------
*/
static void
DeleteScriptRecord(interp, chanPtr, mask)
Tcl_Interp *interp; /* Interpreter in which script was to be
* executed. */
Channel *chanPtr; /* The channel for which to delete the
* script record (if any). */
int mask; /* Events in mask must exactly match mask
* of script to delete. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
EventScriptRecord *esPtr, *prevEsPtr;
for (esPtr = statePtr->scriptRecordPtr,
prevEsPtr = (EventScriptRecord *) NULL;
esPtr != (EventScriptRecord *) NULL;
prevEsPtr = esPtr, esPtr = esPtr->nextPtr) {
if ((esPtr->interp == interp) && (esPtr->mask == mask)) {
if (esPtr == statePtr->scriptRecordPtr) {
statePtr->scriptRecordPtr = esPtr->nextPtr;
} else {
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, (ClientData) esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree((char *) esPtr);
break;
}
}
}
/*
*----------------------------------------------------------------------
*
* CreateScriptRecord --
*
* Creates a record to store a script to be executed when a specific
* event fires on a specific channel.
*
* Results:
* None.
*
* Side effects:
* Causes the script to be stored for later execution.
*
*----------------------------------------------------------------------
*/
static void
CreateScriptRecord(interp, chanPtr, mask, scriptPtr)
Tcl_Interp *interp; /* Interpreter in which to execute
* the stored script. */
Channel *chanPtr; /* Channel for which script is to
* be stored. */
int mask; /* Set of events for which script
* will be invoked. */
Tcl_Obj *scriptPtr; /* Pointer to script object. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
EventScriptRecord *esPtr;
for (esPtr = statePtr->scriptRecordPtr;
esPtr != (EventScriptRecord *) NULL;
esPtr = esPtr->nextPtr) {
if ((esPtr->interp == interp) && (esPtr->mask == mask)) {
Tcl_DecrRefCount(esPtr->scriptPtr);
esPtr->scriptPtr = (Tcl_Obj *) NULL;
break;
}
}
if (esPtr == (EventScriptRecord *) NULL) {
esPtr = (EventScriptRecord *) ckalloc((unsigned)
sizeof(EventScriptRecord));
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
TclChannelEventScriptInvoker, (ClientData) esPtr);
esPtr->nextPtr = statePtr->scriptRecordPtr;
statePtr->scriptRecordPtr = esPtr;
}
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
Tcl_IncrRefCount(scriptPtr);
esPtr->scriptPtr = scriptPtr;
}
/*
*----------------------------------------------------------------------
*
* TclChannelEventScriptInvoker --
*
* Invokes a script scheduled by "fileevent" for when the channel
* becomes ready for IO. This function is invoked by the channel
* handler which was created by the Tcl "fileevent" command.
*
* Results:
* None.
*
* Side effects:
* Whatever the script does.
*
*----------------------------------------------------------------------
*/
void
TclChannelEventScriptInvoker(clientData, mask)
ClientData clientData; /* The script+interp record. */
int mask; /* Not used. */
{
Tcl_Interp *interp; /* Interpreter in which to eval the script. */
Channel *chanPtr; /* The channel for which this handler is
* registered. */
EventScriptRecord *esPtr; /* The event script + interpreter to eval it
* in. */
int result; /* Result of call to eval script. */
esPtr = (EventScriptRecord *) clientData;
chanPtr = esPtr->chanPtr;
mask = esPtr->mask;
interp = esPtr->interp;
/*
* We must preserve the interpreter so we can report errors on it
* later. Note that we do not need to preserve the channel because
* that is done by Tcl_NotifyChannel before calling channel handlers.
*/
Tcl_Preserve((ClientData) interp);
Tcl_Preserve((ClientData) chanPtr);
result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL);
/*
* On error, cause a background error and remove the channel handler
* and the script record.
*
* NOTE: Must delete channel handler before causing the background error
* because the background error may want to reinstall the handler.
*/
if (result != TCL_OK) {
if (chanPtr->typePtr != NULL) {
DeleteScriptRecord(interp, chanPtr, mask);
}
Tcl_BackgroundError(interp);
}
Tcl_Release((ClientData) chanPtr);
Tcl_Release((ClientData) interp);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FileEventObjCmd --
*
* This procedure implements the "fileevent" Tcl command. See the
* user documentation for details on what it does. This command is
* based on the Tk command "fileevent" which in turn is based on work
* contributed by Mark Diekhans.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May create a channel handler for the specified channel.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_FileEventObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter in which the channel
* for which to create the handler
* is found. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Channel *chanPtr; /* The channel to create
* the handler for. */
ChannelState *statePtr; /* state info for channel */
Tcl_Channel chan; /* The opaque type for the channel. */
char *chanName;
int modeIndex; /* Index of mode argument. */
int mask;
static CONST char *modeOptions[] = {"readable", "writable", NULL};
static CONST int maskArray[] = {TCL_READABLE, TCL_WRITABLE};
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], modeOptions, "event name", 0,
&modeIndex) != TCL_OK) {
return TCL_ERROR;
}
mask = maskArray[modeIndex];
chanName = Tcl_GetString(objv[1]);
chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
if ((statePtr->flags & mask) == 0) {
Tcl_AppendResult(interp, "channel is not ",
(mask == TCL_READABLE) ? "readable" : "writable",
(char *) NULL);
return TCL_ERROR;
}
/*
* If we are supposed to return the script, do so.
*/
if (objc == 3) {
EventScriptRecord *esPtr;
for (esPtr = statePtr->scriptRecordPtr;
esPtr != (EventScriptRecord *) NULL;
esPtr = esPtr->nextPtr) {
if ((esPtr->interp == interp) && (esPtr->mask == mask)) {
Tcl_SetObjResult(interp, esPtr->scriptPtr);
break;
}
}
return TCL_OK;
}
/*
* If we are supposed to delete a stored script, do so.
*/
if (*(Tcl_GetString(objv[3])) == '\0') {
DeleteScriptRecord(interp, chanPtr, mask);
return TCL_OK;
}
/*
* Make the script record that will link between the event and the
* script to invoke. This also creates a channel event handler which
* will evaluate the script in the supplied interpreter.
*/
CreateScriptRecord(interp, chanPtr, mask, objv[3]);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCopyChannel --
*
* This routine copies data from one channel to another, either
* synchronously or asynchronously. If a command script is
* supplied, the operation runs in the background. The script
* is invoked when the copy completes. Otherwise the function
* waits until the copy is completed before returning.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May schedule a background copy operation that causes both
* channels to be marked busy.
*
*----------------------------------------------------------------------
*/
int
TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Channel inChan; /* Channel to read from. */
Tcl_Channel outChan; /* Channel to write to. */
int toRead; /* Amount of data to copy, or -1 for all. */
Tcl_Obj *cmdPtr; /* Pointer to script to execute or NULL. */
{
Channel *inPtr = (Channel *) inChan;
Channel *outPtr = (Channel *) outChan;
ChannelState *inStatePtr, *outStatePtr;
int readFlags, writeFlags;
CopyState *csPtr;
int nonBlocking = (cmdPtr) ? CHANNEL_NONBLOCKING : 0;
inStatePtr = inPtr->state;
outStatePtr = outPtr->state;
if (BUSY_STATE(inStatePtr,TCL_READABLE)) {
if (interp) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
Tcl_GetChannelName(inChan), "\" is busy", NULL);
}
return TCL_ERROR;
}
if (BUSY_STATE(outStatePtr,TCL_WRITABLE)) {
if (interp) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
Tcl_GetChannelName(outChan), "\" is busy", NULL);
}
return TCL_ERROR;
}
readFlags = inStatePtr->flags;
writeFlags = outStatePtr->flags;
/*
* Set up the blocking mode appropriately. Background copies need
* non-blocking channels. Foreground copies need blocking channels.
* If there is an error, restore the old blocking mode.
*/
if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) {
if (SetBlockMode(interp, inPtr,
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING)
!= TCL_OK) {
return TCL_ERROR;
}
}
if (inPtr != outPtr) {
if (nonBlocking != (writeFlags & CHANNEL_NONBLOCKING)) {
if (SetBlockMode(NULL, outPtr,
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING)
!= TCL_OK) {
if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) {
SetBlockMode(NULL, inPtr,
(readFlags & CHANNEL_NONBLOCKING)
? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
return TCL_ERROR;
}
}
}
}
/*
* Make sure the output side is unbuffered.
*/
outStatePtr->flags = (outStatePtr->flags & ~(CHANNEL_LINEBUFFERED))
| CHANNEL_UNBUFFERED;
/*
* Allocate a new CopyState to maintain info about the current copy in
* progress. This structure will be deallocated when the copy is
* completed.
*/
csPtr = (CopyState*) ckalloc(sizeof(CopyState) + inStatePtr->bufSize);
csPtr->bufSize = inStatePtr->bufSize;
csPtr->readPtr = inPtr;
csPtr->writePtr = outPtr;
csPtr->readFlags = readFlags;
csPtr->writeFlags = writeFlags;
csPtr->toRead = toRead;
csPtr->total = 0;
csPtr->interp = interp;
if (cmdPtr) {
Tcl_IncrRefCount(cmdPtr);
}
csPtr->cmdPtr = cmdPtr;
inStatePtr->csPtrR = csPtr;
outStatePtr->csPtrW = csPtr;
/*
* Start copying data between the channels.
*/
return CopyData(csPtr, 0);
}
/*
*----------------------------------------------------------------------
*
* CopyData --
*
* This function implements the lowest level of the copying
* mechanism for TclCopyChannel.
*
* Results:
* Returns TCL_OK on success, else TCL_ERROR.
*
* Side effects:
* Moves data between channels, may create channel handlers.
*
*----------------------------------------------------------------------
*/
static int
CopyData(csPtr, mask)
CopyState *csPtr; /* State of copy operation. */
int mask; /* Current channel event flags. */
{
Tcl_Interp *interp;
Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL;
Tcl_Channel inChan, outChan;
ChannelState *inStatePtr, *outStatePtr;
int result = TCL_OK, size, total, sizeb;
char* buffer;
int inBinary, outBinary, sameEncoding; /* Encoding control */
int underflow; /* input underflow */
inChan = (Tcl_Channel) csPtr->readPtr;
outChan = (Tcl_Channel) csPtr->writePtr;
inStatePtr = csPtr->readPtr->state;
outStatePtr = csPtr->writePtr->state;
interp = csPtr->interp;
cmdPtr = csPtr->cmdPtr;
/*
* Copy the data the slow way, using the translation mechanism.
*
* Note: We have make sure that we use the topmost channel in a stack
* for the copying. The caller uses Tcl_GetChannel to access it, and
* thus gets the bottom of the stack.
*/
inBinary = (inStatePtr->encoding == NULL);
outBinary = (outStatePtr->encoding == NULL);
sameEncoding = (inStatePtr->encoding == outStatePtr->encoding);
if (!(inBinary || sameEncoding)) {
bufObj = Tcl_NewObj ();
Tcl_IncrRefCount (bufObj);
}
while (csPtr->toRead != 0) {
/*
* Check for unreported background errors.
*/
if (inStatePtr->unreportedError != 0) {
Tcl_SetErrno(inStatePtr->unreportedError);
inStatePtr->unreportedError = 0;
goto readError;
}
if (outStatePtr->unreportedError != 0) {
Tcl_SetErrno(outStatePtr->unreportedError);
outStatePtr->unreportedError = 0;
goto writeError;
}
if (cmdPtr && (mask == 0)) {
/*
* In async mode, we skip reading synchronously and fake an
* underflow instead to prime the readable fileevent.
*/
size = 0;
underflow = 1;
} else {
/*
* Read up to bufSize bytes.
*/
if ((csPtr->toRead == -1) || (csPtr->toRead > csPtr->bufSize)) {
sizeb = csPtr->bufSize;
} else {
sizeb = csPtr->toRead;
}
if (inBinary || sameEncoding) {
size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb);
} else {
size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */);
}
underflow = (size >= 0) && (size < sizeb); /* input underflow */
}
if (size < 0) {
readError:
errObj = Tcl_NewObj();
Tcl_AppendStringsToObj(errObj, "error reading \"",
Tcl_GetChannelName(inChan), "\": ",
Tcl_PosixError(interp), (char *) NULL);
break;
} else if (underflow) {
/*
* We had an underflow on the read side. If we are at
* EOF, and not in the synchronous part of an asynchronous
* fcopy, then the copying is done, otherwise set up a
* channel handler to detect when the channel becomes
* readable again.
*/
if ((size == 0) && Tcl_Eof(inChan) && !(cmdPtr && (mask == 0))) {
break;
}
if (((!Tcl_Eof(inChan)) || (cmdPtr && (mask == 0))) &&
!(mask & TCL_READABLE)) {
if (mask & TCL_WRITABLE) {
Tcl_DeleteChannelHandler(outChan, CopyEventProc,
(ClientData) csPtr);
}
Tcl_CreateChannelHandler(inChan, TCL_READABLE,
CopyEventProc, (ClientData) csPtr);
}
if (size == 0) {
if (bufObj != (Tcl_Obj*) NULL) {
Tcl_DecrRefCount (bufObj);
bufObj = (Tcl_Obj*) NULL;
}
return TCL_OK;
}
}
/*
* Now write the buffer out.
*/
if (inBinary || sameEncoding) {
buffer = csPtr->buffer;
sizeb = size;
} else {
buffer = Tcl_GetStringFromObj (bufObj, &sizeb);
}
if (outBinary || sameEncoding) {
sizeb = DoWrite(outStatePtr->topChanPtr, buffer, sizeb);
} else {
sizeb = DoWriteChars(outStatePtr->topChanPtr, buffer, sizeb);
}
/*
* [Bug 2895565]. At this point 'size' still contains the number of
* bytes or characters which have been read. We keep this to later to
* update the totals and toRead information, see marker (UP) below. We
* must not overwrite it with 'sizeb', which is the number of written
* bytes or characters, and both EOL translation and encoding
* conversion may have changed this number unpredictably in relation
* to 'size' (It can be smaller or larger, in the latter case able to
* drive toRead below -1, causing infinite looping). Completely
* unsuitable for updating totals and toRead.
*/
if (sizeb < 0) {
writeError:
errObj = Tcl_NewObj();
Tcl_AppendStringsToObj(errObj, "error writing \"",
Tcl_GetChannelName(outChan), "\": ",
Tcl_PosixError(interp), (char *) NULL);
break;
}
/*
* Update the current byte count. Do it now so the count is
* valid before a return or break takes us out of the loop.
* The invariant at the top of the loop should be that
* csPtr->toRead holds the number of bytes left to copy.
*/
if (csPtr->toRead != -1) {
csPtr->toRead -= size;
}
csPtr->total += size;
/*
* Break loop if EOF && (size>0)
*/
if (Tcl_Eof(inChan)) {
break;
}
/*
* Check to see if the write is happening in the background. If so,
* stop copying and wait for the channel to become writable again.
* After input underflow we already installed a readable handler
* therefore we don't need a writable handler.
*/
if ( ! underflow && (outStatePtr->flags & BG_FLUSH_SCHEDULED) ) {
if (!(mask & TCL_WRITABLE)) {
if (mask & TCL_READABLE) {
Tcl_DeleteChannelHandler(inChan, CopyEventProc,
(ClientData) csPtr);
}
Tcl_CreateChannelHandler(outChan, TCL_WRITABLE,
CopyEventProc, (ClientData) csPtr);
}
if (bufObj != (Tcl_Obj*) NULL) {
Tcl_DecrRefCount (bufObj);
bufObj = (Tcl_Obj*) NULL;
}
return TCL_OK;
}
/*
* For background copies, we only do one buffer per invocation so
* we don't starve the rest of the system.
*/
if (cmdPtr && (csPtr->toRead != 0)) {
/*
* The first time we enter this code, there won't be a
* channel handler established yet, so do it here.
*/
if (mask == 0) {
Tcl_CreateChannelHandler(outChan, TCL_WRITABLE,
CopyEventProc, (ClientData) csPtr);
}
if (bufObj != (Tcl_Obj*) NULL) {
Tcl_DecrRefCount (bufObj);
bufObj = (Tcl_Obj*) NULL;
}
return TCL_OK;
}
} /* while */
if (bufObj != (Tcl_Obj*) NULL) {
Tcl_DecrRefCount (bufObj);
bufObj = (Tcl_Obj*) NULL;
}
/*
* Make the callback or return the number of bytes transferred.
* The local total is used because StopCopy frees csPtr.
*/
total = csPtr->total;
if (cmdPtr && interp) {
/*
* Get a private copy of the command so we can mutate it
* by adding arguments. Note that StopCopy frees our saved
* reference to the original command obj.
*/
cmdPtr = Tcl_DuplicateObj(cmdPtr);
Tcl_IncrRefCount(cmdPtr);
StopCopy(csPtr);
Tcl_Preserve((ClientData) interp);
Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(total));
if (errObj) {
Tcl_ListObjAppendElement(interp, cmdPtr, errObj);
}
if (Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) {
Tcl_BackgroundError(interp);
result = TCL_ERROR;
}
Tcl_DecrRefCount(cmdPtr);
Tcl_Release((ClientData) interp);
} else {
StopCopy(csPtr);
if (interp) {
if (errObj) {
Tcl_SetObjResult(interp, errObj);
result = TCL_ERROR;
} else {
Tcl_ResetResult(interp);
Tcl_SetIntObj(Tcl_GetObjResult(interp), total);
}
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* DoRead --
*
* Reads a given number of bytes from a channel.
*
* No encoding conversions are applied to the bytes being read.
*
* Results:
* The number of characters read, or -1 on error. Use Tcl_GetErrno()
* to retrieve the error code for the error that occurred.
*
* Side effects:
* May cause input to be buffered.
*
*----------------------------------------------------------------------
*/
static int
DoRead(chanPtr, bufPtr, toRead)
Channel *chanPtr; /* The channel from which to read. */
char *bufPtr; /* Where to store input read. */
int toRead; /* Maximum number of bytes to read. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
int copied; /* How many characters were copied into
* the result string? */
int copiedNow; /* How many characters were copied from
* the current input buffer? */
int result; /* Of calling GetInput. */
/*
* If we have not encountered a sticky EOF, clear the EOF bit. Either
* way clear the BLOCKED bit. We want to discover these anew during
* each operation.
*/
if (!(statePtr->flags & CHANNEL_STICKY_EOF)) {
statePtr->flags &= ~CHANNEL_EOF;
}
statePtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);
for (copied = 0; copied < toRead; copied += copiedNow) {
copiedNow = CopyAndTranslateBuffer(statePtr, bufPtr + copied,
toRead - copied);
if (copiedNow == 0) {
if (statePtr->flags & CHANNEL_EOF) {
goto done;
}
if (statePtr->flags & CHANNEL_BLOCKED) {
if (statePtr->flags & CHANNEL_NONBLOCKING) {
goto done;
}
statePtr->flags &= (~(CHANNEL_BLOCKED));
}
result = GetInput(chanPtr);
if (result != 0) {
if (result != EAGAIN) {
copied = -1;
}
goto done;
}
}
}
statePtr->flags &= (~(CHANNEL_BLOCKED));
done:
/*
* Update the notifier state so we don't block while there is still
* data in the buffers.
*/
UpdateInterest(chanPtr);
return copied;
}
/*
*----------------------------------------------------------------------
*
* CopyAndTranslateBuffer --
*
* Copy at most one buffer of input to the result space, doing
* eol translations according to mode in effect currently.
*
* Results:
* Number of bytes stored in the result buffer (as opposed to the
* number of bytes read from the channel). May return
* zero if no input is available to be translated.
*
* Side effects:
* Consumes buffered input. May deallocate one buffer.
*
*----------------------------------------------------------------------
*/
static int
CopyAndTranslateBuffer(statePtr, result, space)
ChannelState *statePtr; /* Channel state from which to read input. */
char *result; /* Where to store the copied input. */
int space; /* How many bytes are available in result
* to store the copied input? */
{
ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */
int bytesInBuffer; /* How many bytes are available to be
* copied in the current input buffer? */
int copied; /* How many characters were already copied
* into the destination space? */
int i; /* Iterates over the copied input looking
* for the input eofChar. */
/*
* If there is no input at all, return zero. The invariant is that either
* there is no buffer in the queue, or if the first buffer is empty, it
* is also the last buffer (and thus there is no input in the queue).
* Note also that if the buffer is empty, we leave it in the queue.
*/
if (statePtr->inQueueHead == (ChannelBuffer *) NULL) {
return 0;
}
bufPtr = statePtr->inQueueHead;
bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved;
copied = 0;
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF: {
if (bytesInBuffer == 0) {
return 0;
}
/*
* Copy the current chunk into the result buffer.
*/
if (bytesInBuffer < space) {
space = bytesInBuffer;
}
memcpy((VOID *) result,
(VOID *) (bufPtr->buf + bufPtr->nextRemoved),
(size_t) space);
bufPtr->nextRemoved += space;
copied = space;
break;
}
case TCL_TRANSLATE_CR: {
char *end;
if (bytesInBuffer == 0) {
return 0;
}
/*
* Copy the current chunk into the result buffer, then
* replace all \r with \n.
*/
if (bytesInBuffer < space) {
space = bytesInBuffer;
}
memcpy((VOID *) result,
(VOID *) (bufPtr->buf + bufPtr->nextRemoved),
(size_t) space);
bufPtr->nextRemoved += space;
copied = space;
for (end = result + copied; result < end; result++) {
if (*result == '\r') {
*result = '\n';
}
}
break;
}
case TCL_TRANSLATE_CRLF: {
char *src, *end, *dst;
int curByte;
/*
* If there is a held-back "\r" at EOF, produce it now.
*/
if (bytesInBuffer == 0) {
if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) ==
(INPUT_SAW_CR | CHANNEL_EOF)) {
result[0] = '\r';
statePtr->flags &= ~INPUT_SAW_CR;
return 1;
}
return 0;
}
/*
* Copy the current chunk and replace "\r\n" with "\n"
* (but not standalone "\r"!).
*/
if (bytesInBuffer < space) {
space = bytesInBuffer;
}
memcpy((VOID *) result,
(VOID *) (bufPtr->buf + bufPtr->nextRemoved),
(size_t) space);
bufPtr->nextRemoved += space;
copied = space;
end = result + copied;
dst = result;
for (src = result; src < end; src++) {
curByte = *src;
if (curByte == '\n') {
statePtr->flags &= ~INPUT_SAW_CR;
} else if (statePtr->flags & INPUT_SAW_CR) {
statePtr->flags &= ~INPUT_SAW_CR;
*dst = '\r';
dst++;
}
if (curByte == '\r') {
statePtr->flags |= INPUT_SAW_CR;
} else {
*dst = (char) curByte;
dst++;
}
}
copied = dst - result;
break;
}
case TCL_TRANSLATE_AUTO: {
char *src, *end, *dst;
int curByte;
if (bytesInBuffer == 0) {
return 0;
}
/*
* Loop over the current buffer, converting "\r" and "\r\n"
* to "\n".
*/
if (bytesInBuffer < space) {
space = bytesInBuffer;
}
memcpy((VOID *) result,
(VOID *) (bufPtr->buf + bufPtr->nextRemoved),
(size_t) space);
bufPtr->nextRemoved += space;
copied = space;
end = result + copied;
dst = result;
for (src = result; src < end; src++) {
curByte = *src;
if (curByte == '\r') {
statePtr->flags |= INPUT_SAW_CR;
*dst = '\n';
dst++;
} else {
if ((curByte != '\n') ||
!(statePtr->flags & INPUT_SAW_CR)) {
*dst = (char) curByte;
dst++;
}
statePtr->flags &= ~INPUT_SAW_CR;
}
}
copied = dst - result;
break;
}
default: {
panic("unknown eol translation mode");
}
}
/*
* If an in-stream EOF character is set for this channel, check that
* the input we copied so far does not contain the EOF char. If it does,
* copy only up to and excluding that character.
*/
if (statePtr->inEofChar != 0) {
for (i = 0; i < copied; i++) {
if (result[i] == (char) statePtr->inEofChar) {
/*
* Set sticky EOF so that no further input is presented
* to the caller.
*/
statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
copied = i;
break;
}
}
}
/*
* If the current buffer is empty recycle it.
*/
if (bufPtr->nextRemoved == bufPtr->nextAdded) {
statePtr->inQueueHead = bufPtr->nextPtr;
if (statePtr->inQueueHead == (ChannelBuffer *) NULL) {
statePtr->inQueueTail = (ChannelBuffer *) NULL;
}
RecycleBuffer(statePtr, bufPtr, 0);
}
/*
* Return the number of characters copied into the result buffer.
* This may be different from the number of bytes consumed, because
* of EOL translations.
*/
return copied;
}
/*
*----------------------------------------------------------------------
*
* CopyBuffer --
*
* Copy at most one buffer of input to the result space.
*
* Results:
* Number of bytes stored in the result buffer. May return
* zero if no input is available.
*
* Side effects:
* Consumes buffered input. May deallocate one buffer.
*
*----------------------------------------------------------------------
*/
static int
CopyBuffer(chanPtr, result, space)
Channel *chanPtr; /* Channel from which to read input. */
char *result; /* Where to store the copied input. */
int space; /* How many bytes are available in result
* to store the copied input? */
{
ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */
int bytesInBuffer; /* How many bytes are available to be
* copied in the current input buffer? */
int copied; /* How many characters were already copied
* into the destination space? */
/*
* If there is no input at all, return zero. The invariant is that
* either there is no buffer in the queue, or if the first buffer
* is empty, it is also the last buffer (and thus there is no
* input in the queue). Note also that if the buffer is empty, we
* don't leave it in the queue, but recycle it.
*/
if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) {
return 0;
}
bufPtr = chanPtr->inQueueHead;
bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved;
copied = 0;
if (bytesInBuffer == 0) {
RecycleBuffer(chanPtr->state, bufPtr, 0);
chanPtr->inQueueHead = (ChannelBuffer*) NULL;
chanPtr->inQueueTail = (ChannelBuffer*) NULL;
return 0;
}
/*
* Copy the current chunk into the result buffer.
*/
if (bytesInBuffer < space) {
space = bytesInBuffer;
}
memcpy((VOID *) result,
(VOID *) (bufPtr->buf + bufPtr->nextRemoved),
(size_t) space);
bufPtr->nextRemoved += space;
copied = space;
/*
* We don't care about in-stream EOF characters here as the data
* read here may still flow through one or more transformations,
* i.e. is not in its final state yet.
*/
/*
* If the current buffer is empty recycle it.
*/
if (bufPtr->nextRemoved == bufPtr->nextAdded) {
chanPtr->inQueueHead = bufPtr->nextPtr;
if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) {
chanPtr->inQueueTail = (ChannelBuffer *) NULL;
}
RecycleBuffer(chanPtr->state, bufPtr, 0);
}
/*
* Return the number of characters copied into the result buffer.
*/
return copied;
}
/*
*----------------------------------------------------------------------
*
* DoWrite --
*
* Puts a sequence of characters into an output buffer, may queue the
* buffer for output if it gets full, and also remembers whether the
* current buffer is ready e.g. if it contains a newline and we are in
* line buffering mode.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
* Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
static int
DoWrite(chanPtr, src, srcLen)
Channel *chanPtr; /* The channel to buffer output for. */
CONST char *src; /* Data to write. */
int srcLen; /* Number of bytes to write. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *outBufPtr; /* Current output buffer. */
int foundNewline; /* Did we find a newline in output? */
char *dPtr;
CONST char *sPtr; /* Search variables for newline. */
int crsent; /* In CRLF eol translation mode,
* remember the fact that a CR was
* output to the channel without
* its following NL. */
int i; /* Loop index for newline search. */
int destCopied; /* How many bytes were used in this
* destination buffer to hold the
* output? */
int totalDestCopied; /* How many bytes total were
* copied to the channel buffer? */
int srcCopied; /* How many bytes were copied from
* the source string? */
char *destPtr; /* Where in line to copy to? */
/*
* If we are in network (or windows) translation mode, record the fact
* that we have not yet sent a CR to the channel.
*/
crsent = 0;
/*
* Loop filling buffers and flushing them until all output has been
* consumed.
*/
srcCopied = 0;
totalDestCopied = 0;
while (srcLen > 0) {
/*
* Make sure there is a current output buffer to accept output.
*/
if (statePtr->curOutPtr == (ChannelBuffer *) NULL) {
statePtr->curOutPtr = AllocChannelBuffer(statePtr->bufSize);
}
outBufPtr = statePtr->curOutPtr;
destCopied = outBufPtr->bufLength - outBufPtr->nextAdded;
if (destCopied > srcLen) {
destCopied = srcLen;
}
destPtr = outBufPtr->buf + outBufPtr->nextAdded;
switch (statePtr->outputTranslation) {
case TCL_TRANSLATE_LF:
srcCopied = destCopied;
memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied);
break;
case TCL_TRANSLATE_CR:
srcCopied = destCopied;
memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied);
for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) {
if (*dPtr == '\n') {
*dPtr = '\r';
}
}
break;
case TCL_TRANSLATE_CRLF:
for (srcCopied = 0, dPtr = destPtr, sPtr = src;
dPtr < destPtr + destCopied;
dPtr++, sPtr++, srcCopied++) {
if (*sPtr == '\n') {
if (crsent) {
*dPtr = '\n';
crsent = 0;
} else {
*dPtr = '\r';
crsent = 1;
sPtr--, srcCopied--;
}
} else {
*dPtr = *sPtr;
}
}
break;
case TCL_TRANSLATE_AUTO:
panic("Tcl_Write: AUTO output translation mode not supported");
default:
panic("Tcl_Write: unknown output translation mode");
}
/*
* The current buffer is ready for output if it is full, or if it
* contains a newline and this channel is line-buffered, or if it
* contains any output and this channel is unbuffered.
*/
outBufPtr->nextAdded += destCopied;
if (!(statePtr->flags & BUFFER_READY)) {
if (outBufPtr->nextAdded == outBufPtr->bufLength) {
statePtr->flags |= BUFFER_READY;
} else if (statePtr->flags & CHANNEL_LINEBUFFERED) {
for (sPtr = src, i = 0, foundNewline = 0;
(i < srcCopied) && (!foundNewline);
i++, sPtr++) {
if (*sPtr == '\n') {
foundNewline = 1;
break;
}
}
if (foundNewline) {
statePtr->flags |= BUFFER_READY;
}
} else if (statePtr->flags & CHANNEL_UNBUFFERED) {
statePtr->flags |= BUFFER_READY;
}
}
totalDestCopied += srcCopied;
src += srcCopied;
srcLen -= srcCopied;
if (statePtr->flags & BUFFER_READY) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
}
} /* Closes "while" */
return totalDestCopied;
}
/*
*----------------------------------------------------------------------
*
* CopyEventProc --
*
* This routine is invoked as a channel event handler for
* the background copy operation. It is just a trivial wrapper
* around the CopyData routine.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
CopyEventProc(clientData, mask)
ClientData clientData;
int mask;
{
(void) CopyData((CopyState *)clientData, mask);
}
/*
*----------------------------------------------------------------------
*
* StopCopy --
*
* This routine halts a copy that is in progress.
*
* Results:
* None.
*
* Side effects:
* Removes any pending channel handlers and restores the blocking
* and buffering modes of the channels. The CopyState is freed.
*
*----------------------------------------------------------------------
*/
static void
StopCopy(csPtr)
CopyState *csPtr; /* State for bg copy to stop . */
{
ChannelState *inStatePtr, *outStatePtr;
int nonBlocking;
if (!csPtr) {
return;
}
inStatePtr = csPtr->readPtr->state;
outStatePtr = csPtr->writePtr->state;
/*
* Restore the old blocking mode and output buffering mode.
*/
nonBlocking = (csPtr->readFlags & CHANNEL_NONBLOCKING);
if (nonBlocking != (inStatePtr->flags & CHANNEL_NONBLOCKING)) {
SetBlockMode(NULL, csPtr->readPtr,
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
}
if (csPtr->readPtr != csPtr->writePtr) {
nonBlocking = (csPtr->writeFlags & CHANNEL_NONBLOCKING);
if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) {
SetBlockMode(NULL, csPtr->writePtr,
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
}
}
outStatePtr->flags &= ~(CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);
outStatePtr->flags |=
csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);
if (csPtr->cmdPtr) {
Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->readPtr, CopyEventProc,
(ClientData)csPtr);
if (csPtr->readPtr != csPtr->writePtr) {
Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->writePtr,
CopyEventProc, (ClientData)csPtr);
}
Tcl_DecrRefCount(csPtr->cmdPtr);
}
inStatePtr->csPtrR = NULL;
outStatePtr->csPtrW = NULL;
ckfree((char*) csPtr);
}
/*
*----------------------------------------------------------------------
*
* StackSetBlockMode --
*
* This function sets the blocking mode for a channel, iterating
* through each channel in a stack and updates the state flags.
*
* Results:
* 0 if OK, result code from failed blockModeProc otherwise.
*
* Side effects:
* Modifies the blocking mode of the channel and possibly generates
* an error.
*
*----------------------------------------------------------------------
*/
static int
StackSetBlockMode(chanPtr, mode)
Channel *chanPtr; /* Channel to modify. */
int mode; /* One of TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
int result = 0;
Tcl_DriverBlockModeProc *blockModeProc;
/*
* Start at the top of the channel stack
*/
chanPtr = chanPtr->state->topChanPtr;
while (chanPtr != (Channel *) NULL) {
blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr);
if (blockModeProc != NULL) {
result = (*blockModeProc) (chanPtr->instanceData, mode);
if (result != 0) {
Tcl_SetErrno(result);
return result;
}
}
chanPtr = chanPtr->downChanPtr;
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* SetBlockMode --
*
* This function sets the blocking mode for a channel and updates
* the state flags.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Modifies the blocking mode of the channel and possibly generates
* an error.
*
*----------------------------------------------------------------------
*/
static int
SetBlockMode(interp, chanPtr, mode)
Tcl_Interp *interp; /* Interp for error reporting. */
Channel *chanPtr; /* Channel to modify. */
int mode; /* One of TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
int result = 0;
result = StackSetBlockMode(chanPtr, mode);
if (result != 0) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "error setting blocking mode: ",
Tcl_PosixError(interp), (char *) NULL);
}
return TCL_ERROR;
}
if (mode == TCL_MODE_BLOCKING) {
statePtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED));
} else {
statePtr->flags |= CHANNEL_NONBLOCKING;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelNames --
*
* Return the names of all open channels in the interp.
*
* Results:
* TCL_OK or TCL_ERROR.
*
* Side effects:
* Interp result modified with list of channel names.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetChannelNames(interp)
Tcl_Interp *interp; /* Interp for error reporting. */
{
return Tcl_GetChannelNamesEx(interp, (char *) NULL);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelNamesEx --
*
* Return the names of open channels in the interp filtered
* filtered through a pattern. If pattern is NULL, it returns
* all the open channels.
*
* Results:
* TCL_OK or TCL_ERROR.
*
* Side effects:
* Interp result modified with list of channel names.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetChannelNamesEx(interp, pattern)
Tcl_Interp *interp; /* Interp for error reporting. */
CONST char *pattern; /* pattern to filter on. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ChannelState *statePtr;
CONST char *name; /* name for channel */
Tcl_Obj *resultPtr; /* pointer to result object */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashEntry *hPtr; /* Search variable. */
Tcl_HashSearch hSearch; /* Search variable. */
if (interp == (Tcl_Interp *) NULL) {
return TCL_OK;
}
/*
* Get the channel table that stores the channels registered
* for this interpreter.
*/
hTblPtr = GetChannelTable(interp);
resultPtr = Tcl_GetObjResult(interp);
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != (Tcl_HashEntry *) NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
statePtr = ((Channel *) Tcl_GetHashValue(hPtr))->state;
if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) {
name = "stdin";
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) {
name = "stdout";
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
name = "stderr";
} else {
/*
* This is also stored in Tcl_GetHashKey(hTblPtr, hPtr),
* but it's simpler to just grab the name from the statePtr.
*/
name = statePtr->channelName;
}
if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) &&
(Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, -1)) != TCL_OK)) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_IsChannelRegistered --
*
* Checks whether the channel is associated with the interp.
* See also Tcl_RegisterChannel and Tcl_UnregisterChannel.
*
* Results:
* 0 if the channel is not registered in the interpreter, 1 else.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_IsChannelRegistered (interp, chan)
Tcl_Interp* interp; /* The interp to query of the channel */
Tcl_Channel chan; /* The channel to check */
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashEntry *hPtr; /* Search variable. */
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of the real channel. */
/*
* Always check bottom-most channel in the stack. This is the one
* that gets registered.
*/
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
return 0;
}
hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
if (hPtr == (Tcl_HashEntry *) NULL) {
return 0;
}
if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
return 0;
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_IsChannelShared --
*
* Checks whether the channel is shared by multiple interpreters.
*
* Results:
* A boolean value (0 = Not shared, 1 = Shared).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_IsChannelShared (chan)
Tcl_Channel chan; /* The channel to query */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
return ((statePtr->refCount > 1) ? 1 : 0);
}
/*
*----------------------------------------------------------------------
*
* Tcl_IsChannelExisting --
*
* Checks whether a channel of the given name exists in the
* (thread)-global list of all channels.
* See Tcl_GetChannelNamesEx for function exposed at the Tcl level.
*
* Results:
* A boolean value (0 = Does not exist, 1 = Does exist).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_IsChannelExisting(chanName)
CONST char* chanName; /* The name of the channel to look for. */
{
ChannelState *statePtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
CONST char *name;
int chanNameLen;
chanNameLen = strlen(chanName);
for (statePtr = tsdPtr->firstCSPtr;
statePtr != NULL;
statePtr = statePtr->nextCSPtr) {
if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) {
name = "stdin";
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) {
name = "stdout";
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
name = "stderr";
} else {
name = statePtr->channelName;
}
/* Bug 2333466. Include \0 in the compare to prevent partial matching on prefixes.
*/
if ((*chanName == *name) &&
(memcmp(name, chanName, (size_t) chanNameLen+1) == 0)) {
return 1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelName --
*
* Return the name of the channel type.
*
* Results:
* A pointer the name of the channel type.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_ChannelName(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
return chanTypePtr->typeName;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelVersion --
*
* Return the of version of the channel type.
*
* Results:
* One of the TCL_CHANNEL_VERSION_* constants from tcl.h
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_ChannelTypeVersion
Tcl_ChannelVersion(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) {
return TCL_CHANNEL_VERSION_2;
} else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) {
return TCL_CHANNEL_VERSION_3;
} else if (chanTypePtr->version == TCL_CHANNEL_VERSION_4) {
return TCL_CHANNEL_VERSION_4;
} else {
/*
* In = ((int)minimumVersion);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelBlockModeProc --
*
* Return the Tcl_DriverBlockModeProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------- */
Tcl_DriverBlockModeProc *
Tcl_ChannelBlockModeProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) {
return chanTypePtr->blockModeProc;
} else {
/*
* The v1 structure had the blockModeProc in a different place.
*/
return (Tcl_DriverBlockModeProc *) (chanTypePtr->version);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelCloseProc --
*
* Return the Tcl_DriverCloseProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverCloseProc *
Tcl_ChannelCloseProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
return chanTypePtr->closeProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelClose2Proc --
*
* Return the Tcl_DriverClose2Proc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverClose2Proc *
Tcl_ChannelClose2Proc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
return chanTypePtr->close2Proc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelInputProc --
*
* Return the Tcl_DriverInputProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverInputProc *
Tcl_ChannelInputProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
return chanTypePtr->inputProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelOutputProc --
*
* Return the Tcl_DriverOutputProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverOutputProc *
Tcl_ChannelOutputProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
return chanTypePtr->outputProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelSeekProc --
*
* Return the Tcl_DriverSeekProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverSeekProc *
Tcl_ChannelSeekProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
return chanTypePtr->seekProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelSetOptionProc --
*
* Return the Tcl_DriverSetOptionProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverSetOptionProc *
Tcl_ChannelSetOptionProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
return chanTypePtr->setOptionProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelGetOptionProc --
*
* Return the Tcl_DriverGetOptionProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverGetOptionProc *
Tcl_ChannelGetOptionProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
return chanTypePtr->getOptionProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelWatchProc --
*
* Return the Tcl_DriverWatchProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverWatchProc *
Tcl_ChannelWatchProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
return chanTypePtr->watchProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelGetHandleProc --
*
* Return the Tcl_DriverGetHandleProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverGetHandleProc *
Tcl_ChannelGetHandleProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
return chanTypePtr->getHandleProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelFlushProc --
*
* Return the Tcl_DriverFlushProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverFlushProc *
Tcl_ChannelFlushProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) {
return chanTypePtr->flushProc;
} else {
return NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelHandlerProc --
*
* Return the Tcl_DriverHandlerProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverHandlerProc *
Tcl_ChannelHandlerProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) {
return chanTypePtr->handlerProc;
} else {
return NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelWideSeekProc --
*
* Return the Tcl_DriverWideSeekProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverWideSeekProc *
Tcl_ChannelWideSeekProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) {
return chanTypePtr->wideSeekProc;
} else {
return NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelThreadActionProc --
*
* Return the Tcl_DriverThreadActionProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverThreadActionProc *
Tcl_ChannelThreadActionProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) {
return chanTypePtr->threadActionProc;
} else {
return NULL;
}
}
#if 0
/* For future debugging work, a simple function to print the flags of
* a channel in semi-readable form.
*/
static int
DumpFlags (str, flags)
char* str;
int flags;
{
char buf [20];
int i = 0;
if (flags & TCL_READABLE) {buf[i] = 'r';} else {buf [i]='_';}; i++;
if (flags & TCL_WRITABLE) {buf[i] = 'w';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_NONBLOCKING) {buf[i] = 'n';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_LINEBUFFERED) {buf[i] = 'l';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_UNBUFFERED) {buf[i] = 'u';} else {buf [i]='_';}; i++;
if (flags & BUFFER_READY) {buf[i] = 'R';} else {buf [i]='_';}; i++;
if (flags & BG_FLUSH_SCHEDULED) {buf[i] = 'F';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_CLOSED) {buf[i] = 'c';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_EOF) {buf[i] = 'E';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_STICKY_EOF) {buf[i] = 'S';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_BLOCKED) {buf[i] = 'B';} else {buf [i]='_';}; i++;
if (flags & INPUT_SAW_CR) {buf[i] = '/';} else {buf [i]='_';}; i++;
if (flags & INPUT_NEED_NL) {buf[i] = '*';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_DEAD) {buf[i] = 'D';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_RAW_MODE) {buf[i] = 'R';} else {buf [i]='_';}; i++;
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
if (flags & CHANNEL_TIMER_FEV) {buf[i] = 'T';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_HAS_MORE_DATA) {buf[i] = 'H';} else {buf [i]='_';}; i++;
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
if (flags & CHANNEL_INCLOSE) {buf[i] = 'x';} else {buf [i]='_';}; i++;
buf [i] ='\0';
fprintf (stderr,"%s: %s\n", str, buf); fflush(stderr);
return 0;
}
#endif
tcl8.4.20/generic/tclEnv.c 0000644 0036047 0045461 00000044545 12052456743 013744 0 ustar dgp 771div /*
* tclEnv.c --
*
* Tcl support for environment variables, including a setenv
* procedure. This file contains the generic portion of the
* environment module. It is primarily responsible for keeping
* the "env" arrays in sync with the system environment variables.
*
* Copyright (c) 1991-1994 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.
*/
#include "tclInt.h"
#include "tclPort.h"
TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ */
static int cacheSize = 0; /* Number of env strings in environCache. */
static char **environCache = NULL;
/* Array containing all of the environment
* strings that Tcl has allocated. */
#ifndef USE_PUTENV
static char **ourEnviron = NULL;/* Cache of the array that we allocate.
* We need to track this in case another
* subsystem swaps around the environ array
* like we do.
*/
static int environSize = 0; /* Non-zero means that the environ array was
* malloced and has this many total entries
* allocated to it (not all may be in use at
* once). Zero means that the environment
* array is in its original static state. */
#endif
/*
* Declarations for local procedures defined in this file:
*/
static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
static void ReplaceString _ANSI_ARGS_((CONST char *oldStr,
char *newStr));
void TclSetEnv _ANSI_ARGS_((CONST char *name,
CONST char *value));
void TclUnsetEnv _ANSI_ARGS_((CONST char *name));
/*
*----------------------------------------------------------------------
*
* TclSetupEnv --
*
* This procedure is invoked for an interpreter to make environment
* variables accessible from that interpreter via the "env"
* associative array.
*
* Results:
* None.
*
* Side effects:
* The interpreter is added to a list of interpreters managed
* by us, so that its view of envariables can be kept consistent
* with the view in other interpreters. If this is the first
* call to TclSetupEnv, then additional initialization happens,
* such as copying the environment to dynamically-allocated space
* for ease of management.
*
*----------------------------------------------------------------------
*/
void
TclSetupEnv(interp)
Tcl_Interp *interp; /* Interpreter whose "env" array is to be
* managed. */
{
Tcl_DString envString;
char *p1, *p2;
int i;
/*
* Synchronize the values in the environ array with the contents
* of the Tcl "env" variable. To do this:
* 1) Remove the trace that fires when the "env" var is unset.
* 2) Unset the "env" variable.
* 3) If there are no environ variables, create an empty "env"
* array. Otherwise populate the array with current values.
* 4) Add a trace that synchronizes the "env" array.
*/
Tcl_UntraceVar2(interp, "env", (char *) NULL,
TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc,
(ClientData) NULL);
Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY);
if (environ[0] == NULL) {
Tcl_Obj *varNamePtr;
varNamePtr = Tcl_NewStringObj("env", -1);
Tcl_IncrRefCount(varNamePtr);
TclArraySet(interp, varNamePtr, NULL);
Tcl_DecrRefCount(varNamePtr);
} else {
Tcl_MutexLock(&envMutex);
for (i = 0; environ[i] != NULL; i++) {
p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
p2 = strchr(p1, '=');
if (p2 == NULL) {
/*
* This condition seem to happen occasionally under some
* versions of Solaris; ignore the entry.
*/
continue;
}
p2++;
p2[-1] = '\0';
Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&envString);
}
Tcl_MutexUnlock(&envMutex);
}
Tcl_TraceVar2(interp, "env", (char *) NULL,
TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc,
(ClientData) NULL);
}
/*
*----------------------------------------------------------------------
*
* TclSetEnv --
*
* Set an environment variable, replacing an existing value
* or creating a new variable if there doesn't exist a variable
* by the given name. This procedure is intended to be a
* stand-in for the UNIX "setenv" procedure so that applications
* using that procedure will interface properly to Tcl. To make
* it a stand-in, the Makefile must define "TclSetEnv" to "setenv".
*
* Results:
* None.
*
* Side effects:
* The environ array gets updated.
*
*----------------------------------------------------------------------
*/
void
TclSetEnv(name, value)
CONST char *name; /* Name of variable whose value is to be
* set (UTF-8). */
CONST char *value; /* New value for variable (UTF-8). */
{
Tcl_DString envString;
int index, length, nameLength;
char *p, *oldValue;
CONST char *p2;
/*
* Figure out where the entry is going to go. If the name doesn't
* already exist, enlarge the array if necessary to make room. If the
* name exists, free its old entry.
*/
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
if (index == -1) {
#ifndef USE_PUTENV
/*
* We need to handle the case where the environment may be changed
* outside our control. environSize is only valid if the current
* environment is the one we allocated. [Bug 979640]
*/
if ((ourEnviron != environ) || ((length + 2) > environSize)) {
char **newEnviron;
newEnviron = (char **) ckalloc((unsigned)
((length + 5) * sizeof(char *)));
memcpy((VOID *) newEnviron, (VOID *) environ,
length*sizeof(char *));
if ((environSize != 0) && (ourEnviron != NULL)) {
ckfree((char *) ourEnviron);
}
environ = ourEnviron = newEnviron;
environSize = length + 5;
}
index = length;
environ[index + 1] = NULL;
#endif
oldValue = NULL;
nameLength = strlen(name);
} else {
CONST char *env;
/*
* Compare the new value to the existing value. If they're
* the same then quit immediately (e.g. don't rewrite the
* value or propagate it to other interpreters). Otherwise,
* when there are N interpreters there will be N! propagations
* of the same value among the interpreters.
*/
env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString);
if (strcmp(value, (env + length + 1)) == 0) {
Tcl_DStringFree(&envString);
Tcl_MutexUnlock(&envMutex);
return;
}
Tcl_DStringFree(&envString);
oldValue = environ[index];
nameLength = length;
}
/*
* Create a new entry. Build a complete UTF string that contains
* a "name=value" pattern. Then convert the string to the native
* encoding, and set the environ array value.
*/
p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
strcpy(p, name);
p[nameLength] = '=';
strcpy(p+nameLength+1, value);
p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
/*
* Copy the native string to heap memory.
*/
p = (char *) ckrealloc(p, (unsigned) (strlen(p2) + 1));
strcpy(p, p2);
Tcl_DStringFree(&envString);
#ifdef USE_PUTENV
/*
* Update the system environment.
*/
putenv(p);
index = TclpFindVariable(name, &length);
#else
environ[index] = p;
#endif
/*
* Watch out for versions of putenv that copy the string (e.g. VC++).
* In this case we need to free the string immediately. Otherwise
* update the string in the cache.
*/
if ((index != -1) && (environ[index] == p)) {
ReplaceString(oldValue, p);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/* This putenv() copies instead of taking ownership */
ckfree(p);
#endif
}
Tcl_MutexUnlock(&envMutex);
if (!strcmp(name, "HOME")) {
/*
* If the user's home directory has changed, we must invalidate
* the filesystem cache, because '~' expansions will now be
* incorrect.
*/
Tcl_FSMountsChanged(NULL);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_PutEnv --
*
* Set an environment variable. Similar to setenv except that
* the information is passed in a single string of the form
* NAME=value, rather than as separate name strings. This procedure
* is intended to be a stand-in for the UNIX "putenv" procedure
* so that applications using that procedure will interface
* properly to Tcl. To make it a stand-in, the Makefile will
* define "Tcl_PutEnv" to "putenv".
*
* Results:
* None.
*
* Side effects:
* The environ array gets updated, as do all of the interpreters
* that we manage.
*
*----------------------------------------------------------------------
*/
int
Tcl_PutEnv(string)
CONST char *string; /* Info about environment variable in the
* form NAME=value. (native) */
{
Tcl_DString nameString;
CONST char *name;
char *value;
if (string == NULL) {
return 0;
}
/*
* First convert the native string to UTF. Then separate the
* string into name and value parts, and call TclSetEnv to do
* all of the real work.
*/
name = Tcl_ExternalToUtfDString(NULL, string, -1, &nameString);
value = strchr(name, '=');
if ((value != NULL) && (value != name)) {
value[0] = '\0';
TclSetEnv(name, value+1);
}
Tcl_DStringFree(&nameString);
return 0;
}
/*
*----------------------------------------------------------------------
*
* TclUnsetEnv --
*
* Remove an environment variable, updating the "env" arrays
* in all interpreters managed by us. This function is intended
* to replace the UNIX "unsetenv" function (but to do this the
* Makefile must be modified to redefine "TclUnsetEnv" to
* "unsetenv".
*
* Results:
* None.
*
* Side effects:
* Interpreters are updated, as is environ.
*
*----------------------------------------------------------------------
*/
void
TclUnsetEnv(name)
CONST char *name; /* Name of variable to remove (UTF-8). */
{
char *oldValue;
int length;
int index;
#ifdef USE_PUTENV_FOR_UNSET
Tcl_DString envString;
char *string;
#else
char **envPtr;
#endif
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
/*
* First make sure that the environment variable exists to avoid
* doing needless work and to avoid recursion on the unset.
*/
if (index == -1) {
Tcl_MutexUnlock(&envMutex);
return;
}
/*
* Remember the old value so we can free it if Tcl created the string.
*/
oldValue = environ[index];
/*
* Update the system environment. This must be done before we
* update the interpreters or we will recurse.
*/
#ifdef USE_PUTENV_FOR_UNSET
/*
* For those platforms that support putenv to unset, Linux indicates
* that no = should be included, and Windows requires it.
*/
#ifdef WIN32
string = ckalloc((unsigned int) length+2);
memcpy((VOID *) string, (VOID *) name, (size_t) length);
string[length] = '=';
string[length+1] = '\0';
#else
string = ckalloc((unsigned int) length+1);
memcpy((VOID *) string, (VOID *) name, (size_t) length);
string[length] = '\0';
#endif
Tcl_UtfToExternalDString(NULL, string, -1, &envString);
string = ckrealloc(string, (unsigned) (Tcl_DStringLength(&envString)+1));
strcpy(string, Tcl_DStringValue(&envString));
Tcl_DStringFree(&envString);
putenv(string);
/*
* Watch out for versions of putenv that copy the string (e.g. VC++).
* In this case we need to free the string immediately. Otherwise
* update the string in the cache.
*/
if (environ[index] == string) {
ReplaceString(oldValue, string);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/* This putenv() copies instead of taking ownership */
ckfree(string);
#endif
}
#else
for (envPtr = environ+index+1; ; envPtr++) {
envPtr[-1] = *envPtr;
if (*envPtr == NULL) {
break;
}
}
ReplaceString(oldValue, NULL);
#endif
Tcl_MutexUnlock(&envMutex);
}
/*
*---------------------------------------------------------------------------
*
* TclGetEnv --
*
* Retrieve the value of an environment variable.
*
* Results:
* The result is a pointer to a string specifying the value of the
* environment variable, or NULL if that environment variable does
* not exist. Storage for the result string is allocated in valuePtr;
* the caller must call Tcl_DStringFree() when the result is no
* longer needed.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char *
TclGetEnv(name, valuePtr)
CONST char *name; /* Name of environment variable to find
* (UTF-8). */
Tcl_DString *valuePtr; /* Uninitialized or free DString in which
* the value of the environment variable is
* stored. */
{
int length, index;
CONST char *result;
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
result = NULL;
if (index != -1) {
Tcl_DString envStr;
result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr);
result += length;
if (*result == '=') {
result++;
Tcl_DStringInit(valuePtr);
Tcl_DStringAppend(valuePtr, result, -1);
result = Tcl_DStringValue(valuePtr);
} else {
result = NULL;
}
Tcl_DStringFree(&envStr);
}
Tcl_MutexUnlock(&envMutex);
return result;
}
/*
*----------------------------------------------------------------------
*
* EnvTraceProc --
*
* This procedure is invoked whenever an environment variable
* is read, modified or deleted. It propagates the change to the global
* "environ" array.
*
* Results:
* Always returns NULL to indicate success.
*
* Side effects:
* Environment variable changes get propagated. If the whole
* "env" array is deleted, then we stop managing things for
* this interpreter (usually this happens because the whole
* interpreter is being deleted).
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static char *
EnvTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter whose "env" variable is
* being modified. */
CONST char *name1; /* Better be "env". */
CONST char *name2; /* Name of variable being modified, or NULL
* if whole array is being deleted (UTF-8). */
int flags; /* Indicates what's happening. */
{
/*
* For array traces, let TclSetupEnv do all the work.
*/
if (flags & TCL_TRACE_ARRAY) {
TclSetupEnv(interp);
return NULL;
}
/*
* If name2 is NULL, then return and do nothing.
*/
if (name2 == NULL) {
return NULL;
}
/*
* If a value is being set, call TclSetEnv to do all of the work.
*/
if (flags & TCL_TRACE_WRITES) {
CONST char *value;
value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
TclSetEnv(name2, value);
}
/*
* If a value is being read, call TclGetEnv to do all of the work.
*/
if (flags & TCL_TRACE_READS) {
Tcl_DString valueString;
CONST char *value;
value = TclGetEnv(name2, &valueString);
if (value == NULL) {
return "no such variable";
}
Tcl_SetVar2(interp, name1, name2, value, 0);
Tcl_DStringFree(&valueString);
}
/*
* For unset traces, let TclUnsetEnv do all the work.
*/
if (flags & TCL_TRACE_UNSETS) {
TclUnsetEnv(name2);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* ReplaceString --
*
* Replace one string with another in the environment variable
* cache. The cache keeps track of all of the environment
* variables that Tcl has modified so they can be freed later.
*
* Results:
* None.
*
* Side effects:
* May free the old string.
*
*----------------------------------------------------------------------
*/
static void
ReplaceString(oldStr, newStr)
CONST char *oldStr; /* Old environment string. */
char *newStr; /* New environment string. */
{
int i;
char **newCache;
/*
* Check to see if the old value was allocated by Tcl. If so,
* it needs to be deallocated to avoid memory leaks. Note that this
* algorithm is O(n), not O(1). This will result in n-squared behavior
* if lots of environment changes are being made.
*/
for (i = 0; i < cacheSize; i++) {
if ((environCache[i] == oldStr) || (environCache[i] == NULL)) {
break;
}
}
if (i < cacheSize) {
/*
* Replace or delete the old value.
*/
if (environCache[i]) {
ckfree(environCache[i]);
}
if (newStr) {
environCache[i] = newStr;
} else {
for (; i < cacheSize-1; i++) {
environCache[i] = environCache[i+1];
}
environCache[cacheSize-1] = NULL;
}
} else {
int allocatedSize = (cacheSize + 5) * sizeof(char *);
/*
* We need to grow the cache in order to hold the new string.
*/
newCache = (char **) ckalloc((unsigned) allocatedSize);
(VOID *) memset(newCache, (int) 0, (size_t) allocatedSize);
if (environCache) {
memcpy((VOID *) newCache, (VOID *) environCache,
(size_t) (cacheSize * sizeof(char*)));
ckfree((char *) environCache);
}
environCache = newCache;
environCache[cacheSize] = newStr;
environCache[cacheSize+1] = NULL;
cacheSize += 5;
}
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeEnvironment --
*
* This function releases any storage allocated by this module
* that isn't still in use by the global environment. Any
* strings that are still in the environment will be leaked.
*
* Results:
* None.
*
* Side effects:
* May deallocate storage.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeEnvironment()
{
/*
* For now we just deallocate the cache array and none of the environment
* strings. This may leak more memory that strictly necessary, since some
* of the strings may no longer be in the environment. However,
* determining which ones are ok to delete is n-squared, and is pretty
* unlikely, so we don't bother.
*/
if (environCache) {
ckfree((char *) environCache);
environCache = NULL;
cacheSize = 0;
#ifndef USE_PUTENV
environSize = 0;
#endif
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclHistory.c 0000644 0036047 0045461 00000007336 11737050674 014654 0 ustar dgp 771div /*
* tclHistory.c --
*
* This module and the Tcl library file history.tcl together implement
* Tcl command history. Tcl_RecordAndEval(Obj) can be called to record
* commands ("events") before they are executed. Commands defined in
* history.tcl may be used to perform history substitutions.
*
* Copyright (c) 1990-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.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
*----------------------------------------------------------------------
*
* Tcl_RecordAndEval --
*
* This procedure adds its command argument to the current list of
* recorded events and then executes the command by calling
* Tcl_Eval.
*
* Results:
* The return value is a standard Tcl return value, the result of
* executing cmd.
*
* Side effects:
* The command is recorded and executed.
*
*----------------------------------------------------------------------
*/
int
Tcl_RecordAndEval(interp, cmd, flags)
Tcl_Interp *interp; /* Token for interpreter in which command
* will be executed. */
CONST char *cmd; /* Command to record. */
int flags; /* Additional flags. TCL_NO_EVAL means
* only record: don't execute command.
* TCL_EVAL_GLOBAL means use Tcl_GlobalEval
* instead of Tcl_Eval. */
{
register Tcl_Obj *cmdPtr;
int length = strlen(cmd);
int result;
if (length > 0) {
/*
* Call Tcl_RecordAndEvalObj to do the actual work.
*/
cmdPtr = Tcl_NewStringObj(cmd, length);
Tcl_IncrRefCount(cmdPtr);
result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
/*
* Discard the Tcl object created to hold the command.
*/
Tcl_DecrRefCount(cmdPtr);
} else {
/*
* An empty string. Just reset the interpreter's result.
*/
Tcl_ResetResult(interp);
result = TCL_OK;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RecordAndEvalObj --
*
* This procedure adds the command held in its argument object to the
* current list of recorded events and then executes the command by
* calling Tcl_EvalObj.
*
* Results:
* The return value is a standard Tcl return value, the result of
* executing the command.
*
* Side effects:
* The command is recorded and executed.
*
*----------------------------------------------------------------------
*/
int
Tcl_RecordAndEvalObj(interp, cmdPtr, flags)
Tcl_Interp *interp; /* Token for interpreter in which command
* will be executed. */
Tcl_Obj *cmdPtr; /* Points to object holding the command to
* record and execute. */
int flags; /* Additional flags. TCL_NO_EVAL means
* record only: don't execute the command.
* TCL_EVAL_GLOBAL means evaluate the
* script in global variable context instead
* of the current procedure. */
{
int result;
Tcl_Obj *list[3];
register Tcl_Obj *objPtr;
/*
* Do recording by eval'ing a tcl history command: history add $cmd.
*/
list[0] = Tcl_NewStringObj("history", -1);
list[1] = Tcl_NewStringObj("add", -1);
list[2] = cmdPtr;
objPtr = Tcl_NewListObj(3, list);
Tcl_IncrRefCount(objPtr);
(void) Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(objPtr);
/*
* Execute the command.
*/
result = TCL_OK;
if (!(flags & TCL_NO_EVAL)) {
result = Tcl_EvalObjEx(interp, cmdPtr, flags & TCL_EVAL_GLOBAL);
}
return result;
}
tcl8.4.20/generic/tclPort.h 0000644 0036047 0045461 00000001752 12052456744 014137 0 ustar dgp 771div /*
* tclPort.h --
*
* This header file handles porting issues that occur because
* of differences between systems. It reads in platform specific
* portability files.
*
* Copyright (c) 1994-1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _TCLPORT
#define _TCLPORT
#include "tcl.h"
#if defined(__WIN32__)
# include "tclWinPort.h"
#else
# include "tclUnixPort.h"
#endif
#if !defined(LLONG_MIN)
# ifdef TCL_WIDE_INT_IS_LONG
# define LLONG_MIN LONG_MIN
# else
# ifdef LLONG_BIT
# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<(LLONG_BIT-1)))
# else
/* Assume we're on a system with a 64-bit 'long long' type */
# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<63))
# endif
# endif
/* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */
# define LLONG_MAX (~LLONG_MIN)
#endif
#endif /* _TCLPORT */
tcl8.4.20/generic/tclUtil.c 0000644 0036047 0045461 00000223772 12133546540 014125 0 ustar dgp 771div /*
* tclUtil.c --
*
* This file contains utility procedures that are used by many Tcl
* commands.
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* The following variable holds the full path name of the binary
* from which this application was executed, or NULL if it isn't
* know. The value of the variable is set by the procedure
* Tcl_FindExecutable. The storage space is dynamically allocated.
*/
char *tclExecutableName = NULL;
char *tclNativeExecutableName = NULL;
/*
* The following values are used in the flags returned by Tcl_ScanElement
* and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also
* defined in tcl.h; make sure its value doesn't overlap with any of the
* values below.
*
* TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in
* braces (e.g. it contains unmatched braces,
* or ends in a backslash character, or user
* just doesn't want braces); handle all
* special characters by adding backslashes.
* USE_BRACES - 1 means the string contains a special
* character that can be handled simply by
* enclosing the entire argument in braces.
* BRACES_UNMATCHED - 1 means that braces aren't properly matched
* in the argument.
*/
#define USE_BRACES 2
#define BRACES_UNMATCHED 4
/*
* Data structures for process-global values.
*/
typedef void (InitPGVProc) _ANSI_ARGS_ ((char **valuePtr, int *lengthPtr));
/*
* A ProcessGlobalValue struct exists for each internal value in Tcl that is
* to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
* the value, and the master is kept as a counted string, with epoch and mutex
* control. Each ProcessGlobalValue struct should be a static variable in some
* file.
*/
typedef struct ProcessGlobalValue {
int epoch; /* Epoch counter to detect changes in the
* master value. */
int numBytes; /* Length of the master string. */
char *value; /* The master string value. */
InitPGVProc *proc; /* A procedure to initialize the master string
* copy when a "get" request comes in before
* any "set" request has been received. */
Tcl_Mutex mutex; /* Enforce orderly access from multiple
* threads. */
Tcl_ThreadDataKey key; /* Key for per-thread data holding the
* (Tcl_Obj) copy for each thread. */
} PGV;
/*
* The following values determine the precision used when converting
* floating-point values to strings. This information is linked to all
* of the tcl_precision variables in all interpreters via the procedure
* TclPrecTraceProc.
*/
static InitPGVProc InitPrecision;
static PGV precision = {
0, 0, NULL, InitPrecision, NULL, NULL
};
/*
* Prototypes for procedures defined later in this file.
*/
static void ClearHash _ANSI_ARGS_((Tcl_HashTable *tablePtr));
static void FreePGV _ANSI_ARGS_((ClientData clientData));
static void FreeThreadHash _ANSI_ARGS_((ClientData clientData));
static Tcl_HashTable * GetThreadHash _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr));
static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));
static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* objPtr));
static void SetPGV _ANSI_ARGS_((PGV *pgvPtr, Tcl_Obj *newValue));
static Tcl_Obj * GetPGV _ANSI_ARGS_((PGV *pgvPtr));
/*
* The following is the Tcl object type definition for an object
* that represents a list index in the form, "end-offset". It is
* used as a performance optimization in TclGetIntForIndex. The
* internal rep is an integer, so no memory management is required
* for it.
*/
Tcl_ObjType tclEndOffsetType = {
"end-offset", /* name */
(Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */
(Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */
UpdateStringOfEndOffset, /* updateStringProc */
SetEndOffsetFromAny
};
/*
*----------------------------------------------------------------------
*
* TclFindElement --
*
* Given a pointer into a Tcl list, locate the first (or next)
* element in the list.
*
* Results:
* The return value is normally TCL_OK, which means that the
* element was successfully located. If TCL_ERROR is returned
* it means that list didn't have proper list structure;
* the interp's result contains a more detailed error message.
*
* If TCL_OK is returned, then *elementPtr will be set to point to the
* first element of list, and *nextPtr will be set to point to the
* character just after any white space following the last character
* that's part of the element. If this is the last argument in the
* list, then *nextPtr will point just after the last character in the
* list (i.e., at the character at list+listLength). If sizePtr is
* non-NULL, *sizePtr is filled in with the number of characters in the
* element. If the element is in braces, then *elementPtr will point
* to the character after the opening brace and *sizePtr will not
* include either of the braces. If there isn't an element in the list,
* *sizePtr will be zero, and both *elementPtr and *termPtr will point
* just after the last character in the list. Note: this procedure does
* NOT collapse backslash sequences.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
bracePtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, then no error message is left
* after errors. */
CONST char *list; /* Points to the first byte of a string
* containing a Tcl list with zero or more
* elements (possibly in braces). */
int listLength; /* Number of bytes in the list's string. */
CONST char **elementPtr; /* Where to put address of first significant
* character in first element of list. */
CONST char **nextPtr; /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list). */
int *sizePtr; /* If non-zero, fill in with size of
* element. */
int *bracePtr; /* If non-zero, fill in with non-zero/zero
* to indicate that arg was/wasn't
* in braces. */
{
CONST char *p = list;
CONST char *elemStart; /* Points to first byte of first element. */
CONST char *limit; /* Points just after list's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
int size = 0; /* lint. */
int numChars;
CONST char *p2;
/*
* Skim off leading white space and check for an opening brace or
* quote. We treat embedded NULLs in the list as bytes belonging to
* a list element.
*/
limit = (list + listLength);
while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
p++;
}
if (p == limit) { /* no element found */
elemStart = limit;
goto done;
}
if (*p == '{') {
openBraces = 1;
p++;
} else if (*p == '"') {
inQuotes = 1;
p++;
}
elemStart = p;
if (bracePtr != 0) {
*bracePtr = openBraces;
}
/*
* Find element's end (a space, close brace, or the end of the string).
*/
while (p < limit) {
switch (*p) {
/*
* Open brace: don't treat specially unless the element is in
* braces. In this case, keep a nesting count.
*/
case '{':
if (openBraces != 0) {
openBraces++;
}
break;
/*
* Close brace: if element is in braces, keep nesting count and
* quit when the last close brace is seen.
*/
case '}':
if (openBraces > 1) {
openBraces--;
} else if (openBraces == 1) {
size = (p - elemStart);
p++;
if ((p >= limit)
|| isspace(UCHAR(*p))) { /* INTL: ISO space. */
goto done;
}
/*
* Garbage after the closing brace; return an error.
*/
if (interp != NULL) {
char buf[100];
p2 = p;
while ((p2 < limit)
&& (!isspace(UCHAR(*p2))) /* INTL: ISO space. */
&& (p2 < p+20)) {
p2++;
}
sprintf(buf,
"list element in braces followed by \"%.*s\" instead of space",
(int) (p2-p), p);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
}
return TCL_ERROR;
}
break;
/*
* Backslash: skip over everything up to the end of the
* backslash sequence.
*/
case '\\': {
TclParseBackslash(p, limit - p, &numChars, NULL);
p += (numChars - 1);
break;
}
/*
* Space: ignore if element is in braces or quotes; otherwise
* terminate element.
*/
case ' ':
case '\f':
case '\n':
case '\r':
case '\t':
case '\v':
if ((openBraces == 0) && !inQuotes) {
size = (p - elemStart);
goto done;
}
break;
/*
* Double-quote: if element is in quotes then terminate it.
*/
case '"':
if (inQuotes) {
size = (p - elemStart);
p++;
if ((p >= limit)
|| isspace(UCHAR(*p))) { /* INTL: ISO space */
goto done;
}
/*
* Garbage after the closing quote; return an error.
*/
if (interp != NULL) {
char buf[100];
p2 = p;
while ((p2 < limit)
&& (!isspace(UCHAR(*p2))) /* INTL: ISO space */
&& (p2 < p+20)) {
p2++;
}
sprintf(buf,
"list element in quotes followed by \"%.*s\" %s",
(int) (p2-p), p, "instead of space");
Tcl_SetResult(interp, buf, TCL_VOLATILE);
}
return TCL_ERROR;
}
break;
}
p++;
}
/*
* End of list: terminate element.
*/
if (p == limit) {
if (openBraces != 0) {
if (interp != NULL) {
Tcl_SetResult(interp, "unmatched open brace in list",
TCL_STATIC);
}
return TCL_ERROR;
} else if (inQuotes) {
if (interp != NULL) {
Tcl_SetResult(interp, "unmatched open quote in list",
TCL_STATIC);
}
return TCL_ERROR;
}
size = (p - elemStart);
}
done:
while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
p++;
}
*elementPtr = elemStart;
*nextPtr = p;
if (sizePtr != 0) {
*sizePtr = size;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCopyAndCollapse --
*
* Copy a string and eliminate any backslashes that aren't in braces.
*
* Results:
* Count bytes get copied from src to dst. Along the way, backslash
* sequences are substituted in the copy. After scanning count bytes
* from src, a null character is placed at the end of dst. Returns
* the number of bytes that got written to dst.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclCopyAndCollapse(count, src, dst)
int count; /* Number of bytes to copy from src. */
CONST char *src; /* Copy from here... */
char *dst; /* ... to here. */
{
int newCount = 0;
while (count > 0) {
char c = *src;
if (c == '\\') {
int numRead;
int backslashCount = TclParseBackslash(src, count, &numRead, dst);
dst += backslashCount;
newCount += backslashCount;
src += numRead;
count -= numRead;
} else {
*dst = c;
dst++;
newCount++;
src++;
count--;
}
}
*dst = 0;
return newCount;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SplitList --
*
* Splits a list up into its constituent fields.
*
* Results
* The return value is normally TCL_OK, which means that
* the list was successfully split up. If TCL_ERROR is
* returned, it means that "list" didn't have proper list
* structure; the interp's result will contain a more detailed
* error message.
*
* *argvPtr will be filled in with the address of an array
* whose elements point to the elements of list, in order.
* *argcPtr will get filled in with the number of valid elements
* in the array. A single block of memory is dynamically allocated
* to hold both the argv array and a copy of the list (with
* backslashes and braces removed in the standard way).
* The caller must eventually free this memory by calling free()
* on *argvPtr. Note: *argvPtr and *argcPtr are only modified
* if the procedure returns normally.
*
* Side effects:
* Memory is allocated.
*
*----------------------------------------------------------------------
*/
int
Tcl_SplitList(interp, list, argcPtr, argvPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, no error message is left. */
CONST char *list; /* Pointer to string with list structure. */
int *argcPtr; /* Pointer to location to fill in with
* the number of elements in the list. */
CONST char ***argvPtr; /* Pointer to place to store pointer to
* array of pointers to list elements. */
{
CONST char **argv;
CONST char *l;
char *p;
int length, size, i, result, elSize, brace;
CONST char *element;
/*
* Figure out how much space to allocate. There must be enough
* space for both the array of pointers and also for a copy of
* the list. To estimate the number of pointers needed, count
* the number of space characters in the list.
*/
for (size = 2, l = list; *l != 0; l++) {
if (isspace(UCHAR(*l))) { /* INTL: ISO space. */
size++;
/* Consecutive space can only count as a single list delimiter */
while (1) {
char next = *(l + 1);
if (next == '\0') {
break;
}
++l;
if (isspace(UCHAR(next))) {
continue;
}
break;
}
}
}
length = l - list;
argv = (CONST char **) ckalloc((unsigned)
((size * sizeof(char *)) + length + 1));
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
*list != 0; i++) {
CONST char *prevList = list;
result = TclFindElement(interp, list, length, &element,
&list, &elSize, &brace);
length -= (list - prevList);
if (result != TCL_OK) {
ckfree((char *) argv);
return result;
}
if (*element == 0) {
break;
}
if (i >= size) {
ckfree((char *) argv);
if (interp != NULL) {
Tcl_SetResult(interp, "internal error in Tcl_SplitList",
TCL_STATIC);
}
return TCL_ERROR;
}
argv[i] = p;
if (brace) {
memcpy((VOID *) p, (VOID *) element, (size_t) elSize);
p += elSize;
*p = 0;
p++;
} else {
TclCopyAndCollapse(elSize, element, p);
p += elSize+1;
}
}
argv[i] = NULL;
*argvPtr = argv;
*argcPtr = i;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ScanElement --
*
* This procedure is a companion procedure to Tcl_ConvertElement.
* It scans a string to see what needs to be done to it (e.g. add
* backslashes or enclosing braces) to make the string into a
* valid Tcl list element.
*
* Results:
* The return value is an overestimate of the number of characters
* that will be needed by Tcl_ConvertElement to produce a valid
* list element from string. The word at *flagPtr is filled in
* with a value needed by Tcl_ConvertElement when doing the actual
* conversion.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ScanElement(string, flagPtr)
register CONST char *string; /* String to convert to list element. */
register int *flagPtr; /* Where to store information to guide
* Tcl_ConvertCountedElement. */
{
return Tcl_ScanCountedElement(string, -1, flagPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ScanCountedElement --
*
* This procedure is a companion procedure to
* Tcl_ConvertCountedElement. It scans a string to see what
* needs to be done to it (e.g. add backslashes or enclosing
* braces) to make the string into a valid Tcl list element.
* If length is -1, then the string is scanned up to the first
* null byte.
*
* Results:
* The return value is an overestimate of the number of characters
* that will be needed by Tcl_ConvertCountedElement to produce a
* valid list element from string. The word at *flagPtr is
* filled in with a value needed by Tcl_ConvertCountedElement
* when doing the actual conversion.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ScanCountedElement(string, length, flagPtr)
CONST char *string; /* String to convert to Tcl list element. */
int length; /* Number of bytes in string, or -1. */
int *flagPtr; /* Where to store information to guide
* Tcl_ConvertElement. */
{
int flags, nestingLevel;
register CONST char *p, *lastChar;
/*
* This procedure and Tcl_ConvertElement together do two things:
*
* 1. They produce a proper list, one that will yield back the
* argument strings when evaluated or when disassembled with
* Tcl_SplitList. This is the most important thing.
*
* 2. They try to produce legible output, which means minimizing the
* use of backslashes (using braces instead). However, there are
* some situations where backslashes must be used (e.g. an element
* like "{abc": the leading brace will have to be backslashed.
* For each element, one of three things must be done:
*
* (a) Use the element as-is (it doesn't contain any special
* characters). This is the most desirable option.
*
* (b) Enclose the element in braces, but leave the contents alone.
* This happens if the element contains embedded space, or if it
* contains characters with special interpretation ($, [, ;, or \),
* or if it starts with a brace or double-quote, or if there are
* no characters in the element.
*
* (c) Don't enclose the element in braces, but add backslashes to
* prevent special interpretation of special characters. This is a
* last resort used when the argument would normally fall under case
* (b) but contains unmatched braces. It also occurs if the last
* character of the argument is a backslash or if the element contains
* a backslash followed by newline.
*
* The procedure figures out how many bytes will be needed to store
* the result (actually, it overestimates). It also collects information
* about the element in the form of a flags word.
*
* Note: list elements produced by this procedure and
* Tcl_ConvertCountedElement must have the property that they can be
* enclosing in curly braces to make sub-lists. This means, for
* example, that we must not leave unmatched curly braces in the
* resulting list element. This property is necessary in order for
* procedures like Tcl_DStringStartSublist to work.
*/
nestingLevel = 0;
flags = 0;
if (string == NULL) {
string = "";
}
if (length == -1) {
length = strlen(string);
}
lastChar = string + length;
p = string;
if ((p == lastChar) || (*p == '{') || (*p == '"')) {
flags |= USE_BRACES;
}
for ( ; p < lastChar; p++) {
switch (*p) {
case '{':
nestingLevel++;
break;
case '}':
nestingLevel--;
if (nestingLevel < 0) {
flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
}
break;
case '[':
case '$':
case ';':
case ' ':
case '\f':
case '\n':
case '\r':
case '\t':
case '\v':
flags |= USE_BRACES;
break;
case '\\':
if ((p+1 == lastChar) || (p[1] == '\n')) {
flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
} else {
int size;
TclParseBackslash(p, lastChar - p, &size, NULL);
p += size-1;
flags |= USE_BRACES;
}
break;
}
}
if (nestingLevel != 0) {
flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
}
*flagPtr = flags;
/*
* Allow enough space to backslash every character plus leave
* two spaces for braces.
*/
return 2*(p-string) + 2;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConvertElement --
*
* This is a companion procedure to Tcl_ScanElement. Given
* the information produced by Tcl_ScanElement, this procedure
* converts a string to a list element equal to that string.
*
* Results:
* Information is copied to *dst in the form of a list element
* identical to src (i.e. if Tcl_SplitList is applied to dst it
* will produce a string identical to src). The return value is
* a count of the number of characters copied (not including the
* terminating NULL character).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ConvertElement(src, dst, flags)
register CONST char *src; /* Source information for list element. */
register char *dst; /* Place to put list-ified element. */
register int flags; /* Flags produced by Tcl_ScanElement. */
{
return Tcl_ConvertCountedElement(src, -1, dst, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConvertCountedElement --
*
* This is a companion procedure to Tcl_ScanCountedElement. Given
* the information produced by Tcl_ScanCountedElement, this
* procedure converts a string to a list element equal to that
* string.
*
* Results:
* Information is copied to *dst in the form of a list element
* identical to src (i.e. if Tcl_SplitList is applied to dst it
* will produce a string identical to src). The return value is
* a count of the number of characters copied (not including the
* terminating NULL character).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ConvertCountedElement(src, length, dst, flags)
register CONST char *src; /* Source information for list element. */
int length; /* Number of bytes in src, or -1. */
char *dst; /* Place to put list-ified element. */
int flags; /* Flags produced by Tcl_ScanElement. */
{
register char *p = dst;
register CONST char *lastChar;
/*
* See the comment block at the beginning of the Tcl_ScanElement
* code for details of how this works.
*/
if (src && length == -1) {
length = strlen(src);
}
if ((src == NULL) || (length == 0)) {
p[0] = '{';
p[1] = '}';
p[2] = 0;
return 2;
}
lastChar = src + length;
if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
*p = '{';
p++;
for ( ; src != lastChar; src++, p++) {
*p = *src;
}
*p = '}';
p++;
} else {
if (*src == '{') {
/*
* Can't have a leading brace unless the whole element is
* enclosed in braces. Add a backslash before the brace.
* Furthermore, this may destroy the balance between open
* and close braces, so set BRACES_UNMATCHED.
*/
p[0] = '\\';
p[1] = '{';
p += 2;
src++;
flags |= BRACES_UNMATCHED;
}
for (; src != lastChar; src++) {
switch (*src) {
case ']':
case '[':
case '$':
case ';':
case ' ':
case '\\':
case '"':
*p = '\\';
p++;
break;
case '{':
case '}':
/*
* It may not seem necessary to backslash braces, but
* it is. The reason for this is that the resulting
* list element may actually be an element of a sub-list
* enclosed in braces (e.g. if Tcl_DStringStartSublist
* has been invoked), so there may be a brace mismatch
* if the braces aren't backslashed.
*/
if (flags & BRACES_UNMATCHED) {
*p = '\\';
p++;
}
break;
case '\f':
*p = '\\';
p++;
*p = 'f';
p++;
continue;
case '\n':
*p = '\\';
p++;
*p = 'n';
p++;
continue;
case '\r':
*p = '\\';
p++;
*p = 'r';
p++;
continue;
case '\t':
*p = '\\';
p++;
*p = 't';
p++;
continue;
case '\v':
*p = '\\';
p++;
*p = 'v';
p++;
continue;
}
*p = *src;
p++;
}
}
*p = '\0';
return p-dst;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Merge --
*
* Given a collection of strings, merge them together into a
* single string that has proper Tcl list structured (i.e.
* Tcl_SplitList may be used to retrieve strings equal to the
* original elements, and Tcl_Eval will parse the string back
* into its original elements).
*
* Results:
* The return value is the address of a dynamically-allocated
* string containing the merged list.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Merge(argc, argv)
int argc; /* How many strings to merge. */
CONST char * CONST *argv; /* Array of string values. */
{
# define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr;
int numChars;
char *result;
char *dst;
int i;
/*
* Pass 1: estimate space, gather flags.
*/
if (argc <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
}
numChars = 1;
for (i = 0; i < argc; i++) {
numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
}
/*
* Pass two: copy into the result area.
*/
result = (char *) ckalloc((unsigned) numChars);
dst = result;
for (i = 0; i < argc; i++) {
numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
dst += numChars;
*dst = ' ';
dst++;
}
if (dst == result) {
*dst = 0;
} else {
dst[-1] = 0;
}
if (flagPtr != localFlags) {
ckfree((char *) flagPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Backslash --
*
* Figure out how to handle a backslash sequence.
*
* Results:
* The return value is the character that should be substituted
* in place of the backslash sequence that starts at src. If
* readPtr isn't NULL then it is filled in with a count of the
* number of characters in the backslash sequence.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char
Tcl_Backslash(src, readPtr)
CONST char *src; /* Points to the backslash character of
* a backslash sequence. */
int *readPtr; /* Fill in with number of characters read
* from src, unless NULL. */
{
char buf[TCL_UTF_MAX];
Tcl_UniChar ch;
Tcl_UtfBackslash(src, readPtr, buf);
TclUtfToUniChar(buf, &ch);
return (char) ch;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Concat --
*
* Concatenate a set of strings into a single large string.
*
* Results:
* The return value is dynamically-allocated string containing
* a concatenation of all the strings in argv, with spaces between
* the original argv elements.
*
* Side effects:
* Memory is allocated for the result; the caller is responsible
* for freeing the memory.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Concat(argc, argv)
int argc; /* Number of strings to concatenate. */
CONST char * CONST *argv; /* Array of strings to concatenate. */
{
int totalSize, i;
char *p;
char *result;
for (totalSize = 1, i = 0; i < argc; i++) {
totalSize += strlen(argv[i]) + 1;
}
result = (char *) ckalloc((unsigned) totalSize);
if (argc == 0) {
*result = '\0';
return result;
}
for (p = result, i = 0; i < argc; i++) {
CONST char *element;
int length;
/*
* Clip white space off the front and back of the string
* to generate a neater result, and ignore any empty
* elements.
*/
element = argv[i];
while (isspace(UCHAR(*element))) { /* INTL: ISO space. */
element++;
}
for (length = strlen(element);
(length > 0)
&& (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */
&& ((length < 2) || (element[length-2] != '\\'));
length--) {
/* Null loop body. */
}
if (length == 0) {
continue;
}
memcpy((VOID *) p, (VOID *) element, (size_t) length);
p += length;
*p = ' ';
p++;
}
if (p != result) {
p[-1] = 0;
} else {
*p = 0;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConcatObj --
*
* Concatenate the strings from a set of objects into a single string
* object with spaces between the original strings.
*
* Results:
* The return value is a new string object containing a concatenation
* of the strings in objv. Its ref count is zero.
*
* Side effects:
* A new object is created.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ConcatObj(objc, objv)
int objc; /* Number of objects to concatenate. */
Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */
{
int allocSize, finalSize, length, elemLength, i;
char *p;
char *element;
char *concatStr;
Tcl_Obj *objPtr;
/*
* Check first to see if all the items are of list type. If so,
* we will concat them together as lists, and return a list object.
* This is only valid when the lists have no current string
* representation, since we don't know what the original type was.
* An original string rep may have lost some whitespace info when
* converted which could be important.
*/
for (i = 0; i < objc; i++) {
objPtr = objv[i];
if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) {
break;
}
}
if (i == objc) {
Tcl_Obj **listv;
int listc;
objPtr = Tcl_NewListObj(0, NULL);
for (i = 0; i < objc; i++) {
/*
* Tcl_ListObjAppendList could be used here, but this saves
* us a bit of type checking (since we've already done it)
* Use of INT_MAX tells us to always put the new stuff on
* the end. It will be set right in Tcl_ListObjReplace.
*/
Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv);
Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv);
}
return objPtr;
}
allocSize = 0;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
element = Tcl_GetStringFromObj(objPtr, &length);
if ((element != NULL) && (length > 0)) {
allocSize += (length + 1);
}
}
if (allocSize == 0) {
allocSize = 1; /* enough for the NULL byte at end */
}
/*
* Allocate storage for the concatenated result. Note that allocSize
* is one more than the total number of characters, and so includes
* room for the terminating NULL byte.
*/
concatStr = (char *) ckalloc((unsigned) allocSize);
/*
* Now concatenate the elements. Clip white space off the front and back
* to generate a neater result, and ignore any empty elements. Also put
* a null byte at the end.
*/
finalSize = 0;
if (objc == 0) {
*concatStr = '\0';
} else {
p = concatStr;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
element = Tcl_GetStringFromObj(objPtr, &elemLength);
while ((elemLength > 0) && (UCHAR(*element) < 127)
&& isspace(UCHAR(*element))) { /* INTL: ISO C space. */
element++;
elemLength--;
}
/*
* Trim trailing white space. But, be careful not to trim
* a space character if it is preceded by a backslash: in
* this case it could be significant.
*/
while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127)
&& isspace(UCHAR(element[elemLength-1])) /* INTL: ISO C space. */
&& ((elemLength < 2) || (element[elemLength-2] != '\\'))) {
elemLength--;
}
if (elemLength == 0) {
continue; /* nothing left of this element */
}
memcpy((VOID *) p, (VOID *) element, (size_t) elemLength);
p += elemLength;
*p = ' ';
p++;
finalSize += (elemLength + 1);
}
if (p != concatStr) {
p[-1] = 0;
finalSize -= 1; /* we overwrote the final ' ' */
} else {
*p = 0;
}
}
TclNewObj(objPtr);
objPtr->bytes = concatStr;
objPtr->length = finalSize;
return objPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_StringMatch --
*
* See if a particular string matches a particular pattern.
*
* Results:
* The return value is 1 if string matches pattern, and
* 0 otherwise. The matching operation permits the following
* special characters in the pattern: *?\[] (see the manual
* entry for details on what these mean).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_StringMatch(string, pattern)
CONST char *string; /* String. */
CONST char *pattern; /* Pattern, which may contain special
* characters. */
{
return Tcl_StringCaseMatch(string, pattern, 0);
}
/*
*----------------------------------------------------------------------
*
* Tcl_StringCaseMatch --
*
* See if a particular string matches a particular pattern.
* Allows case insensitivity.
*
* Results:
* The return value is 1 if string matches pattern, and
* 0 otherwise. The matching operation permits the following
* special characters in the pattern: *?\[] (see the manual
* entry for details on what these mean).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_StringCaseMatch(string, pattern, nocase)
CONST char *string; /* String. */
CONST char *pattern; /* Pattern, which may contain special
* characters. */
int nocase; /* 0 for case sensitive, 1 for insensitive */
{
int p, charLen;
CONST char *pstart = pattern;
Tcl_UniChar ch1, ch2;
while (1) {
p = *pattern;
/*
* See if we're at the end of both the pattern and the string. If
* so, we succeeded. If we're at the end of the pattern but not at
* the end of the string, we failed.
*/
if (p == '\0') {
return (*string == '\0');
}
if ((*string == '\0') && (p != '*')) {
return 0;
}
/*
* Check for a "*" as the next pattern character. It matches
* any substring. We handle this by calling ourselves
* recursively for each postfix of string, until either we
* match or we reach the end of the string.
*/
if (p == '*') {
/*
* Skip all successive *'s in the pattern
*/
while (*(++pattern) == '*') {}
p = *pattern;
if (p == '\0') {
return 1;
}
/*
* This is a special case optimization for single-byte utf.
*/
if (UCHAR(*pattern) < 0x80) {
ch2 = (Tcl_UniChar)
(nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
} else {
Tcl_UtfToUniChar(pattern, &ch2);
if (nocase) {
ch2 = Tcl_UniCharToLower(ch2);
}
}
while (1) {
/*
* Optimization for matching - cruise through the string
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*string) {
charLen = TclUtfToUniChar(string, &ch1);
if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
break;
}
string += charLen;
}
} else {
/*
* There's no point in trying to make this code
* shorter, as the number of bytes you want to
* compare each time is non-constant.
*/
while (*string) {
charLen = TclUtfToUniChar(string, &ch1);
if (ch2 == ch1) {
break;
}
string += charLen;
}
}
}
if (Tcl_StringCaseMatch(string, pattern, nocase)) {
return 1;
}
if (*string == '\0') {
return 0;
}
string += TclUtfToUniChar(string, &ch1);
}
}
/*
* Check for a "?" as the next pattern character. It matches
* any single character.
*/
if (p == '?') {
pattern++;
string += TclUtfToUniChar(string, &ch1);
continue;
}
/*
* Check for a "[" as the next pattern character. It is followed
* by a list of characters that are acceptable, or by a range
* (two characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar startChar, endChar;
pattern++;
if (UCHAR(*string) < 0x80) {
ch1 = (Tcl_UniChar)
(nocase ? tolower(UCHAR(*string)) : UCHAR(*string));
string++;
} else {
string += Tcl_UtfToUniChar(string, &ch1);
if (nocase) {
ch1 = Tcl_UniCharToLower(ch1);
}
}
while (1) {
if ((*pattern == ']') || (*pattern == '\0')) {
return 0;
}
if (UCHAR(*pattern) < 0x80) {
startChar = (Tcl_UniChar)
(nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
pattern += Tcl_UtfToUniChar(pattern, &startChar);
if (nocase) {
startChar = Tcl_UniCharToLower(startChar);
}
}
if (*pattern == '-') {
pattern++;
if (*pattern == '\0') {
return 0;
}
if (UCHAR(*pattern) < 0x80) {
endChar = (Tcl_UniChar)
(nocase ? tolower(UCHAR(*pattern))
: UCHAR(*pattern));
pattern++;
} else {
pattern += Tcl_UtfToUniChar(pattern, &endChar);
if (nocase) {
endChar = Tcl_UniCharToLower(endChar);
}
}
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
break;
}
} else if (startChar == ch1) {
break;
}
}
while (*pattern != ']') {
if (*pattern == '\0') {
pattern = Tcl_UtfPrev(pattern, pstart);
break;
}
pattern++;
}
pattern++;
continue;
}
/*
* If the next pattern character is '\', just strip off the '\'
* so we do exact matching on the character that follows.
*/
if (p == '\\') {
pattern++;
if (*pattern == '\0') {
return 0;
}
}
/*
* There's no special character. Just make sure that the next
* bytes of each string match.
*/
string += TclUtfToUniChar(string, &ch1);
pattern += TclUtfToUniChar(pattern, &ch2);
if (nocase) {
if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
return 0;
}
} else if (ch1 != ch2) {
return 0;
}
}
}
/*
*----------------------------------------------------------------------
*
* TclMatchIsTrivial --
*
* Test whether a particular glob pattern is a trivial pattern.
* (i.e. where matching is the same as equality testing).
*
* Results:
* A boolean indicating whether the pattern is free of all of the
* glob special chars.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclMatchIsTrivial(pattern)
CONST char *pattern;
{
CONST char *p = pattern;
while (1) {
switch (*p++) {
case '\0':
return 1;
case '*':
case '?':
case '[':
case '\\':
return 0;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringInit --
*
* Initializes a dynamic string, discarding any previous contents
* of the string (Tcl_DStringFree should have been called already
* if the dynamic string was previously in use).
*
* Results:
* None.
*
* Side effects:
* The dynamic string is initialized to be empty.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringInit(dsPtr)
Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */
{
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
dsPtr->staticSpace[0] = '\0';
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringAppend --
*
* Append more characters to the current value of a dynamic string.
*
* Results:
* The return value is a pointer to the dynamic string's new value.
*
* Side effects:
* Length bytes from string (or all of string if length is less
* than zero) are added to the current value of the string. Memory
* gets reallocated if needed to accomodate the string's new size.
*
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppend(dsPtr, string, length)
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
CONST char *string; /* String to append. If length is -1 then
* this must be null-terminated. */
int length; /* Number of characters from string to
* append. If < 0, then append all of string,
* up to null at end. */
{
int newSize;
char *dst;
CONST char *end;
if (length < 0) {
length = strlen(string);
}
newSize = length + dsPtr->length;
/*
* Allocate a larger buffer for the string if the current one isn't
* large enough. Allocate extra space in the new buffer so that there
* will be room to grow before we have to allocate again.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
char *newString;
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
memcpy((VOID *) newString, (VOID *) dsPtr->string,
(size_t) dsPtr->length);
dsPtr->string = newString;
} else {
dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
(size_t) dsPtr->spaceAvl);
}
}
/*
* Copy the new string into the buffer at the end of the old
* one.
*/
for (dst = dsPtr->string + dsPtr->length, end = string+length;
string < end; string++, dst++) {
*dst = *string;
}
*dst = '\0';
dsPtr->length += length;
return dsPtr->string;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringAppendElement --
*
* Append a list element to the current value of a dynamic string.
*
* Results:
* The return value is a pointer to the dynamic string's new value.
*
* Side effects:
* String is reformatted as a list element and added to the current
* value of the string. Memory gets reallocated if needed to
* accomodate the string's new size.
*
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppendElement(dsPtr, string)
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
CONST char *string; /* String to append. Must be
* null-terminated. */
{
int newSize, flags, strSize;
char *dst;
strSize = ((string == NULL) ? 0 : strlen(string));
newSize = Tcl_ScanCountedElement(string, strSize, &flags)
+ dsPtr->length + 1;
/*
* Allocate a larger buffer for the string if the current one isn't
* large enough. Allocate extra space in the new buffer so that there
* will be room to grow before we have to allocate again.
* SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
* to a larger buffer, since there may be embedded NULLs in the
* string in some cases.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
char *newString;
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
memcpy((VOID *) newString, (VOID *) dsPtr->string,
(size_t) dsPtr->length);
dsPtr->string = newString;
} else {
dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
(size_t) dsPtr->spaceAvl);
}
}
/*
* Convert the new string to a list element and copy it into the
* buffer at the end, with a space, if needed.
*/
dst = dsPtr->string + dsPtr->length;
if (TclNeedSpace(dsPtr->string, dst)) {
*dst = ' ';
dst++;
dsPtr->length++;
}
dsPtr->length += Tcl_ConvertCountedElement(string, strSize, dst, flags);
return dsPtr->string;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringSetLength --
*
* Change the length of a dynamic string. This can cause the
* string to either grow or shrink, depending on the value of
* length.
*
* Results:
* None.
*
* Side effects:
* The length of dsPtr is changed to length and a null byte is
* stored at that position in the string. If length is larger
* than the space allocated for dsPtr, then a panic occurs.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringSetLength(dsPtr, length)
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
int length; /* New length for dynamic string. */
{
int newsize;
if (length < 0) {
length = 0;
}
if (length >= dsPtr->spaceAvl) {
/*
* There are two interesting cases here. In the first case, the user
* may be trying to allocate a large buffer of a specific size. It
* would be wasteful to overallocate that buffer, so we just allocate
* enough for the requested size plus the trailing null byte. In the
* second case, we are growing the buffer incrementally, so we need
* behavior similar to Tcl_DStringAppend. The requested length will
* usually be a small delta above the current spaceAvl, so we'll end up
* doubling the old size. This won't grow the buffer quite as quickly,
* but it should be close enough.
*/
newsize = dsPtr->spaceAvl * 2;
if (length < newsize) {
dsPtr->spaceAvl = newsize;
} else {
dsPtr->spaceAvl = length + 1;
}
if (dsPtr->string == dsPtr->staticSpace) {
char *newString;
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
memcpy((VOID *) newString, (VOID *) dsPtr->string,
(size_t) dsPtr->length);
dsPtr->string = newString;
} else {
dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
(size_t) dsPtr->spaceAvl);
}
}
dsPtr->length = length;
dsPtr->string[length] = 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringFree --
*
* Frees up any memory allocated for the dynamic string and
* reinitializes the string to an empty state.
*
* Results:
* None.
*
* Side effects:
* The previous contents of the dynamic string are lost, and
* the new value is an empty string.
*
*---------------------------------------------------------------------- */
void
Tcl_DStringFree(dsPtr)
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
{
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
}
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
dsPtr->staticSpace[0] = '\0';
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringResult --
*
* This procedure moves the value of a dynamic string into an
* interpreter as its string result. Afterwards, the dynamic string
* is reset to an empty string.
*
* Results:
* None.
*
* Side effects:
* The string is "moved" to interp's result, and any existing
* string result for interp is freed. dsPtr is reinitialized to
* an empty string.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringResult(interp, dsPtr)
Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr; /* Dynamic string that is to become the
* result of interp. */
{
Tcl_ResetResult(interp);
if (dsPtr->string != dsPtr->staticSpace) {
interp->result = dsPtr->string;
interp->freeProc = TCL_DYNAMIC;
} else if (dsPtr->length < TCL_RESULT_SIZE) {
interp->result = ((Interp *) interp)->resultSpace;
strcpy(interp->result, dsPtr->string);
} else {
Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
}
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
dsPtr->staticSpace[0] = '\0';
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringGetResult --
*
* This procedure moves an interpreter's result into a dynamic string.
*
* Results:
* None.
*
* Side effects:
* The interpreter's string result is cleared, and the previous
* contents of dsPtr are freed.
*
* If the string result is empty, the object result is moved to the
* string result, then the object result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringGetResult(interp, dsPtr)
Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr; /* Dynamic string that is to become the
* result of interp. */
{
Interp *iPtr = (Interp *) interp;
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
}
/*
* If the string result is empty, move the object result to the
* string result, then reset the object result.
*/
if (*(iPtr->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
dsPtr->length = strlen(iPtr->result);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
dsPtr->string = iPtr->result;
dsPtr->spaceAvl = dsPtr->length+1;
} else {
dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1));
strcpy(dsPtr->string, iPtr->result);
(*iPtr->freeProc)(iPtr->result);
}
dsPtr->spaceAvl = dsPtr->length+1;
iPtr->freeProc = NULL;
} else {
if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) {
dsPtr->string = dsPtr->staticSpace;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
} else {
dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1));
dsPtr->spaceAvl = dsPtr->length + 1;
}
strcpy(dsPtr->string, iPtr->result);
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringStartSublist --
*
* This procedure adds the necessary information to a dynamic
* string (e.g. " {" to start a sublist. Future element
* appends will be in the sublist rather than the main list.
*
* Results:
* None.
*
* Side effects:
* Characters get added to the dynamic string.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringStartSublist(dsPtr)
Tcl_DString *dsPtr; /* Dynamic string. */
{
if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
Tcl_DStringAppend(dsPtr, " {", -1);
} else {
Tcl_DStringAppend(dsPtr, "{", -1);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringEndSublist --
*
* This procedure adds the necessary characters to a dynamic
* string to end a sublist (e.g. "}"). Future element appends
* will be in the enclosing (sub)list rather than the current
* sublist.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringEndSublist(dsPtr)
Tcl_DString *dsPtr; /* Dynamic string. */
{
Tcl_DStringAppend(dsPtr, "}", -1);
}
/*
*----------------------------------------------------------------------
*
* InitPrecision --
*
* Set the default value for tcl_precision to 12.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
InitPrecision(valuePtr, lengthPtr)
char **valuePtr;
int *lengthPtr;
{
*lengthPtr = 2;
*valuePtr = ckalloc(3);
memcpy(*valuePtr, "12", 3);
}
/*
*----------------------------------------------------------------------
*
* Tcl_PrintDouble --
*
* Given a floating-point value, this procedure converts it to
* an ASCII string using.
*
* Results:
* The ASCII equivalent of "value" is written at "dst". It is
* written using the current precision, and it is guaranteed to
* contain a decimal point or exponent, so that it looks like
* a floating-point value and not an integer.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_PrintDouble(interp, value, dst)
Tcl_Interp *interp; /* Interpreter whose tcl_precision
* variable used to be used to control
* printing. It's ignored now. */
double value; /* Value to print as string. */
char *dst; /* Where to store converted value;
* must have at least TCL_DOUBLE_SPACE
* characters. */
{
char *p, c;
char format[10];
Tcl_UniChar ch;
Tcl_Obj *precisionObj = GetPGV(&precision);
sprintf(format, "%%.%sg", Tcl_GetString(precisionObj));
sprintf(dst, format, value);
/*
* If the ASCII result looks like an integer, add ".0" so that it
* doesn't look like an integer anymore. This prevents floating-point
* values from being converted to integers unintentionally.
* Check for ASCII specifically to speed up the function.
*/
for (p = dst; *p != 0; ) {
if (UCHAR(*p) < 0x80) {
c = *p++;
} else {
p += Tcl_UtfToUniChar(p, &ch);
c = UCHAR(ch);
}
if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */
return;
}
}
p[0] = '.';
p[1] = '0';
p[2] = 0;
}
/*
*----------------------------------------------------------------------
*
* TclPrecTraceProc --
*
* This procedure is invoked whenever the variable "tcl_precision"
* is written.
*
* Results:
* Returns NULL if all went well, or an error message if the
* new value for the variable doesn't make sense.
*
* Side effects:
* If the new value doesn't make sense then this procedure
* undoes the effect of the variable modification. Otherwise
* it modifies the format string that's used by Tcl_PrintDouble.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
char *
TclPrecTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *name1; /* Name of variable. */
CONST char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
{
CONST char *value;
char *end;
int prec;
/*
* If the variable is unset, then recreate the trace.
*/
if (flags & TCL_TRACE_UNSETS) {
if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) {
Tcl_TraceVar2(interp, name1, name2,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
}
return (char *) NULL;
}
/*
* When the variable is read, reset its value from our shared
* value. This is needed in case the variable was modified in
* some other interpreter so that this interpreter's value is
* out of date.
*/
if (flags & TCL_TRACE_READS) {
Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision),
flags & TCL_GLOBAL_ONLY);
return (char *) NULL;
}
/*
* The variable is being written. Check the new value and disallow
* it if it isn't reasonable or if this is a safe interpreter (we
* don't want safe interpreters messing up the precision of other
* interpreters).
*/
if (Tcl_IsSafe(interp)) {
Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision),
flags & TCL_GLOBAL_ONLY);
return "can't modify precision from a safe interpreter";
}
value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
if (value == NULL) {
value = "";
}
prec = strtoul(value, &end, 10);
if ((prec <= 0) || (prec > TCL_MAX_PREC)
|| (end == value) || (*end != 0)) {
Tcl_SetVar2Ex(interp, name1, name2, GetPGV(&precision),
flags & TCL_GLOBAL_ONLY);
return "improper value for precision";
}
SetPGV(&precision, Tcl_NewIntObj(prec));
return (char *) NULL;
}
/*
*----------------------------------------------------------------------
*
* TclNeedSpace --
*
* This procedure checks to see whether it is appropriate to
* add a space before appending a new list element to an
* existing string.
*
* Results:
* The return value is 1 if a space is appropriate, 0 otherwise.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclNeedSpace(start, end)
CONST char *start; /* First character in string. */
CONST char *end; /* End of string (place where space will
* be added, if appropriate). */
{
/*
* A space is needed unless either
* (a) we're at the start of the string, or
*/
if (end == start) {
return 0;
}
/*
* (b) we're at the start of a nested list-element, quoted with an
* open curly brace; we can be nested arbitrarily deep, so long
* as the first curly brace starts an element, so backtrack over
* open curly braces that are trailing characters of the string; and
*/
end = Tcl_UtfPrev(end, start);
while (*end == '{') {
if (end == start) {
return 0;
}
end = Tcl_UtfPrev(end, start);
}
/*
* (c) the trailing character of the string is already a list-element
* separator (according to TclFindElement); that is, one of these
* characters:
* \u0009 \t TAB
* \u000A \n NEWLINE
* \u000B \v VERTICAL TAB
* \u000C \f FORM FEED
* \u000D \r CARRIAGE RETURN
* \u0020 SPACE
* with the condition that the penultimate character is not a
* backslash.
*/
if (*end > 0x20) {
/*
* Performance tweak. All ASCII spaces are <= 0x20. So get
* a quick answer for most characters before comparing against
* all spaces in the switch below.
*
* NOTE: Remove this if other Unicode spaces ever get accepted
* as list-element separators.
*/
return 1;
}
switch (*end) {
case ' ':
case '\t':
case '\n':
case '\r':
case '\v':
case '\f':
if ((end == start) || (end[-1] != '\\')) {
return 0;
}
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* TclFormatInt --
*
* This procedure formats an integer into a sequence of decimal digit
* characters in a buffer. If the integer is negative, a minus sign is
* inserted at the start of the buffer. A null character is inserted at
* the end of the formatted characters. It is the caller's
* responsibility to ensure that enough storage is available. This
* procedure has the effect of sprintf(buffer, "%d", n) but is faster.
*
* Results:
* An integer representing the number of characters formatted, not
* including the terminating \0.
*
* Side effects:
* The formatted characters are written into the storage pointer to
* by the "buffer" argument.
*
*----------------------------------------------------------------------
*/
int
TclFormatInt(buffer, n)
char *buffer; /* Points to the storage into which the
* formatted characters are written. */
long n; /* The integer to format. */
{
long intVal;
int i;
int numFormatted, j;
char *digits = "0123456789";
/*
* Check first whether "n" is zero.
*/
if (n == 0) {
buffer[0] = '0';
buffer[1] = 0;
return 1;
}
/*
* Check whether "n" is the maximum negative value. This is
* -2^(m-1) for an m-bit word, and has no positive equivalent;
* negating it produces the same value.
*/
intVal = -n; /* [Bug 3390638] Workaround for*/
if (n == -n || intVal == n) { /* broken compiler optimizers. */
sprintf(buffer, "%ld", n);
return strlen(buffer);
}
/*
* Generate the characters of the result backwards in the buffer.
*/
intVal = (n < 0? -n : n);
i = 0;
buffer[0] = '\0';
do {
i++;
buffer[i] = digits[intVal % 10];
intVal = intVal/10;
} while (intVal > 0);
if (n < 0) {
i++;
buffer[i] = '-';
}
numFormatted = i;
/*
* Now reverse the characters.
*/
for (j = 0; j < i; j++, i--) {
char tmp = buffer[i];
buffer[i] = buffer[j];
buffer[j] = tmp;
}
return numFormatted;
}
/*
*----------------------------------------------------------------------
*
* TclLooksLikeInt --
*
* This procedure decides whether the leading characters of a
* string look like an integer or something else (such as a
* floating-point number or string).
*
* Results:
* The return value is 1 if the leading characters of p look
* like a valid Tcl integer. If they look like a floating-point
* number (e.g. "e01" or "2.4"), or if they don't look like a
* number at all, then 0 is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclLooksLikeInt(bytes, length)
register CONST char *bytes; /* Points to first byte of the string. */
int length; /* Number of bytes in the string. If < 0
* bytes up to the first null byte are
* considered (if they may appear in an
* integer). */
{
register CONST char *p;
if ((bytes == NULL) && (length > 0)) {
Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length);
}
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
}
p = bytes;
while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */
length--; p++;
}
if (length == 0) {
return 0;
}
if ((*p == '+') || (*p == '-')) {
p++; length--;
}
return (0 != TclParseInteger(p, length));
}
/*
*----------------------------------------------------------------------
*
* TclGetIntForIndex --
*
* This procedure returns an integer corresponding to the list index
* held in a Tcl object. The Tcl object's value is expected to be
* either an integer or a string of the form "end([+-]integer)?".
*
* Results:
* The return value is normally TCL_OK, which means that the index was
* successfully stored into the location referenced by "indexPtr". If
* the Tcl object referenced by "objPtr" has the value "end", the
* value stored is "endValue". If "objPtr"s values is not of the form
* "end([+-]integer)?" and
* can not be converted to an integer, TCL_ERROR is returned and, if
* "interp" is non-NULL, an error message is left in the interpreter's
* result object.
*
* Side effects:
* The object referenced by "objPtr" might be converted to an
* integer, wide integer, or end-based-index object.
*
*----------------------------------------------------------------------
*/
int
TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, then no error message is left
* after errors. */
Tcl_Obj *objPtr; /* Points to an object containing either
* "end" or an integer. */
int endValue; /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
int *indexPtr; /* Location filled in with an integer
* representing an index. */
{
if (Tcl_GetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) {
return TCL_OK;
}
if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
/*
* If the object is already an offset from the end of the
* list, or can be converted to one, use it.
*/
*indexPtr = endValue + objPtr->internalRep.longValue;
} else {
/*
* Report a parse error.
*/
if (interp != NULL) {
char *bytes = Tcl_GetString(objPtr);
/*
* The result might not be empty; this resets it which
* should be both a cheap operation, and of little problem
* because this is an error-generation path anyway.
*/
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad index \"", bytes,
"\": must be integer or end?-integer?",
(char *) NULL);
if (!strncmp(bytes, "end-", 3)) {
bytes += 3;
}
TclCheckBadOctal(interp, bytes);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfEndOffset --
*
* Update the string rep of a Tcl object holding an "end-offset"
* expression.
*
* Results:
* None.
*
* Side effects:
* Stores a valid string in the object's string rep.
*
* This procedure does NOT free any earlier string rep. If it is
* called on an object that already has a valid string rep, it will
* leak memory.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfEndOffset(objPtr)
register Tcl_Obj* objPtr;
{
char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1];
register int len;
strcpy(buffer, "end");
len = sizeof("end") - 1;
if (objPtr->internalRep.longValue != 0) {
buffer[len++] = '-';
len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
}
objPtr->bytes = ckalloc((unsigned) (len+1));
strcpy(objPtr->bytes, buffer);
objPtr->length = len;
}
/*
*----------------------------------------------------------------------
*
* SetEndOffsetFromAny --
*
* Look for a string of the form "end-offset" and convert it
* to an internal representation holding the offset.
*
* Results:
* Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
*
* Side effects:
* If interp is not NULL, stores an error message in the
* interpreter result.
*
*----------------------------------------------------------------------
*/
static int
SetEndOffsetFromAny(interp, objPtr)
Tcl_Interp* interp; /* Tcl interpreter or NULL */
Tcl_Obj* objPtr; /* Pointer to the object to parse */
{
int offset; /* Offset in the "end-offset" expression */
Tcl_ObjType* oldTypePtr = objPtr->typePtr;
/* Old internal rep type of the object */
register char* bytes; /* String rep of the object */
int length; /* Length of the object's string rep */
/* If it's already the right type, we're fine. */
if (objPtr->typePtr == &tclEndOffsetType) {
return TCL_OK;
}
/* Check for a string rep of the right form. */
bytes = Tcl_GetStringFromObj(objPtr, &length);
if ((*bytes != 'e') || (strncmp(bytes, "end",
(size_t)((length > 3) ? 3 : length)) != 0)) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad index \"", bytes,
"\": must be end?-integer?",
(char*) NULL);
}
return TCL_ERROR;
}
/* Convert the string rep */
if (length <= 3) {
offset = 0;
} else if ((length > 4) && (bytes[3] == '-')) {
/*
* This is our limited string expression evaluator. Pass everything
* after "end-" to Tcl_GetInt, then reverse for offset.
*/
if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
return TCL_ERROR;
}
offset = -offset;
} else {
/*
* Conversion failed. Report the error.
*/
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad index \"", bytes,
"\": must be integer or end?-integer?",
(char *) NULL);
}
return TCL_ERROR;
}
/*
* The conversion succeeded. Free the old internal rep and set
* the new one.
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.longValue = offset;
objPtr->typePtr = &tclEndOffsetType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCheckBadOctal --
*
* This procedure checks for a bad octal value and appends a
* meaningful error to the interp's result.
*
* Results:
* 1 if the argument was a bad octal, else 0.
*
* Side effects:
* The interpreter's result is modified.
*
*----------------------------------------------------------------------
*/
int
TclCheckBadOctal(interp, value)
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, then no error message is left
* after errors. */
CONST char *value; /* String to check. */
{
register CONST char *p = value;
/*
* A frequent mistake is invalid octal values due to an unwanted
* leading zero. Try to generate a meaningful error message.
*/
while (isspace(UCHAR(*p))) { /* INTL: ISO space. */
p++;
}
if (*p == '+' || *p == '-') {
p++;
}
if (*p == '0') {
while (isdigit(UCHAR(*p))) { /* INTL: digit. */
p++;
}
while (isspace(UCHAR(*p))) { /* INTL: ISO space. */
p++;
}
if (*p == '\0') {
/* Reached end of string */
if (interp != NULL) {
/*
* Don't reset the result here because we want this result
* to be added to an existing error message as extra info.
*/
Tcl_AppendResult(interp, " (looks like invalid octal number)",
(char *) NULL);
}
return 1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* ClearHash --
*
* Remove all the entries in the hash table *tablePtr.
*
*----------------------------------------------------------------------
*/
static void
ClearHash(tablePtr)
Tcl_HashTable *tablePtr;
{
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(objPtr);
Tcl_DeleteHashEntry(hPtr);
}
}
/*
*----------------------------------------------------------------------
*
* GetThreadHash --
*
* Get a thread-specific (Tcl_HashTable *) associated with a thread data
* key.
*
* Results:
* The Tcl_HashTable * corresponding to *keyPtr.
*
* Side effects:
* The first call on a keyPtr in each thread creates a new Tcl_HashTable,
* and registers a thread exit handler to dispose of it.
*
*----------------------------------------------------------------------
*/
static Tcl_HashTable *
GetThreadHash(keyPtr)
Tcl_ThreadDataKey *keyPtr;
{
Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **)
Tcl_GetThreadData(keyPtr, (int) sizeof(Tcl_HashTable *));
if (NULL == *tablePtrPtr) {
*tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr);
Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS);
}
return *tablePtrPtr;
}
/*
*----------------------------------------------------------------------
*
* FreeThreadHash --
*
* Thread exit handler used by GetThreadHash to dispose of a thread hash
* table.
*
* Side effects:
* Frees a Tcl_HashTable.
*
*----------------------------------------------------------------------
*/
static void
FreeThreadHash(clientData)
ClientData clientData;
{
Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData;
ClearHash(tablePtr);
Tcl_DeleteHashTable(tablePtr);
ckfree((char *) tablePtr);
}
/*
*----------------------------------------------------------------------
*
* FreePGV --
*
* Exit handler used by (Set|Get)PGV to cleanup a PGV at exit.
*
*----------------------------------------------------------------------
*/
static void
FreePGV(clientData)
ClientData clientData;
{
PGV *pgvPtr = (PGV *) clientData;
pgvPtr->epoch++;
pgvPtr->numBytes = 0;
ckfree(pgvPtr->value);
pgvPtr->value = NULL;
Tcl_MutexFinalize(&pgvPtr->mutex);
}
/*
*----------------------------------------------------------------------
*
* SetPGV --
*
* Utility routine to set a global value shared by all threads in the
* process while keeping a thread-local copy as well.
*
*----------------------------------------------------------------------
*/
static void
SetPGV(pgvPtr, newValue)
PGV *pgvPtr;
Tcl_Obj *newValue;
{
CONST char *bytes;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
int dummy;
Tcl_MutexLock(&pgvPtr->mutex);
/*
* Fill the global string value.
*/
pgvPtr->epoch++;
if (NULL != pgvPtr->value) {
ckfree(pgvPtr->value);
} else {
Tcl_CreateExitHandler(FreePGV, (ClientData) pgvPtr);
}
bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
pgvPtr->value = ckalloc((unsigned) pgvPtr->numBytes + 1);
memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1);
/*
* Fill the local thread copy directly with the Tcl_Obj value to avoid
* loss of the intrep. Increment newValue refCount early to handle case
* where we set a PGV to itself.
*/
Tcl_IncrRefCount(newValue);
cacheMap = GetThreadHash(&pgvPtr->key);
ClearHash(cacheMap);
hPtr = Tcl_CreateHashEntry(cacheMap, (char *) pgvPtr->epoch, &dummy);
Tcl_SetHashValue(hPtr, (ClientData) newValue);
Tcl_MutexUnlock(&pgvPtr->mutex);
}
/*
*----------------------------------------------------------------------
*
* GetPGV --
*
* Retrieve a global value shared among all threads of the process,
* preferring a thread-local copy as long as it remains valid.
*
* Results:
* Returns a (Tcl_Obj *) that holds a copy of the global value.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
GetPGV(pgvPtr)
PGV *pgvPtr;
{
Tcl_Obj *value = NULL;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
int epoch = pgvPtr->epoch;
cacheMap = GetThreadHash(&pgvPtr->key);
hPtr = Tcl_FindHashEntry(cacheMap, (char *) epoch);
if (NULL == hPtr) {
int dummy;
/*
* No cache for the current epoch - must be a new one.
*
* First, clear the cacheMap, as anything in it must refer to some
* expired epoch.
*/
ClearHash(cacheMap);
/*
* If no thread has set the shared value, call the initializer.
*/
Tcl_MutexLock(&pgvPtr->mutex);
if ((NULL == pgvPtr->value) && (pgvPtr->proc)) {
pgvPtr->epoch++;
(*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes);
if (pgvPtr->value == NULL) {
Tcl_Panic("PGV Initializer did not initialize");
}
Tcl_CreateExitHandler(FreePGV, (ClientData) pgvPtr);
}
/*
* Store a copy of the shared value in our epoch-indexed cache.
*/
value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
hPtr = Tcl_CreateHashEntry(cacheMap, (char *) pgvPtr->epoch, &dummy);
Tcl_MutexUnlock(&pgvPtr->mutex);
Tcl_SetHashValue(hPtr, (ClientData) value);
Tcl_IncrRefCount(value);
}
return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetNameOfExecutable --
*
* This procedure simply returns a pointer to the internal full
* path name of the executable file as computed by
* Tcl_FindExecutable. This procedure call is the C API
* equivalent to the "info nameofexecutable" command.
*
* Results:
* A pointer to the internal string or NULL if the internal full
* path name has not been computed or unknown.
*
* Side effects:
* The object referenced by "objPtr" might be converted to an
* integer object.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_GetNameOfExecutable()
{
return tclExecutableName;
}
/*
*----------------------------------------------------------------------
*
* TclpGetTime --
*
* Deprecated synonym for Tcl_GetTime.
*
* Results:
* None.
*
* Side effects:
* Stores current time in the buffer designated by "timePtr"
*
* This procedure is provided for the benefit of extensions written
* before Tcl_GetTime was exported from the library.
*
*----------------------------------------------------------------------
*/
void
TclpGetTime(timePtr)
Tcl_Time* timePtr;
{
Tcl_GetTime(timePtr);
}
tcl8.4.20/generic/regc_lex.c 0000644 0036047 0045461 00000060053 12052456743 014271 0 ustar dgp 771div /*
* lexical analyzer
* This file is #included by regcomp.c.
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*/
/* scanning macros (know about v) */
#define ATEOS() (v->now >= v->stop)
#define HAVE(n) (v->stop - v->now >= (n))
#define NEXT1(c) (!ATEOS() && *v->now == CHR(c))
#define NEXT2(a,b) (HAVE(2) && *v->now == CHR(a) && *(v->now+1) == CHR(b))
#define NEXT3(a,b,c) (HAVE(3) && *v->now == CHR(a) && \
*(v->now+1) == CHR(b) && \
*(v->now+2) == CHR(c))
#define SET(c) (v->nexttype = (c))
#define SETV(c, n) (v->nexttype = (c), v->nextvalue = (n))
#define RET(c) return (SET(c), 1)
#define RETV(c, n) return (SETV(c, n), 1)
#define FAILW(e) return (ERR(e), 0) /* ERR does SET(EOS) */
#define LASTTYPE(t) (v->lasttype == (t))
/* lexical contexts */
#define L_ERE 1 /* mainline ERE/ARE */
#define L_BRE 2 /* mainline BRE */
#define L_Q 3 /* REG_QUOTE */
#define L_EBND 4 /* ERE/ARE bound */
#define L_BBND 5 /* BRE bound */
#define L_BRACK 6 /* brackets */
#define L_CEL 7 /* collating element */
#define L_ECL 8 /* equivalence class */
#define L_CCL 9 /* character class */
#define INTOCON(c) (v->lexcon = (c))
#define INCON(con) (v->lexcon == (con))
/* construct pointer past end of chr array */
#define ENDOF(array) ((array) + sizeof(array)/sizeof(chr))
/*
- lexstart - set up lexical stuff, scan leading options
^ static VOID lexstart(struct vars *);
*/
static VOID
lexstart(v)
struct vars *v;
{
prefixes(v); /* may turn on new type bits etc. */
NOERR();
if (v->cflags®_QUOTE) {
assert(!(v->cflags&(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE)));
INTOCON(L_Q);
} else if (v->cflags®_EXTENDED) {
assert(!(v->cflags®_QUOTE));
INTOCON(L_ERE);
} else {
assert(!(v->cflags&(REG_QUOTE|REG_ADVF)));
INTOCON(L_BRE);
}
v->nexttype = EMPTY; /* remember we were at the start */
next(v); /* set up the first token */
}
/*
- prefixes - implement various special prefixes
^ static VOID prefixes(struct vars *);
*/
static VOID
prefixes(v)
struct vars *v;
{
/* literal string doesn't get any of this stuff */
if (v->cflags®_QUOTE)
return;
/* initial "***" gets special things */
if (HAVE(4) && NEXT3('*', '*', '*'))
switch (*(v->now + 3)) {
case CHR('?'): /* "***?" error, msg shows version */
ERR(REG_BADPAT);
return; /* proceed no further */
break;
case CHR('='): /* "***=" shifts to literal string */
NOTE(REG_UNONPOSIX);
v->cflags |= REG_QUOTE;
v->cflags &= ~(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE);
v->now += 4;
return; /* and there can be no more prefixes */
break;
case CHR(':'): /* "***:" shifts to AREs */
NOTE(REG_UNONPOSIX);
v->cflags |= REG_ADVANCED;
v->now += 4;
break;
default: /* otherwise *** is just an error */
ERR(REG_BADRPT);
return;
break;
}
/* BREs and EREs don't get embedded options */
if ((v->cflags®_ADVANCED) != REG_ADVANCED)
return;
/* embedded options (AREs only) */
if (HAVE(3) && NEXT2('(', '?') && iscalpha(*(v->now + 2))) {
NOTE(REG_UNONPOSIX);
v->now += 2;
for (; !ATEOS() && iscalpha(*v->now); v->now++)
switch (*v->now) {
case CHR('b'): /* BREs (but why???) */
v->cflags &= ~(REG_ADVANCED|REG_QUOTE);
break;
case CHR('c'): /* case sensitive */
v->cflags &= ~REG_ICASE;
break;
case CHR('e'): /* plain EREs */
v->cflags |= REG_EXTENDED;
v->cflags &= ~(REG_ADVF|REG_QUOTE);
break;
case CHR('i'): /* case insensitive */
v->cflags |= REG_ICASE;
break;
case CHR('m'): /* Perloid synonym for n */
case CHR('n'): /* \n affects ^ $ . [^ */
v->cflags |= REG_NEWLINE;
break;
case CHR('p'): /* ~Perl, \n affects . [^ */
v->cflags |= REG_NLSTOP;
v->cflags &= ~REG_NLANCH;
break;
case CHR('q'): /* literal string */
v->cflags |= REG_QUOTE;
v->cflags &= ~REG_ADVANCED;
break;
case CHR('s'): /* single line, \n ordinary */
v->cflags &= ~REG_NEWLINE;
break;
case CHR('t'): /* tight syntax */
v->cflags &= ~REG_EXPANDED;
break;
case CHR('w'): /* weird, \n affects ^ $ only */
v->cflags &= ~REG_NLSTOP;
v->cflags |= REG_NLANCH;
break;
case CHR('x'): /* expanded syntax */
v->cflags |= REG_EXPANDED;
break;
default:
ERR(REG_BADOPT);
return;
}
if (!NEXT1(')')) {
ERR(REG_BADOPT);
return;
}
v->now++;
if (v->cflags®_QUOTE)
v->cflags &= ~(REG_EXPANDED|REG_NEWLINE);
}
}
/*
- lexnest - "call a subroutine", interpolating string at the lexical level
* Note, this is not a very general facility. There are a number of
* implicit assumptions about what sorts of strings can be subroutines.
^ static VOID lexnest(struct vars *, chr *, chr *);
*/
static VOID
lexnest(v, beginp, endp)
struct vars *v;
CONST chr *beginp; /* start of interpolation */
CONST chr *endp; /* one past end of interpolation */
{
assert(v->savenow == NULL); /* only one level of nesting */
v->savenow = v->now;
v->savestop = v->stop;
v->now = beginp;
v->stop = endp;
}
/*
* string constants to interpolate as expansions of things like \d
*/
static CONST chr backd[] = { /* \d */
CHR('['), CHR('['), CHR(':'),
CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'),
CHR(':'), CHR(']'), CHR(']')
};
static CONST chr backD[] = { /* \D */
CHR('['), CHR('^'), CHR('['), CHR(':'),
CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'),
CHR(':'), CHR(']'), CHR(']')
};
static CONST chr brbackd[] = { /* \d within brackets */
CHR('['), CHR(':'),
CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'),
CHR(':'), CHR(']')
};
static CONST chr backs[] = { /* \s */
CHR('['), CHR('['), CHR(':'),
CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'),
CHR(':'), CHR(']'), CHR(']')
};
static CONST chr backS[] = { /* \S */
CHR('['), CHR('^'), CHR('['), CHR(':'),
CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'),
CHR(':'), CHR(']'), CHR(']')
};
static CONST chr brbacks[] = { /* \s within brackets */
CHR('['), CHR(':'),
CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'),
CHR(':'), CHR(']')
};
static CONST chr backw[] = { /* \w */
CHR('['), CHR('['), CHR(':'),
CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'),
CHR(':'), CHR(']'), CHR('_'), CHR(']')
};
static CONST chr backW[] = { /* \W */
CHR('['), CHR('^'), CHR('['), CHR(':'),
CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'),
CHR(':'), CHR(']'), CHR('_'), CHR(']')
};
static CONST chr brbackw[] = { /* \w within brackets */
CHR('['), CHR(':'),
CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'),
CHR(':'), CHR(']'), CHR('_')
};
/*
- lexword - interpolate a bracket expression for word characters
* Possibly ought to inquire whether there is a "word" character class.
^ static VOID lexword(struct vars *);
*/
static VOID
lexword(v)
struct vars *v;
{
lexnest(v, backw, ENDOF(backw));
}
/*
- next - get next token
^ static int next(struct vars *);
*/
static int /* 1 normal, 0 failure */
next(v)
struct vars *v;
{
chr c;
/* errors yield an infinite sequence of failures */
if (ISERR())
return 0; /* the error has set nexttype to EOS */
/* remember flavor of last token */
v->lasttype = v->nexttype;
/* REG_BOSONLY */
if (v->nexttype == EMPTY && (v->cflags®_BOSONLY)) {
/* at start of a REG_BOSONLY RE */
RETV(SBEGIN, 0); /* same as \A */
}
/* if we're nested and we've hit end, return to outer level */
if (v->savenow != NULL && ATEOS()) {
v->now = v->savenow;
v->stop = v->savestop;
v->savenow = v->savestop = NULL;
}
/* skip white space etc. if appropriate (not in literal or []) */
if (v->cflags®_EXPANDED)
switch (v->lexcon) {
case L_ERE:
case L_BRE:
case L_EBND:
case L_BBND:
skip(v);
break;
}
/* handle EOS, depending on context */
if (ATEOS()) {
switch (v->lexcon) {
case L_ERE:
case L_BRE:
case L_Q:
RET(EOS);
break;
case L_EBND:
case L_BBND:
FAILW(REG_EBRACE);
break;
case L_BRACK:
case L_CEL:
case L_ECL:
case L_CCL:
FAILW(REG_EBRACK);
break;
}
assert(NOTREACHED);
}
/* okay, time to actually get a character */
c = *v->now++;
/* deal with the easy contexts, punt EREs to code below */
switch (v->lexcon) {
case L_BRE: /* punt BREs to separate function */
return brenext(v, c);
break;
case L_ERE: /* see below */
break;
case L_Q: /* literal strings are easy */
RETV(PLAIN, c);
break;
case L_BBND: /* bounds are fairly simple */
case L_EBND:
switch (c) {
case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'):
case CHR('4'): case CHR('5'): case CHR('6'): case CHR('7'):
case CHR('8'): case CHR('9'):
RETV(DIGIT, (chr)DIGITVAL(c));
break;
case CHR(','):
RET(',');
break;
case CHR('}'): /* ERE bound ends with } */
if (INCON(L_EBND)) {
INTOCON(L_ERE);
if ((v->cflags®_ADVF) && NEXT1('?')) {
v->now++;
NOTE(REG_UNONPOSIX);
RETV('}', 0);
}
RETV('}', 1);
} else
FAILW(REG_BADBR);
break;
case CHR('\\'): /* BRE bound ends with \} */
if (INCON(L_BBND) && NEXT1('}')) {
v->now++;
INTOCON(L_BRE);
RET('}');
} else
FAILW(REG_BADBR);
break;
default:
FAILW(REG_BADBR);
break;
}
assert(NOTREACHED);
break;
case L_BRACK: /* brackets are not too hard */
switch (c) {
case CHR(']'):
if (LASTTYPE('['))
RETV(PLAIN, c);
else {
INTOCON((v->cflags®_EXTENDED) ?
L_ERE : L_BRE);
RET(']');
}
break;
case CHR('\\'):
NOTE(REG_UBBS);
if (!(v->cflags®_ADVF))
RETV(PLAIN, c);
NOTE(REG_UNONPOSIX);
if (ATEOS())
FAILW(REG_EESCAPE);
(DISCARD)lexescape(v);
switch (v->nexttype) { /* not all escapes okay here */
case PLAIN:
return 1;
break;
case CCLASS:
switch (v->nextvalue) {
case 'd':
lexnest(v, brbackd, ENDOF(brbackd));
break;
case 's':
lexnest(v, brbacks, ENDOF(brbacks));
break;
case 'w':
lexnest(v, brbackw, ENDOF(brbackw));
break;
default:
FAILW(REG_EESCAPE);
break;
}
/* lexnest done, back up and try again */
v->nexttype = v->lasttype;
return next(v);
break;
}
/* not one of the acceptable escapes */
FAILW(REG_EESCAPE);
break;
case CHR('-'):
if (LASTTYPE('[') || NEXT1(']'))
RETV(PLAIN, c);
else
RETV(RANGE, c);
break;
case CHR('['):
if (ATEOS())
FAILW(REG_EBRACK);
switch (*v->now++) {
case CHR('.'):
INTOCON(L_CEL);
/* might or might not be locale-specific */
RET(COLLEL);
break;
case CHR('='):
INTOCON(L_ECL);
NOTE(REG_ULOCALE);
RET(ECLASS);
break;
case CHR(':'):
INTOCON(L_CCL);
NOTE(REG_ULOCALE);
RET(CCLASS);
break;
default: /* oops */
v->now--;
RETV(PLAIN, c);
break;
}
assert(NOTREACHED);
break;
default:
RETV(PLAIN, c);
break;
}
assert(NOTREACHED);
break;
case L_CEL: /* collating elements are easy */
if (c == CHR('.') && NEXT1(']')) {
v->now++;
INTOCON(L_BRACK);
RETV(END, '.');
} else
RETV(PLAIN, c);
break;
case L_ECL: /* ditto equivalence classes */
if (c == CHR('=') && NEXT1(']')) {
v->now++;
INTOCON(L_BRACK);
RETV(END, '=');
} else
RETV(PLAIN, c);
break;
case L_CCL: /* ditto character classes */
if (c == CHR(':') && NEXT1(']')) {
v->now++;
INTOCON(L_BRACK);
RETV(END, ':');
} else
RETV(PLAIN, c);
break;
default:
assert(NOTREACHED);
break;
}
/* that got rid of everything except EREs and AREs */
assert(INCON(L_ERE));
/* deal with EREs and AREs, except for backslashes */
switch (c) {
case CHR('|'):
RET('|');
break;
case CHR('*'):
if ((v->cflags®_ADVF) && NEXT1('?')) {
v->now++;
NOTE(REG_UNONPOSIX);
RETV('*', 0);
}
RETV('*', 1);
break;
case CHR('+'):
if ((v->cflags®_ADVF) && NEXT1('?')) {
v->now++;
NOTE(REG_UNONPOSIX);
RETV('+', 0);
}
RETV('+', 1);
break;
case CHR('?'):
if ((v->cflags®_ADVF) && NEXT1('?')) {
v->now++;
NOTE(REG_UNONPOSIX);
RETV('?', 0);
}
RETV('?', 1);
break;
case CHR('{'): /* bounds start or plain character */
if (v->cflags®_EXPANDED)
skip(v);
if (ATEOS() || !iscdigit(*v->now)) {
NOTE(REG_UBRACES);
NOTE(REG_UUNSPEC);
RETV(PLAIN, c);
} else {
NOTE(REG_UBOUNDS);
INTOCON(L_EBND);
RET('{');
}
assert(NOTREACHED);
break;
case CHR('('): /* parenthesis, or advanced extension */
if ((v->cflags®_ADVF) && NEXT1('?')) {
NOTE(REG_UNONPOSIX);
v->now++;
switch (*v->now++) {
case CHR(':'): /* non-capturing paren */
RETV('(', 0);
break;
case CHR('#'): /* comment */
while (!ATEOS() && *v->now != CHR(')'))
v->now++;
if (!ATEOS())
v->now++;
assert(v->nexttype == v->lasttype);
return next(v);
break;
case CHR('='): /* positive lookahead */
NOTE(REG_ULOOKAHEAD);
RETV(LACON, 1);
break;
case CHR('!'): /* negative lookahead */
NOTE(REG_ULOOKAHEAD);
RETV(LACON, 0);
break;
default:
FAILW(REG_BADRPT);
break;
}
assert(NOTREACHED);
}
if (v->cflags®_NOSUB)
RETV('(', 0); /* all parens non-capturing */
else
RETV('(', 1);
break;
case CHR(')'):
if (LASTTYPE('(')) {
NOTE(REG_UUNSPEC);
}
RETV(')', c);
break;
case CHR('['): /* easy except for [[:<:]] and [[:>:]] */
if (HAVE(6) && *(v->now+0) == CHR('[') &&
*(v->now+1) == CHR(':') &&
(*(v->now+2) == CHR('<') ||
*(v->now+2) == CHR('>')) &&
*(v->now+3) == CHR(':') &&
*(v->now+4) == CHR(']') &&
*(v->now+5) == CHR(']')) {
c = *(v->now+2);
v->now += 6;
NOTE(REG_UNONPOSIX);
RET((c == CHR('<')) ? '<' : '>');
}
INTOCON(L_BRACK);
if (NEXT1('^')) {
v->now++;
RETV('[', 0);
}
RETV('[', 1);
break;
case CHR('.'):
RET('.');
break;
case CHR('^'):
RET('^');
break;
case CHR('$'):
RET('$');
break;
case CHR('\\'): /* mostly punt backslashes to code below */
if (ATEOS())
FAILW(REG_EESCAPE);
break;
default: /* ordinary character */
RETV(PLAIN, c);
break;
}
/* ERE/ARE backslash handling; backslash already eaten */
assert(!ATEOS());
if (!(v->cflags®_ADVF)) { /* only AREs have non-trivial escapes */
if (iscalnum(*v->now)) {
NOTE(REG_UBSALNUM);
NOTE(REG_UUNSPEC);
}
RETV(PLAIN, *v->now++);
}
(DISCARD)lexescape(v);
if (ISERR())
FAILW(REG_EESCAPE);
if (v->nexttype == CCLASS) { /* fudge at lexical level */
switch (v->nextvalue) {
case 'd': lexnest(v, backd, ENDOF(backd)); break;
case 'D': lexnest(v, backD, ENDOF(backD)); break;
case 's': lexnest(v, backs, ENDOF(backs)); break;
case 'S': lexnest(v, backS, ENDOF(backS)); break;
case 'w': lexnest(v, backw, ENDOF(backw)); break;
case 'W': lexnest(v, backW, ENDOF(backW)); break;
default:
assert(NOTREACHED);
FAILW(REG_ASSERT);
break;
}
/* lexnest done, back up and try again */
v->nexttype = v->lasttype;
return next(v);
}
/* otherwise, lexescape has already done the work */
return !ISERR();
}
/*
- lexescape - parse an ARE backslash escape (backslash already eaten)
* Note slightly nonstandard use of the CCLASS type code.
^ static int lexescape(struct vars *);
*/
static int /* not actually used, but convenient for RETV */
lexescape(v)
struct vars *v;
{
chr c;
static CONST chr alert[] = {
CHR('a'), CHR('l'), CHR('e'), CHR('r'), CHR('t')
};
static CONST chr esc[] = {
CHR('E'), CHR('S'), CHR('C')
};
CONST chr *save;
assert(v->cflags®_ADVF);
assert(!ATEOS());
c = *v->now++;
if (!iscalnum(c))
RETV(PLAIN, c);
NOTE(REG_UNONPOSIX);
switch (c) {
case CHR('a'):
RETV(PLAIN, chrnamed(v, alert, ENDOF(alert), CHR('\007')));
break;
case CHR('A'):
RETV(SBEGIN, 0);
break;
case CHR('b'):
RETV(PLAIN, CHR('\b'));
break;
case CHR('B'):
RETV(PLAIN, CHR('\\'));
break;
case CHR('c'):
NOTE(REG_UUNPORT);
if (ATEOS())
FAILW(REG_EESCAPE);
RETV(PLAIN, (chr)(*v->now++ & 037));
break;
case CHR('d'):
NOTE(REG_ULOCALE);
RETV(CCLASS, 'd');
break;
case CHR('D'):
NOTE(REG_ULOCALE);
RETV(CCLASS, 'D');
break;
case CHR('e'):
NOTE(REG_UUNPORT);
RETV(PLAIN, chrnamed(v, esc, ENDOF(esc), CHR('\033')));
break;
case CHR('f'):
RETV(PLAIN, CHR('\f'));
break;
case CHR('m'):
RET('<');
break;
case CHR('M'):
RET('>');
break;
case CHR('n'):
RETV(PLAIN, CHR('\n'));
break;
case CHR('r'):
RETV(PLAIN, CHR('\r'));
break;
case CHR('s'):
NOTE(REG_ULOCALE);
RETV(CCLASS, 's');
break;
case CHR('S'):
NOTE(REG_ULOCALE);
RETV(CCLASS, 'S');
break;
case CHR('t'):
RETV(PLAIN, CHR('\t'));
break;
case CHR('u'):
c = lexdigits(v, 16, 4, 4);
if (ISERR())
FAILW(REG_EESCAPE);
RETV(PLAIN, c);
break;
case CHR('U'):
c = lexdigits(v, 16, 8, 8);
if (ISERR())
FAILW(REG_EESCAPE);
RETV(PLAIN, c);
break;
case CHR('v'):
RETV(PLAIN, CHR('\v'));
break;
case CHR('w'):
NOTE(REG_ULOCALE);
RETV(CCLASS, 'w');
break;
case CHR('W'):
NOTE(REG_ULOCALE);
RETV(CCLASS, 'W');
break;
case CHR('x'):
NOTE(REG_UUNPORT);
c = lexdigits(v, 16, 1, 255); /* REs >255 long outside spec */
if (ISERR())
FAILW(REG_EESCAPE);
RETV(PLAIN, c);
break;
case CHR('y'):
NOTE(REG_ULOCALE);
RETV(WBDRY, 0);
break;
case CHR('Y'):
NOTE(REG_ULOCALE);
RETV(NWBDRY, 0);
break;
case CHR('Z'):
RETV(SEND, 0);
break;
case CHR('1'): case CHR('2'): case CHR('3'): case CHR('4'):
case CHR('5'): case CHR('6'): case CHR('7'): case CHR('8'):
case CHR('9'):
save = v->now;
v->now--; /* put first digit back */
c = lexdigits(v, 10, 1, 255); /* REs >255 long outside spec */
if (ISERR())
FAILW(REG_EESCAPE);
/* ugly heuristic (first test is "exactly 1 digit?") */
if (v->now-save == 0 || ((int)c > 0 && (int)c <= v->nsubexp)) {
NOTE(REG_UBACKREF);
RETV(BACKREF, (chr)c);
}
/* oops, doesn't look like it's a backref after all... */
v->now = save;
/* and fall through into octal number */
case CHR('0'):
NOTE(REG_UUNPORT);
v->now--; /* put first digit back */
c = lexdigits(v, 8, 1, 3);
if (ISERR())
FAILW(REG_EESCAPE);
RETV(PLAIN, c);
break;
default:
assert(iscalpha(c));
FAILW(REG_EESCAPE); /* unknown alphabetic escape */
break;
}
assert(NOTREACHED);
}
/*
- lexdigits - slurp up digits and return chr value
^ static chr lexdigits(struct vars *, int, int, int);
*/
static chr /* chr value; errors signalled via ERR */
lexdigits(v, base, minlen, maxlen)
struct vars *v;
int base;
int minlen;
int maxlen;
{
uchr n; /* unsigned to avoid overflow misbehavior */
int len;
chr c;
int d;
CONST uchr ub = (uchr) base;
n = 0;
for (len = 0; len < maxlen && !ATEOS(); len++) {
c = *v->now++;
switch (c) {
case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'):
case CHR('4'): case CHR('5'): case CHR('6'): case CHR('7'):
case CHR('8'): case CHR('9'):
d = DIGITVAL(c);
break;
case CHR('a'): case CHR('A'): d = 10; break;
case CHR('b'): case CHR('B'): d = 11; break;
case CHR('c'): case CHR('C'): d = 12; break;
case CHR('d'): case CHR('D'): d = 13; break;
case CHR('e'): case CHR('E'): d = 14; break;
case CHR('f'): case CHR('F'): d = 15; break;
default:
v->now--; /* oops, not a digit at all */
d = -1;
break;
}
if (d >= base) { /* not a plausible digit */
v->now--;
d = -1;
}
if (d < 0)
break; /* NOTE BREAK OUT */
n = n*ub + (uchr)d;
}
if (len < minlen)
ERR(REG_EESCAPE);
return (chr)n;
}
/*
- brenext - get next BRE token
* This is much like EREs except for all the stupid backslashes and the
* context-dependency of some things.
^ static int brenext(struct vars *, pchr);
*/
static int /* 1 normal, 0 failure */
brenext(v, pc)
struct vars *v;
pchr pc;
{
chr c = (chr)pc;
switch (c) {
case CHR('*'):
if (LASTTYPE(EMPTY) || LASTTYPE('(') || LASTTYPE('^'))
RETV(PLAIN, c);
RET('*');
break;
case CHR('['):
if (HAVE(6) && *(v->now+0) == CHR('[') &&
*(v->now+1) == CHR(':') &&
(*(v->now+2) == CHR('<') ||
*(v->now+2) == CHR('>')) &&
*(v->now+3) == CHR(':') &&
*(v->now+4) == CHR(']') &&
*(v->now+5) == CHR(']')) {
c = *(v->now+2);
v->now += 6;
NOTE(REG_UNONPOSIX);
RET((c == CHR('<')) ? '<' : '>');
}
INTOCON(L_BRACK);
if (NEXT1('^')) {
v->now++;
RETV('[', 0);
}
RETV('[', 1);
break;
case CHR('.'):
RET('.');
break;
case CHR('^'):
if (LASTTYPE(EMPTY))
RET('^');
if (LASTTYPE('(')) {
NOTE(REG_UUNSPEC);
RET('^');
}
RETV(PLAIN, c);
break;
case CHR('$'):
if (v->cflags®_EXPANDED)
skip(v);
if (ATEOS())
RET('$');
if (NEXT2('\\', ')')) {
NOTE(REG_UUNSPEC);
RET('$');
}
RETV(PLAIN, c);
break;
case CHR('\\'):
break; /* see below */
default:
RETV(PLAIN, c);
break;
}
assert(c == CHR('\\'));
if (ATEOS())
FAILW(REG_EESCAPE);
c = *v->now++;
switch (c) {
case CHR('{'):
INTOCON(L_BBND);
NOTE(REG_UBOUNDS);
RET('{');
break;
case CHR('('):
RETV('(', 1);
break;
case CHR(')'):
RETV(')', c);
break;
case CHR('<'):
NOTE(REG_UNONPOSIX);
RET('<');
break;
case CHR('>'):
NOTE(REG_UNONPOSIX);
RET('>');
break;
case CHR('1'): case CHR('2'): case CHR('3'): case CHR('4'):
case CHR('5'): case CHR('6'): case CHR('7'): case CHR('8'):
case CHR('9'):
NOTE(REG_UBACKREF);
RETV(BACKREF, (chr)DIGITVAL(c));
break;
default:
if (iscalnum(c)) {
NOTE(REG_UBSALNUM);
NOTE(REG_UUNSPEC);
}
RETV(PLAIN, c);
break;
}
assert(NOTREACHED);
}
/*
- skip - skip white space and comments in expanded form
^ static VOID skip(struct vars *);
*/
static VOID
skip(v)
struct vars *v;
{
CONST chr *start = v->now;
assert(v->cflags®_EXPANDED);
for (;;) {
while (!ATEOS() && iscspace(*v->now))
v->now++;
if (ATEOS() || *v->now != CHR('#'))
break; /* NOTE BREAK OUT */
assert(NEXT1('#'));
while (!ATEOS() && *v->now != CHR('\n'))
v->now++;
/* leave the newline to be picked up by the iscspace loop */
}
if (v->now != start)
NOTE(REG_UNONPOSIX);
}
/*
- newline - return the chr for a newline
* This helps confine use of CHR to this source file.
^ static chr newline(NOPARMS);
*/
static chr
newline()
{
return CHR('\n');
}
/*
- ch - return the chr sequence for regc_locale.c's fake collating element ch
* This helps confine use of CHR to this source file. Beware that the caller
* knows how long the sequence is.
^ #ifdef REG_DEBUG
^ static chr *ch(NOPARMS);
^ #endif
*/
#ifdef REG_DEBUG
static CONST chr *
ch()
{
static CONST chr chstr[] = { CHR('c'), CHR('h'), CHR('\0') };
return chstr;
}
#endif
/*
- chrnamed - return the chr known by a given (chr string) name
* The code is a bit clumsy, but this routine gets only such specialized
* use that it hardly matters.
^ static chr chrnamed(struct vars *, chr *, chr *, pchr);
*/
static chr
chrnamed(v, startp, endp, lastresort)
struct vars *v;
CONST chr *startp; /* start of name */
CONST chr *endp; /* just past end of name */
pchr lastresort; /* what to return if name lookup fails */
{
celt c;
int errsave;
int e;
struct cvec *cv;
errsave = v->err;
v->err = 0;
c = element(v, startp, endp);
e = v->err;
v->err = errsave;
if (e != 0)
return (chr)lastresort;
cv = range(v, c, c, 0);
if (cv->nchrs == 0)
return (chr)lastresort;
return cv->chrs[0];
}
tcl8.4.20/generic/tclIntPlatDecls.h 0000644 0036047 0045461 00000050525 12052456744 015543 0 ustar dgp 771div /*
* tclIntPlatDecls.h --
*
* This file contains the declarations for all platform dependent
* unsupported functions that are exported by the Tcl library. These
* interfaces are not guaranteed to remain the same between
* versions. Use at your own risk.
*
* Copyright (c) 1998-1999 by Scriptics Corporation.
* All rights reserved.
*/
#ifndef _TCLINTPLATDECLS
#define _TCLINTPLATDECLS
#ifdef __WIN32__
# define Tcl_DirEntry void
# define DIR void
#endif
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
* script. Any modifications to the function declarations below should be made
* in the generic/tclInt.decls script.
*/
/* !BEGIN!: Do not edit below this line. */
/*
* Exported function declarations:
*/
#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 0 */
EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
/* 1 */
EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file));
/* 2 */
EXTERN Tcl_Channel TclpCreateCommandChannel _ANSI_ARGS_((
TclFile readFile, TclFile writeFile,
TclFile errorFile, int numPids,
Tcl_Pid *pidPtr));
/* 3 */
EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile *readPipe,
TclFile *writePipe));
/* 4 */
EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp *interp,
int argc, CONST char **argv,
TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr));
/* Slot 5 is reserved */
/* 6 */
EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel,
int direction));
/* 7 */
EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char *fname,
int mode));
/* 8 */
EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask,
int timeout));
/* 9 */
EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((CONST char *contents));
/* 10 */
EXTERN Tcl_DirEntry * TclpReaddir _ANSI_ARGS_((DIR *dir));
/* 11 */
EXTERN struct tm * TclpLocaltime_unix _ANSI_ARGS_((
TclpTime_t_CONST clock));
/* 12 */
EXTERN struct tm * TclpGmtime_unix _ANSI_ARGS_((TclpTime_t_CONST clock));
/* 13 */
EXTERN char * TclpInetNtoa _ANSI_ARGS_((struct in_addr addr));
/* Slot 14 is reserved */
/* Slot 15 is reserved */
/* Slot 16 is reserved */
/* Slot 17 is reserved */
/* Slot 18 is reserved */
/* Slot 19 is reserved */
/* Slot 20 is reserved */
/* Slot 21 is reserved */
/* Slot 22 is reserved */
/* Slot 23 is reserved */
/* Slot 24 is reserved */
/* Slot 25 is reserved */
/* Slot 26 is reserved */
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
EXTERN int TclWinCPUID _ANSI_ARGS_((unsigned int index,
unsigned int *regs));
#endif /* UNIX */
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode));
/* 1 */
EXTERN void TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode));
/* 2 */
EXTERN struct servent * TclWinGetServByName _ANSI_ARGS_((CONST char *nm,
CONST char *proto));
/* 3 */
EXTERN int TclWinGetSockOpt _ANSI_ARGS_((SOCKET s, int level,
int optname, char *optval, int *optlen));
/* 4 */
EXTERN HINSTANCE TclWinGetTclInstance _ANSI_ARGS_((void));
/* 5 */
EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask,
int timeout));
/* 6 */
EXTERN unsigned short TclWinNToHS _ANSI_ARGS_((unsigned short ns));
/* 7 */
EXTERN int TclWinSetSockOpt _ANSI_ARGS_((SOCKET s, int level,
int optname, CONST char *optval, int optlen));
/* 8 */
EXTERN int TclpGetPid _ANSI_ARGS_((Tcl_Pid pid));
/* 9 */
EXTERN int TclWinGetPlatformId _ANSI_ARGS_((void));
/* 10 */
EXTERN Tcl_DirEntry * TclpReaddir _ANSI_ARGS_((DIR *dir));
/* 11 */
EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
/* 12 */
EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file));
/* 13 */
EXTERN Tcl_Channel TclpCreateCommandChannel _ANSI_ARGS_((
TclFile readFile, TclFile writeFile,
TclFile errorFile, int numPids,
Tcl_Pid *pidPtr));
/* 14 */
EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile *readPipe,
TclFile *writePipe));
/* 15 */
EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp *interp,
int argc, CONST char **argv,
TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr));
/* 16 */
EXTERN int TclpIsAtty _ANSI_ARGS_((int fd));
/* Slot 17 is reserved */
/* 18 */
EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel,
int direction));
/* 19 */
EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char *fname,
int mode));
/* 20 */
EXTERN void TclWinAddProcess _ANSI_ARGS_((HANDLE hProcess,
DWORD id));
/* 21 */
EXTERN char * TclpInetNtoa _ANSI_ARGS_((struct in_addr addr));
/* 22 */
EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((CONST char *contents));
/* 23 */
EXTERN char * TclpGetTZName _ANSI_ARGS_((int isdst));
/* 24 */
EXTERN char * TclWinNoBackslash _ANSI_ARGS_((char *path));
/* 25 */
EXTERN TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void));
/* 26 */
EXTERN void TclWinSetInterfaces _ANSI_ARGS_((int wide));
/* 27 */
EXTERN void TclWinFlushDirtyChannels _ANSI_ARGS_((void));
/* 28 */
EXTERN void TclWinResetInterfaces _ANSI_ARGS_((void));
/* 29 */
EXTERN int TclWinCPUID _ANSI_ARGS_((unsigned int index,
unsigned int *regs));
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
/* 1 */
EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file));
/* 2 */
EXTERN Tcl_Channel TclpCreateCommandChannel _ANSI_ARGS_((
TclFile readFile, TclFile writeFile,
TclFile errorFile, int numPids,
Tcl_Pid *pidPtr));
/* 3 */
EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile *readPipe,
TclFile *writePipe));
/* 4 */
EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp *interp,
int argc, CONST char **argv,
TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr));
/* Slot 5 is reserved */
/* 6 */
EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel,
int direction));
/* 7 */
EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char *fname,
int mode));
/* 8 */
EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask,
int timeout));
/* 9 */
EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((CONST char *contents));
/* 10 */
EXTERN Tcl_DirEntry * TclpReaddir _ANSI_ARGS_((DIR *dir));
/* 11 */
EXTERN struct tm * TclpLocaltime_unix _ANSI_ARGS_((
TclpTime_t_CONST clock));
/* 12 */
EXTERN struct tm * TclpGmtime_unix _ANSI_ARGS_((TclpTime_t_CONST clock));
/* 13 */
EXTERN char * TclpInetNtoa _ANSI_ARGS_((struct in_addr addr));
/* Slot 14 is reserved */
/* Slot 15 is reserved */
/* Slot 16 is reserved */
/* Slot 17 is reserved */
/* Slot 18 is reserved */
/* Slot 19 is reserved */
/* Slot 20 is reserved */
/* Slot 21 is reserved */
/* Slot 22 is reserved */
/* Slot 23 is reserved */
/* Slot 24 is reserved */
/* Slot 25 is reserved */
/* Slot 26 is reserved */
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
EXTERN int TclWinCPUID _ANSI_ARGS_((unsigned int index,
unsigned int *regs));
#endif /* MACOSX */
typedef struct TclIntPlatStubs {
int magic;
struct TclIntPlatStubHooks *hooks;
#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tclGetAndDetachPids) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan)); /* 0 */
int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr)); /* 2 */
int (*tclpCreatePipe) _ANSI_ARGS_((TclFile *readPipe, TclFile *writePipe)); /* 3 */
int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp *interp, int argc, CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr)); /* 4 */
VOID *reserved5;
TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */
TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char *fname, int mode)); /* 7 */
int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */
TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char *contents)); /* 9 */
Tcl_DirEntry * (*tclpReaddir) _ANSI_ARGS_((DIR *dir)); /* 10 */
struct tm * (*tclpLocaltime_unix) _ANSI_ARGS_((TclpTime_t_CONST clock)); /* 11 */
struct tm * (*tclpGmtime_unix) _ANSI_ARGS_((TclpTime_t_CONST clock)); /* 12 */
char * (*tclpInetNtoa) _ANSI_ARGS_((struct in_addr addr)); /* 13 */
VOID *reserved14;
VOID *reserved15;
VOID *reserved16;
VOID *reserved17;
VOID *reserved18;
VOID *reserved19;
VOID *reserved20;
VOID *reserved21;
VOID *reserved22;
VOID *reserved23;
VOID *reserved24;
VOID *reserved25;
VOID *reserved26;
VOID *reserved27;
VOID *reserved28;
int (*tclWinCPUID) _ANSI_ARGS_((unsigned int index, unsigned int *regs)); /* 29 */
#endif /* UNIX */
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
void (*tclWinConvertError) _ANSI_ARGS_((DWORD errCode)); /* 0 */
void (*tclWinConvertWSAError) _ANSI_ARGS_((DWORD errCode)); /* 1 */
struct servent * (*tclWinGetServByName) _ANSI_ARGS_((CONST char *nm, CONST char *proto)); /* 2 */
int (*tclWinGetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, char *optval, int *optlen)); /* 3 */
HINSTANCE (*tclWinGetTclInstance) _ANSI_ARGS_((void)); /* 4 */
int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 5 */
unsigned short (*tclWinNToHS) _ANSI_ARGS_((unsigned short ns)); /* 6 */
int (*tclWinSetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, CONST char *optval, int optlen)); /* 7 */
int (*tclpGetPid) _ANSI_ARGS_((Tcl_Pid pid)); /* 8 */
int (*tclWinGetPlatformId) _ANSI_ARGS_((void)); /* 9 */
Tcl_DirEntry * (*tclpReaddir) _ANSI_ARGS_((DIR *dir)); /* 10 */
void (*tclGetAndDetachPids) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan)); /* 11 */
int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 12 */
Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr)); /* 13 */
int (*tclpCreatePipe) _ANSI_ARGS_((TclFile *readPipe, TclFile *writePipe)); /* 14 */
int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp *interp, int argc, CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr)); /* 15 */
int (*tclpIsAtty) _ANSI_ARGS_((int fd)); /* 16 */
VOID *reserved17;
TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 18 */
TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char *fname, int mode)); /* 19 */
void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */
char * (*tclpInetNtoa) _ANSI_ARGS_((struct in_addr addr)); /* 21 */
TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char *contents)); /* 22 */
char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */
char * (*tclWinNoBackslash) _ANSI_ARGS_((char *path)); /* 24 */
TclPlatformType * (*tclWinGetPlatform) _ANSI_ARGS_((void)); /* 25 */
void (*tclWinSetInterfaces) _ANSI_ARGS_((int wide)); /* 26 */
void (*tclWinFlushDirtyChannels) _ANSI_ARGS_((void)); /* 27 */
void (*tclWinResetInterfaces) _ANSI_ARGS_((void)); /* 28 */
int (*tclWinCPUID) _ANSI_ARGS_((unsigned int index, unsigned int *regs)); /* 29 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tclGetAndDetachPids) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan)); /* 0 */
int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr)); /* 2 */
int (*tclpCreatePipe) _ANSI_ARGS_((TclFile *readPipe, TclFile *writePipe)); /* 3 */
int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp *interp, int argc, CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr)); /* 4 */
VOID *reserved5;
TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */
TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char *fname, int mode)); /* 7 */
int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */
TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char *contents)); /* 9 */
Tcl_DirEntry * (*tclpReaddir) _ANSI_ARGS_((DIR *dir)); /* 10 */
struct tm * (*tclpLocaltime_unix) _ANSI_ARGS_((TclpTime_t_CONST clock)); /* 11 */
struct tm * (*tclpGmtime_unix) _ANSI_ARGS_((TclpTime_t_CONST clock)); /* 12 */
char * (*tclpInetNtoa) _ANSI_ARGS_((struct in_addr addr)); /* 13 */
VOID *reserved14;
VOID *reserved15;
VOID *reserved16;
VOID *reserved17;
VOID *reserved18;
VOID *reserved19;
VOID *reserved20;
VOID *reserved21;
VOID *reserved22;
VOID *reserved23;
VOID *reserved24;
VOID *reserved25;
VOID *reserved26;
VOID *reserved27;
VOID *reserved28;
int (*tclWinCPUID) _ANSI_ARGS_((unsigned int index, unsigned int *regs)); /* 29 */
#endif /* MACOSX */
} TclIntPlatStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern TclIntPlatStubs *tclIntPlatStubsPtr;
#ifdef __cplusplus
}
#endif
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
/*
* Inline function declarations:
*/
#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
#ifndef TclGetAndDetachPids
#define TclGetAndDetachPids \
(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
#endif
#ifndef TclpCloseFile
#define TclpCloseFile \
(tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
#endif
#ifndef TclpCreateCommandChannel
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#endif
#ifndef TclpCreatePipe
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
#endif
#ifndef TclpCreateProcess
#define TclpCreateProcess \
(tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
#endif
/* Slot 5 is reserved */
#ifndef TclpMakeFile
#define TclpMakeFile \
(tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
#endif
#ifndef TclpOpenFile
#define TclpOpenFile \
(tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
#endif
#ifndef TclUnixWaitForFile
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
#endif
#ifndef TclpCreateTempFile
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
#endif
#ifndef TclpReaddir
#define TclpReaddir \
(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
#endif
#ifndef TclpLocaltime_unix
#define TclpLocaltime_unix \
(tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */
#endif
#ifndef TclpGmtime_unix
#define TclpGmtime_unix \
(tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */
#endif
#ifndef TclpInetNtoa
#define TclpInetNtoa \
(tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
#endif
/* Slot 14 is reserved */
/* Slot 15 is reserved */
/* Slot 16 is reserved */
/* Slot 17 is reserved */
/* Slot 18 is reserved */
/* Slot 19 is reserved */
/* Slot 20 is reserved */
/* Slot 21 is reserved */
/* Slot 22 is reserved */
/* Slot 23 is reserved */
/* Slot 24 is reserved */
/* Slot 25 is reserved */
/* Slot 26 is reserved */
/* Slot 27 is reserved */
/* Slot 28 is reserved */
#ifndef TclWinCPUID
#define TclWinCPUID \
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
#endif
#endif /* UNIX */
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
#ifndef TclWinConvertError
#define TclWinConvertError \
(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#endif
#ifndef TclWinConvertWSAError
#define TclWinConvertWSAError \
(tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
#endif
#ifndef TclWinGetServByName
#define TclWinGetServByName \
(tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */
#endif
#ifndef TclWinGetSockOpt
#define TclWinGetSockOpt \
(tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */
#endif
#ifndef TclWinGetTclInstance
#define TclWinGetTclInstance \
(tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
#endif
#ifndef TclUnixWaitForFile
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */
#endif
#ifndef TclWinNToHS
#define TclWinNToHS \
(tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
#endif
#ifndef TclWinSetSockOpt
#define TclWinSetSockOpt \
(tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */
#endif
#ifndef TclpGetPid
#define TclpGetPid \
(tclIntPlatStubsPtr->tclpGetPid) /* 8 */
#endif
#ifndef TclWinGetPlatformId
#define TclWinGetPlatformId \
(tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */
#endif
#ifndef TclpReaddir
#define TclpReaddir \
(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
#endif
#ifndef TclGetAndDetachPids
#define TclGetAndDetachPids \
(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */
#endif
#ifndef TclpCloseFile
#define TclpCloseFile \
(tclIntPlatStubsPtr->tclpCloseFile) /* 12 */
#endif
#ifndef TclpCreateCommandChannel
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */
#endif
#ifndef TclpCreatePipe
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */
#endif
#ifndef TclpCreateProcess
#define TclpCreateProcess \
(tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */
#endif
#ifndef TclpIsAtty
#define TclpIsAtty \
(tclIntPlatStubsPtr->tclpIsAtty) /* 16 */
#endif
/* Slot 17 is reserved */
#ifndef TclpMakeFile
#define TclpMakeFile \
(tclIntPlatStubsPtr->tclpMakeFile) /* 18 */
#endif
#ifndef TclpOpenFile
#define TclpOpenFile \
(tclIntPlatStubsPtr->tclpOpenFile) /* 19 */
#endif
#ifndef TclWinAddProcess
#define TclWinAddProcess \
(tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
#endif
#ifndef TclpInetNtoa
#define TclpInetNtoa \
(tclIntPlatStubsPtr->tclpInetNtoa) /* 21 */
#endif
#ifndef TclpCreateTempFile
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
#endif
#ifndef TclpGetTZName
#define TclpGetTZName \
(tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
#endif
#ifndef TclWinNoBackslash
#define TclWinNoBackslash \
(tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
#endif
#ifndef TclWinGetPlatform
#define TclWinGetPlatform \
(tclIntPlatStubsPtr->tclWinGetPlatform) /* 25 */
#endif
#ifndef TclWinSetInterfaces
#define TclWinSetInterfaces \
(tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */
#endif
#ifndef TclWinFlushDirtyChannels
#define TclWinFlushDirtyChannels \
(tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */
#endif
#ifndef TclWinResetInterfaces
#define TclWinResetInterfaces \
(tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */
#endif
#ifndef TclWinCPUID
#define TclWinCPUID \
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
#endif
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
#ifndef TclGetAndDetachPids
#define TclGetAndDetachPids \
(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
#endif
#ifndef TclpCloseFile
#define TclpCloseFile \
(tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
#endif
#ifndef TclpCreateCommandChannel
#define TclpCreateCommandChannel \
(tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#endif
#ifndef TclpCreatePipe
#define TclpCreatePipe \
(tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
#endif
#ifndef TclpCreateProcess
#define TclpCreateProcess \
(tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
#endif
/* Slot 5 is reserved */
#ifndef TclpMakeFile
#define TclpMakeFile \
(tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
#endif
#ifndef TclpOpenFile
#define TclpOpenFile \
(tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
#endif
#ifndef TclUnixWaitForFile
#define TclUnixWaitForFile \
(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
#endif
#ifndef TclpCreateTempFile
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
#endif
#ifndef TclpReaddir
#define TclpReaddir \
(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
#endif
#ifndef TclpLocaltime_unix
#define TclpLocaltime_unix \
(tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */
#endif
#ifndef TclpGmtime_unix
#define TclpGmtime_unix \
(tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */
#endif
#ifndef TclpInetNtoa
#define TclpInetNtoa \
(tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
#endif
/* Slot 14 is reserved */
/* Slot 15 is reserved */
/* Slot 16 is reserved */
/* Slot 17 is reserved */
/* Slot 18 is reserved */
/* Slot 19 is reserved */
/* Slot 20 is reserved */
/* Slot 21 is reserved */
/* Slot 22 is reserved */
/* Slot 23 is reserved */
/* Slot 24 is reserved */
/* Slot 25 is reserved */
/* Slot 26 is reserved */
/* Slot 27 is reserved */
/* Slot 28 is reserved */
#ifndef TclWinCPUID
#define TclWinCPUID \
(tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
#endif
#endif /* MACOSX */
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
/* !END!: Do not edit above this line. */
#undef TclpLocaltime_unix
#undef TclpGmtime_unix
#if !defined(__WIN32__) && !defined(__CYGWIN__)
# undef TclpGetPid
# define TclpGetPid(pid) ((unsigned long) (pid))
#endif
#endif /* _TCLINTPLATDECLS */
tcl8.4.20/generic/tclCompile.h 0000644 0036047 0045461 00000141415 12133546537 014604 0 ustar dgp 771div /*
* tclCompile.h --
*
* Copyright (c) 1996-1998 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2007 Daniel A. Steffen
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _TCLCOMPILATION
#define _TCLCOMPILATION 1
#ifndef _TCLINT
#include "tclInt.h"
#endif /* _TCLINT */
#ifdef BUILD_tcl
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLEXPORT
#endif
/*
*------------------------------------------------------------------------
* Variables related to compilation. These are used in tclCompile.c,
* tclExecute.c, tclBasic.c, and their clients.
*------------------------------------------------------------------------
*/
#ifdef TCL_COMPILE_DEBUG
/*
* Variable that controls whether compilation tracing is enabled and, if so,
* what level of tracing is desired:
* 0: no compilation tracing
* 1: summarize compilation of top level cmds and proc bodies
* 2: display all instructions of each ByteCode compiled
* This variable is linked to the Tcl variable "tcl_traceCompile".
*/
extern int tclTraceCompile;
#endif
#ifdef TCL_COMPILE_DEBUG
/*
* Variable that controls whether execution tracing is enabled and, if so,
* what level of tracing is desired:
* 0: no execution tracing
* 1: trace invocations of Tcl procs only
* 2: trace invocations of all (not compiled away) commands
* 3: display each instruction executed
* This variable is linked to the Tcl variable "tcl_traceExec".
*/
extern int tclTraceExec;
#endif
/*
*------------------------------------------------------------------------
* Data structures related to compilation.
*------------------------------------------------------------------------
*/
/*
* The structure used to implement Tcl "exceptions" (exceptional returns):
* for example, those generated in loops by the break and continue commands,
* and those generated by scripts and caught by the catch command. This
* ExceptionRange structure describes a range of code (e.g., a loop body),
* the kind of exceptions (e.g., a break or continue) that might occur, and
* the PC offsets to jump to if a matching exception does occur. Exception
* ranges can nest so this structure includes a nesting level that is used
* at runtime to find the closest exception range surrounding a PC. For
* example, when a break command is executed, the ExceptionRange structure
* for the most deeply nested loop, if any, is found and used. These
* structures are also generated for the "next" subcommands of for loops
* since a break there terminates the for command. This means a for command
* actually generates two LoopInfo structures.
*/
typedef enum {
LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop.
* Break and continue "exceptions" cause
* jumps to appropriate PC offsets. */
CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a
* catch command. Errors in the range cause
* a jump to a catch PC offset. */
} ExceptionRangeType;
typedef struct ExceptionRange {
ExceptionRangeType type; /* The kind of ExceptionRange. */
int nestingLevel; /* Static depth of the exception range.
* Used to find the most deeply-nested
* range surrounding a PC at runtime. */
int codeOffset; /* Offset of the first instruction byte of
* the code range. */
int numCodeBytes; /* Number of bytes in the code range. */
int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC
* offset for a break command in the range. */
int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the
* target PC offset for a continue command in
* the code range. Otherwise, ignore this range
* when processing a continue command. */
int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC
* offset for any "exception" in range. */
} ExceptionRange;
/*
* Structure used to map between instruction pc and source locations. It
* defines for each compiled Tcl command its code's starting offset and
* its source's starting offset and length. Note that the code offset
* increases monotonically: that is, the table is sorted in code offset
* order. The source offset is not monotonic.
*/
typedef struct CmdLocation {
int codeOffset; /* Offset of first byte of command code. */
int numCodeBytes; /* Number of bytes for command's code. */
int srcOffset; /* Offset of first char of the command. */
int numSrcBytes; /* Number of command source chars. */
} CmdLocation;
#ifdef TCL_TIP280
/*
* TIP #280
* Structure to record additional location information for byte code.
* This information is internal and not saved. I.e. tbcload'ed code
* will not have this information. It records the lines for all words
* of all commands found in the byte code. The association with a
* ByteCode structure BC is done through the 'lineBCPtr' HashTable in
* Interp, keyed by the address of BC. Also recorded is information
* coming from the context, i.e. type of the frame and associated
* information, like the path of a sourced file.
*/
typedef struct ECL {
int srcOffset; /* cmd location to find the entry */
int nline; /* Number of words in the command */
int* line; /* line information for all words in the command */
int** next; /* Transient information during compile, ICL tracking */
} ECL;
typedef struct ExtCmdLoc {
int type; /* Context type */
Tcl_Obj* path; /* Path of the sourced file the command is in */
ECL* loc; /* Command word locations (lines) */
int nloc; /* Number of allocated entries in 'loc' */
int nuloc; /* Number of used entries in 'loc' */
Tcl_HashTable litInfo; /* Indexed by bytecode 'PC', to have the
* information accessible per command and
* argument, not per whole bytecode. Value is
* index of command in 'loc', giving us the
* literals to associate with line
* information as command argument, see
* TclArgumentBCEnter() */
} ExtCmdLoc;
#endif
/*
* CompileProcs need the ability to record information during compilation
* that can be used by bytecode instructions during execution. The AuxData
* structure provides this "auxiliary data" mechanism. An arbitrary number
* of these structures can be stored in the ByteCode record (during
* compilation they are stored in a CompileEnv structure). Each AuxData
* record holds one word of client-specified data (often a pointer) and is
* given an index that instructions can later use to look up the structure
* and its data.
*
* The following definitions declare the types of procedures that are called
* to duplicate or free this auxiliary data when the containing ByteCode
* objects are duplicated and freed. Pointers to these procedures are kept
* in the AuxData structure.
*/
typedef ClientData (AuxDataDupProc) _ANSI_ARGS_((ClientData clientData));
typedef void (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData));
/*
* We define a separate AuxDataType struct to hold type-related information
* for the AuxData structure. This separation makes it possible for clients
* outside of the TCL core to manipulate (in a limited fashion!) AuxData;
* for example, it makes it possible to pickle and unpickle AuxData structs.
*/
typedef struct AuxDataType {
char *name; /* the name of the type. Types can be
* registered and found by name */
AuxDataDupProc *dupProc; /* Callback procedure to invoke when the
* aux data is duplicated (e.g., when the
* ByteCode structure containing the aux
* data is duplicated). NULL means just
* copy the source clientData bits; no
* proc need be called. */
AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the
* aux data is freed. NULL means no
* proc need be called. */
} AuxDataType;
/*
* The definition of the AuxData structure that holds information created
* during compilation by CompileProcs and used by instructions during
* execution.
*/
typedef struct AuxData {
AuxDataType *type; /* pointer to the AuxData type associated with
* this ClientData. */
ClientData clientData; /* The compilation data itself. */
} AuxData;
/*
* Structure defining the compilation environment. After compilation, fields
* describing bytecode instructions are copied out into the more compact
* ByteCode structure defined below.
*/
#define COMPILEENV_INIT_CODE_BYTES 250
#define COMPILEENV_INIT_NUM_OBJECTS 60
#define COMPILEENV_INIT_EXCEPT_RANGES 5
#define COMPILEENV_INIT_CMD_MAP_SIZE 40
#define COMPILEENV_INIT_AUX_DATA_SIZE 5
typedef struct CompileEnv {
Interp *iPtr; /* Interpreter containing the code being
* compiled. Commands and their compile
* procs are specific to an interpreter so
* the code emitted will depend on the
* interpreter. */
char *source; /* The source string being compiled by
* SetByteCodeFromAny. This pointer is not
* owned by the CompileEnv and must not be
* freed or changed by it. */
int numSrcBytes; /* Number of bytes in source. */
Proc *procPtr; /* If a procedure is being compiled, a
* pointer to its Proc structure; otherwise
* NULL. Used to compile local variables.
* Set from information provided by
* ObjInterpProc in tclProc.c. */
int numCommands; /* Number of commands compiled. */
int exceptDepth; /* Current exception range nesting level;
* -1 if not in any range currently. */
int maxExceptDepth; /* Max nesting level of exception ranges;
* -1 if no ranges have been compiled. */
int maxStackDepth; /* Maximum number of stack elements needed
* to execute the code. Set by compilation
* procedures before returning. */
int currStackDepth; /* Current stack depth. */
LiteralTable localLitTable; /* Contains LiteralEntry's describing
* all Tcl objects referenced by this
* compiled code. Indexed by the string
* representations of the literals. Used to
* avoid creating duplicate objects. */
unsigned char *codeStart; /* Points to the first byte of the code. */
unsigned char *codeNext; /* Points to next code array byte to use. */
unsigned char *codeEnd; /* Points just after the last allocated
* code array byte. */
int mallocedCodeArray; /* Set 1 if code array was expanded
* and codeStart points into the heap.*/
LiteralEntry *literalArrayPtr;
/* Points to start of LiteralEntry array. */
int literalArrayNext; /* Index of next free object array entry. */
int literalArrayEnd; /* Index just after last obj array entry. */
int mallocedLiteralArray; /* 1 if object array was expanded and
* objArray points into the heap, else 0. */
ExceptionRange *exceptArrayPtr;
/* Points to start of the ExceptionRange
* array. */
int exceptArrayNext; /* Next free ExceptionRange array index.
* exceptArrayNext is the number of ranges
* and (exceptArrayNext-1) is the index of
* the current range's array entry. */
int exceptArrayEnd; /* Index after the last ExceptionRange
* array entry. */
int mallocedExceptArray; /* 1 if ExceptionRange array was expanded
* and exceptArrayPtr points in heap,
* else 0. */
CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array.
* numCommands is the index of the next
* entry to use; (numCommands-1) is the
* entry index for the last command. */
int cmdMapEnd; /* Index after last CmdLocation entry. */
int mallocedCmdMap; /* 1 if command map array was expanded and
* cmdMapPtr points in the heap, else 0. */
AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */
int auxDataArrayNext; /* Next free compile aux data array index.
* auxDataArrayNext is the number of aux
* data items and (auxDataArrayNext-1) is
* index of current aux data array entry. */
int auxDataArrayEnd; /* Index after last aux data array entry. */
int mallocedAuxDataArray; /* 1 if aux data array was expanded and
* auxDataArrayPtr points in heap else 0. */
unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES];
/* Initial storage for code. */
LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS];
/* Initial storage of LiteralEntry array. */
ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
/* Initial ExceptionRange array storage. */
CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
/* Initial storage for cmd location map. */
AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
/* Initial storage for aux data array. */
#ifdef TCL_TIP280
/* TIP #280 */
ExtCmdLoc* extCmdMapPtr; /* Extended command location information
* for 'info frame'. */
int line; /* First line of the script, based on the
* invoking context, then the line of the
* command currently compiled. */
ContLineLoc* clLoc; /* If not NULL, the table holding the
* locations of the invisible continuation
* lines in the input script, to adjust the
* line counter. */
int* clNext; /* If not NULL, it refers to the next slot in
* clLoc to check for an invisible
* continuation line. */
#endif
} CompileEnv;
/*
* The structure defining the bytecode instructions resulting from compiling
* a Tcl script. Note that this structure is variable length: a single heap
* object is allocated to hold the ByteCode structure immediately followed
* by the code bytes, the literal object array, the ExceptionRange array,
* the CmdLocation map, and the compilation AuxData array.
*/
/*
* A PRECOMPILED bytecode struct is one that was generated from a compiled
* image rather than implicitly compiled from source
*/
#define TCL_BYTECODE_PRECOMPILED 0x0001
typedef struct ByteCode {
TclHandle interpHandle; /* Handle for interpreter containing the
* compiled code. Commands and their compile
* procs are specific to an interpreter so the
* code emitted will depend on the
* interpreter. */
int compileEpoch; /* Value of iPtr->compileEpoch when this
* ByteCode was compiled. Used to invalidate
* code when, e.g., commands with compile
* procs are redefined. */
Namespace *nsPtr; /* Namespace context in which this code
* was compiled. If the code is executed
* if a different namespace, it must be
* recompiled. */
int nsEpoch; /* Value of nsPtr->resolverEpoch when this
* ByteCode was compiled. Used to invalidate
* code when new namespace resolution rules
* are put into effect. */
int refCount; /* Reference count: set 1 when created
* plus 1 for each execution of the code
* currently active. This structure can be
* freed when refCount becomes zero. */
unsigned int flags; /* flags describing state for the codebyte.
* this variable holds ORed values from the
* TCL_BYTECODE_ masks defined above */
char *source; /* The source string from which this
* ByteCode was compiled. Note that this
* pointer is not owned by the ByteCode and
* must not be freed or modified by it. */
Proc *procPtr; /* If the ByteCode was compiled from a
* procedure body, this is a pointer to its
* Proc structure; otherwise NULL. This
* pointer is also not owned by the ByteCode
* and must not be freed by it. */
size_t structureSize; /* Number of bytes in the ByteCode structure
* itself. Does not include heap space for
* literal Tcl objects or storage referenced
* by AuxData entries. */
int numCommands; /* Number of commands compiled. */
int numSrcBytes; /* Number of source bytes compiled. */
int numCodeBytes; /* Number of code bytes. */
int numLitObjects; /* Number of objects in literal array. */
int numExceptRanges; /* Number of ExceptionRange array elems. */
int numAuxDataItems; /* Number of AuxData items. */
int numCmdLocBytes; /* Number of bytes needed for encoded
* command location information. */
int maxExceptDepth; /* Maximum nesting level of ExceptionRanges;
* -1 if no ranges were compiled. */
int maxStackDepth; /* Maximum number of stack elements needed
* to execute the code. */
unsigned char *codeStart; /* Points to the first byte of the code.
* This is just after the final ByteCode
* member cmdMapPtr. */
Tcl_Obj **objArrayPtr; /* Points to the start of the literal
* object array. This is just after the
* last code byte. */
ExceptionRange *exceptArrayPtr;
/* Points to the start of the ExceptionRange
* array. This is just after the last
* object in the object array. */
AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data
* array. This is just after the last entry
* in the ExceptionRange array. */
unsigned char *codeDeltaStart;
/* Points to the first of a sequence of
* bytes that encode the change in the
* starting offset of each command's code.
* If -127<=delta<=127, it is encoded as 1
* byte, otherwise 0xFF (128) appears and
* the delta is encoded by the next 4 bytes.
* Code deltas are always positive. This
* sequence is just after the last entry in
* the AuxData array. */
unsigned char *codeLengthStart;
/* Points to the first of a sequence of
* bytes that encode the length of each
* command's code. The encoding is the same
* as for code deltas. Code lengths are
* always positive. This sequence is just
* after the last entry in the code delta
* sequence. */
unsigned char *srcDeltaStart;
/* Points to the first of a sequence of
* bytes that encode the change in the
* starting offset of each command's source.
* The encoding is the same as for code
* deltas. Source deltas can be negative.
* This sequence is just after the last byte
* in the code length sequence. */
unsigned char *srcLengthStart;
/* Points to the first of a sequence of
* bytes that encode the length of each
* command's source. The encoding is the
* same as for code deltas. Source lengths
* are always positive. This sequence is
* just after the last byte in the source
* delta sequence. */
#ifdef TCL_COMPILE_STATS
Tcl_Time createTime; /* Absolute time when the ByteCode was
* created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;
/*
* Opcodes for the Tcl bytecode instructions. These must correspond to
* the entries in the table of instruction descriptions,
* tclInstructionTable, in tclCompile.c. Also, the order and number of
* the expression opcodes (e.g., INST_LOR) must match the entries in
* the array operatorStrings in tclExecute.c.
*/
/* Opcodes 0 to 9 */
#define INST_DONE 0
#define INST_PUSH1 1
#define INST_PUSH4 2
#define INST_POP 3
#define INST_DUP 4
#define INST_CONCAT1 5
#define INST_INVOKE_STK1 6
#define INST_INVOKE_STK4 7
#define INST_EVAL_STK 8
#define INST_EXPR_STK 9
/* Opcodes 10 to 23 */
#define INST_LOAD_SCALAR1 10
#define INST_LOAD_SCALAR4 11
#define INST_LOAD_SCALAR_STK 12
#define INST_LOAD_ARRAY1 13
#define INST_LOAD_ARRAY4 14
#define INST_LOAD_ARRAY_STK 15
#define INST_LOAD_STK 16
#define INST_STORE_SCALAR1 17
#define INST_STORE_SCALAR4 18
#define INST_STORE_SCALAR_STK 19
#define INST_STORE_ARRAY1 20
#define INST_STORE_ARRAY4 21
#define INST_STORE_ARRAY_STK 22
#define INST_STORE_STK 23
/* Opcodes 24 to 33 */
#define INST_INCR_SCALAR1 24
#define INST_INCR_SCALAR_STK 25
#define INST_INCR_ARRAY1 26
#define INST_INCR_ARRAY_STK 27
#define INST_INCR_STK 28
#define INST_INCR_SCALAR1_IMM 29
#define INST_INCR_SCALAR_STK_IMM 30
#define INST_INCR_ARRAY1_IMM 31
#define INST_INCR_ARRAY_STK_IMM 32
#define INST_INCR_STK_IMM 33
/* Opcodes 34 to 39 */
#define INST_JUMP1 34
#define INST_JUMP4 35
#define INST_JUMP_TRUE1 36
#define INST_JUMP_TRUE4 37
#define INST_JUMP_FALSE1 38
#define INST_JUMP_FALSE4 39
/* Opcodes 40 to 64 */
#define INST_LOR 40
#define INST_LAND 41
#define INST_BITOR 42
#define INST_BITXOR 43
#define INST_BITAND 44
#define INST_EQ 45
#define INST_NEQ 46
#define INST_LT 47
#define INST_GT 48
#define INST_LE 49
#define INST_GE 50
#define INST_LSHIFT 51
#define INST_RSHIFT 52
#define INST_ADD 53
#define INST_SUB 54
#define INST_MULT 55
#define INST_DIV 56
#define INST_MOD 57
#define INST_UPLUS 58
#define INST_UMINUS 59
#define INST_BITNOT 60
#define INST_LNOT 61
#define INST_CALL_BUILTIN_FUNC1 62
#define INST_CALL_FUNC1 63
#define INST_TRY_CVT_TO_NUMERIC 64
/* Opcodes 65 to 66 */
#define INST_BREAK 65
#define INST_CONTINUE 66
/* Opcodes 67 to 68 */
#define INST_FOREACH_START4 67
#define INST_FOREACH_STEP4 68
/* Opcodes 69 to 72 */
#define INST_BEGIN_CATCH4 69
#define INST_END_CATCH 70
#define INST_PUSH_RESULT 71
#define INST_PUSH_RETURN_CODE 72
/* Opcodes 73 to 78 */
#define INST_STR_EQ 73
#define INST_STR_NEQ 74
#define INST_STR_CMP 75
#define INST_STR_LEN 76
#define INST_STR_INDEX 77
#define INST_STR_MATCH 78
/* Opcodes 78 to 81 */
#define INST_LIST 79
#define INST_LIST_INDEX 80
#define INST_LIST_LENGTH 81
/* Opcodes 82 to 87 */
#define INST_APPEND_SCALAR1 82
#define INST_APPEND_SCALAR4 83
#define INST_APPEND_ARRAY1 84
#define INST_APPEND_ARRAY4 85
#define INST_APPEND_ARRAY_STK 86
#define INST_APPEND_STK 87
/* Opcodes 88 to 93 */
#define INST_LAPPEND_SCALAR1 88
#define INST_LAPPEND_SCALAR4 89
#define INST_LAPPEND_ARRAY1 90
#define INST_LAPPEND_ARRAY4 91
#define INST_LAPPEND_ARRAY_STK 92
#define INST_LAPPEND_STK 93
/* TIP #22 - LINDEX operator with flat arg list */
#define INST_LIST_INDEX_MULTI 94
/*
* TIP #33 - 'lset' command. Code gen also required a Forth-like
* OVER operation.
*/
#define INST_OVER 95
#define INST_LSET_LIST 96
#define INST_LSET_FLAT 97
/* The last opcode */
#define LAST_INST_OPCODE 97
/*
* Table describing the Tcl bytecode instructions: their name (for
* displaying code), total number of code bytes required (including
* operand bytes), and a description of the type of each operand.
* These operand types include signed and unsigned integers of length
* one and four bytes. The unsigned integers are used for indexes or
* for, e.g., the count of objects to push in a "push" instruction.
*/
#define MAX_INSTRUCTION_OPERANDS 2
typedef enum InstOperandType {
OPERAND_NONE,
OPERAND_INT1, /* One byte signed integer. */
OPERAND_INT4, /* Four byte signed integer. */
OPERAND_UINT1, /* One byte unsigned integer. */
OPERAND_UINT4 /* Four byte unsigned integer. */
} InstOperandType;
typedef struct InstructionDesc {
char *name; /* Name of instruction. */
int numBytes; /* Total number of bytes for instruction. */
int stackEffect; /* The worst-case balance stack effect of the
* instruction, used for stack requirements
* computations. The value INT_MIN signals
* that the instruction's worst case effect
* is (1-opnd1).
*/
int numOperands; /* Number of operands. */
InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS];
/* The type of each operand. */
} InstructionDesc;
extern InstructionDesc tclInstructionTable[];
/*
* Definitions of the values of the INST_CALL_BUILTIN_FUNC instruction's
* operand byte. Each value denotes a builtin Tcl math function. These
* values must correspond to the entries in the tclBuiltinFuncTable array
* below and to the values stored in the tclInt.h MathFunc structure's
* builtinFuncIndex field.
*/
#define BUILTIN_FUNC_ACOS 0
#define BUILTIN_FUNC_ASIN 1
#define BUILTIN_FUNC_ATAN 2
#define BUILTIN_FUNC_ATAN2 3
#define BUILTIN_FUNC_CEIL 4
#define BUILTIN_FUNC_COS 5
#define BUILTIN_FUNC_COSH 6
#define BUILTIN_FUNC_EXP 7
#define BUILTIN_FUNC_FLOOR 8
#define BUILTIN_FUNC_FMOD 9
#define BUILTIN_FUNC_HYPOT 10
#define BUILTIN_FUNC_LOG 11
#define BUILTIN_FUNC_LOG10 12
#define BUILTIN_FUNC_POW 13
#define BUILTIN_FUNC_SIN 14
#define BUILTIN_FUNC_SINH 15
#define BUILTIN_FUNC_SQRT 16
#define BUILTIN_FUNC_TAN 17
#define BUILTIN_FUNC_TANH 18
#define BUILTIN_FUNC_ABS 19
#define BUILTIN_FUNC_DOUBLE 20
#define BUILTIN_FUNC_INT 21
#define BUILTIN_FUNC_RAND 22
#define BUILTIN_FUNC_ROUND 23
#define BUILTIN_FUNC_SRAND 24
#define BUILTIN_FUNC_WIDE 25
#define LAST_BUILTIN_FUNC 25
/*
* Table describing the built-in math functions. Entries in this table are
* indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
* operand byte.
*/
typedef int (CallBuiltinFuncProc) _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
typedef struct {
char *name; /* Name of function. */
int numArgs; /* Number of arguments for function. */
Tcl_ValueType argTypes[MAX_MATH_ARGS];
/* Acceptable types for each argument. */
CallBuiltinFuncProc *proc; /* Procedure implementing this function. */
ClientData clientData; /* Additional argument to pass to the
* function when invoking it. */
} BuiltinFunc;
extern BuiltinFunc tclBuiltinFuncTable[];
/*
* Compilation of some Tcl constructs such as if commands and the logical or
* (||) and logical and (&&) operators in expressions requires the
* generation of forward jumps. Since the PC target of these jumps isn't
* known when the jumps are emitted, we record the offset of each jump in an
* array of JumpFixup structures. There is one array for each sequence of
* jumps to one target PC. When we learn the target PC, we update the jumps
* with the correct distance. Also, if the distance is too great (> 127
* bytes), we replace the single-byte jump with a four byte jump
* instruction, move the instructions after the jump down, and update the
* code offsets for any commands between the jump and the target.
*/
typedef enum {
TCL_UNCONDITIONAL_JUMP,
TCL_TRUE_JUMP,
TCL_FALSE_JUMP
} TclJumpType;
typedef struct JumpFixup {
TclJumpType jumpType; /* Indicates the kind of jump. */
int codeOffset; /* Offset of the first byte of the one-byte
* forward jump's code. */
int cmdIndex; /* Index of the first command after the one
* for which the jump was emitted. Used to
* update the code offsets for subsequent
* commands if the two-byte jump at jumpPc
* must be replaced with a five-byte one. */
int exceptIndex; /* Index of the first range entry in the
* ExceptionRange array after the current
* one. This field is used to adjust the
* code offsets in subsequent ExceptionRange
* records when a jump is grown from 2 bytes
* to 5 bytes. */
} JumpFixup;
#define JUMPFIXUP_INIT_ENTRIES 10
typedef struct JumpFixupArray {
JumpFixup *fixup; /* Points to start of jump fixup array. */
int next; /* Index of next free array entry. */
int end; /* Index of last usable entry in array. */
int mallocedArray; /* 1 if array was expanded and fixups points
* into the heap, else 0. */
JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES];
/* Initial storage for jump fixup array. */
} JumpFixupArray;
/*
* The structure describing one variable list of a foreach command. Note
* that only foreach commands inside procedure bodies are compiled inline so
* a ForeachVarList structure always describes local variables. Furthermore,
* only scalar variables are supported for inline-compiled foreach loops.
*/
typedef struct ForeachVarList {
int numVars; /* The number of variables in the list. */
int varIndexes[1]; /* An array of the indexes ("slot numbers")
* for each variable in the procedure's
* array of local variables. Only scalar
* variables are supported. The actual
* size of this field will be large enough
* to numVars indexes. THIS MUST BE THE
* LAST FIELD IN THE STRUCTURE! */
} ForeachVarList;
/*
* Structure used to hold information about a foreach command that is needed
* during program execution. These structures are stored in CompileEnv and
* ByteCode structures as auxiliary data.
*/
typedef struct ForeachInfo {
int numLists; /* The number of both the variable and value
* lists of the foreach command. */
int firstValueTemp; /* Index of the first temp var in a proc
* frame used to point to a value list. */
int loopCtTemp; /* Index of temp var in a proc frame
* holding the loop's iteration count. Used
* to determine next value list element to
* assign each loop var. */
ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList
* structures describing each var list. The
* actual size of this field will be large
* enough to numVars indexes. THIS MUST BE
* THE LAST FIELD IN THE STRUCTURE! */
} ForeachInfo;
extern AuxDataType tclForeachInfoType;
/*
*----------------------------------------------------------------
* Procedures exported by tclBasic.c to be used within the engine.
*----------------------------------------------------------------
*/
EXTERN int TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[], CONST char *command, int length,
int flags));
EXTERN int TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp));
/*
*----------------------------------------------------------------
* Procedures exported by the engine to be used by tclBasic.c
*----------------------------------------------------------------
*/
#ifndef TCL_TIP280
EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
#else
EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, CONST CmdFrame* invoker,
int word));
#endif
/*
*----------------------------------------------------------------
* Procedures shared among Tcl bytecode compilation and execution
* modules but not used outside:
*----------------------------------------------------------------
*/
EXTERN void TclCleanupByteCode _ANSI_ARGS_((ByteCode *codePtr));
EXTERN int TclCompileCmdWord _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr));
EXTERN int TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *script, int numBytes,
CompileEnv *envPtr));
EXTERN int TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *tokenPtr, int numWords,
CompileEnv *envPtr));
EXTERN int TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *script, int numBytes, int nested,
CompileEnv *envPtr));
EXTERN int TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr));
EXTERN int TclCreateAuxData _ANSI_ARGS_((ClientData clientData,
AuxDataType *typePtr, CompileEnv *envPtr));
EXTERN int TclCreateExceptRange _ANSI_ARGS_((
ExceptionRangeType type, CompileEnv *envPtr));
EXTERN ExecEnv * TclCreateExecEnv _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN void TclDeleteExecEnv _ANSI_ARGS_((ExecEnv *eePtr));
EXTERN void TclDeleteLiteralTable _ANSI_ARGS_((
Tcl_Interp *interp, LiteralTable *tablePtr));
EXTERN void TclEmitForwardJump _ANSI_ARGS_((CompileEnv *envPtr,
TclJumpType jumpType, JumpFixup *jumpFixupPtr));
EXTERN ExceptionRange * TclGetExceptionRangeForPc _ANSI_ARGS_((
unsigned char *pc, int catchOnly,
ByteCode* codePtr));
EXTERN void TclExpandJumpFixupArray _ANSI_ARGS_((
JumpFixupArray *fixupArrayPtr));
EXTERN void TclFinalizeAuxDataTypeTable _ANSI_ARGS_((void));
EXTERN int TclFindCompiledLocal _ANSI_ARGS_((CONST char *name,
int nameChars, int create, int flags,
Proc *procPtr));
EXTERN LiteralEntry * TclLookupLiteralEntry _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr));
EXTERN int TclFixupForwardJump _ANSI_ARGS_((
CompileEnv *envPtr, JumpFixup *jumpFixupPtr,
int jumpDist, int distThreshold));
EXTERN void TclFreeCompileEnv _ANSI_ARGS_((CompileEnv *envPtr));
EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_((
JumpFixupArray *fixupArrayPtr));
EXTERN void TclInitAuxDataTypeTable _ANSI_ARGS_((void));
EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr,
CompileEnv *envPtr));
#ifndef TCL_TIP280
EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp,
CompileEnv *envPtr, char *string,
int numBytes));
#else
EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp,
CompileEnv *envPtr, char *string,
int numBytes, CONST CmdFrame* invoker, int word));
#endif
EXTERN void TclInitJumpFixupArray _ANSI_ARGS_((
JumpFixupArray *fixupArrayPtr));
EXTERN void TclInitLiteralTable _ANSI_ARGS_((
LiteralTable *tablePtr));
#ifdef TCL_COMPILE_STATS
EXTERN char * TclLiteralStats _ANSI_ARGS_((
LiteralTable *tablePtr));
EXTERN int TclLog2 _ANSI_ARGS_((int value));
#endif
#ifdef TCL_COMPILE_DEBUG
EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
#endif
EXTERN int TclPrintInstruction _ANSI_ARGS_((ByteCode* codePtr,
unsigned char *pc));
EXTERN void TclPrintObject _ANSI_ARGS_((FILE *outFile,
Tcl_Obj *objPtr, int maxChars));
EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile,
CONST char *string, int maxChars));
EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr));
EXTERN int TclRegisterLiteral _ANSI_ARGS_((CompileEnv *envPtr,
char *bytes, int length, int onHeap));
EXTERN void TclReleaseLiteral _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
EXTERN void TclSetCmdNameObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, Command *cmdPtr));
#ifdef TCL_COMPILE_DEBUG
EXTERN void TclVerifyGlobalLiteralTable _ANSI_ARGS_((
Interp *iPtr));
EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_((
CompileEnv *envPtr));
#endif
EXTERN int TclCompileVariableCmd _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Parse *parsePtr, CompileEnv *envPtr));
/*
*----------------------------------------------------------------
* Macros used by Tcl bytecode compilation and execution modules
* inside the Tcl core but not used outside.
*----------------------------------------------------------------
*/
/*
* Form of TclRegisterLiteral with onHeap == 0.
* In that case, it is safe to cast away CONSTness, and it
* is cleanest to do that here, all in one place.
*/
#define TclRegisterNewLiteral(envPtr, bytes, length) \
TclRegisterLiteral(envPtr, (char *)(bytes), length, /*onHeap*/ 0)
/*
* Macro used to update the stack requirements.
* It is called by the macros TclEmitOpCode, TclEmitInst1 and
* TclEmitInst4.
* Remark that the very last instruction of a bytecode always
* reduces the stack level: INST_DONE or INST_POP, so that the
* maxStackdepth is always updated.
*/
#define TclUpdateStackReqs(op, i, envPtr) \
{\
int delta = tclInstructionTable[(op)].stackEffect;\
if (delta) {\
if (delta < 0) {\
if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\
(envPtr)->maxStackDepth = (envPtr)->currStackDepth;\
}\
if (delta == INT_MIN) {\
delta = 1 - (i);\
}\
}\
(envPtr)->currStackDepth += delta;\
}\
}
/*
* Macro to emit an opcode byte into a CompileEnv's code array.
* The ANSI C "prototype" for this macro is:
*
* EXTERN void TclEmitOpcode _ANSI_ARGS_((unsigned char op,
* CompileEnv *envPtr));
*/
#define TclEmitOpcode(op, envPtr) \
if ((envPtr)->codeNext == (envPtr)->codeEnd) \
TclExpandCodeArray(envPtr); \
*(envPtr)->codeNext++ = (unsigned char) (op);\
TclUpdateStackReqs(op, 0, envPtr)
/*
* Macro to emit an integer operand.
* The ANSI C "prototype" for this macro is:
*
* EXTERN void TclEmitInt1 _ANSI_ARGS_((int i, CompileEnv *envPtr));
*/
#define TclEmitInt1(i, envPtr) \
if ((envPtr)->codeNext == (envPtr)->codeEnd) \
TclExpandCodeArray(envPtr); \
*(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i))
/*
* Macros to emit an instruction with signed or unsigned integer operands.
* Four byte integers are stored in "big-endian" order with the high order
* byte stored at the lowest address.
* The ANSI C "prototypes" for these macros are:
*
* EXTERN void TclEmitInstInt1 _ANSI_ARGS_((unsigned char op, int i,
* CompileEnv *envPtr));
* EXTERN void TclEmitInstInt4 _ANSI_ARGS_((unsigned char op, int i,
* CompileEnv *envPtr));
*/
#define TclEmitInstInt1(op, i, envPtr) \
if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \
TclExpandCodeArray(envPtr); \
} \
*(envPtr)->codeNext++ = (unsigned char) (op); \
*(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i));\
TclUpdateStackReqs(op, i, envPtr)
#define TclEmitInstInt4(op, i, envPtr) \
if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \
TclExpandCodeArray(envPtr); \
} \
*(envPtr)->codeNext++ = (unsigned char) (op); \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) >> 24); \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) >> 16); \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) >> 8); \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) );\
TclUpdateStackReqs(op, i, envPtr)
/*
* Macro to push a Tcl object onto the Tcl evaluation stack. It emits the
* object's one or four byte array index into the CompileEnv's code
* array. These support, respectively, a maximum of 256 (2**8) and 2**32
* objects in a CompileEnv. The ANSI C "prototype" for this macro is:
*
* EXTERN void TclEmitPush _ANSI_ARGS_((int objIndex, CompileEnv *envPtr));
*/
#define TclEmitPush(objIndex, envPtr) \
{\
register int objIndexCopy = (objIndex);\
if (objIndexCopy <= 255) { \
TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \
} else { \
TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \
}\
}
/*
* Macros to update a (signed or unsigned) integer starting at a pointer.
* The two variants depend on the number of bytes. The ANSI C "prototypes"
* for these macros are:
*
* EXTERN void TclStoreInt1AtPtr _ANSI_ARGS_((int i, unsigned char *p));
* EXTERN void TclStoreInt4AtPtr _ANSI_ARGS_((int i, unsigned char *p));
*/
#define TclStoreInt1AtPtr(i, p) \
*(p) = (unsigned char) ((unsigned int) (i))
#define TclStoreInt4AtPtr(i, p) \
*(p) = (unsigned char) ((unsigned int) (i) >> 24); \
*(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \
*(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \
*(p+3) = (unsigned char) ((unsigned int) (i) )
/*
* Macros to update instructions at a particular pc with a new op code
* and a (signed or unsigned) int operand. The ANSI C "prototypes" for
* these macros are:
*
* EXTERN void TclUpdateInstInt1AtPc _ANSI_ARGS_((unsigned char op, int i,
* unsigned char *pc));
* EXTERN void TclUpdateInstInt4AtPc _ANSI_ARGS_((unsigned char op, int i,
* unsigned char *pc));
*/
#define TclUpdateInstInt1AtPc(op, i, pc) \
*(pc) = (unsigned char) (op); \
TclStoreInt1AtPtr((i), ((pc)+1))
#define TclUpdateInstInt4AtPc(op, i, pc) \
*(pc) = (unsigned char) (op); \
TclStoreInt4AtPtr((i), ((pc)+1))
/*
* Macros to get a signed integer (GET_INT{1,2}) or an unsigned int
* (GET_UINT{1,2}) from a pointer. There are two variants for each
* return type that depend on the number of bytes fetched.
* The ANSI C "prototypes" for these macros are:
*
* EXTERN int TclGetInt1AtPtr _ANSI_ARGS_((unsigned char *p));
* EXTERN int TclGetInt4AtPtr _ANSI_ARGS_((unsigned char *p));
* EXTERN unsigned int TclGetUInt1AtPtr _ANSI_ARGS_((unsigned char *p));
* EXTERN unsigned int TclGetUInt4AtPtr _ANSI_ARGS_((unsigned char *p));
*/
/*
* The TclGetInt1AtPtr macro is tricky because we want to do sign
* extension on the 1-byte value. Unfortunately the "char" type isn't
* signed on all platforms so sign-extension doesn't always happen
* automatically. Sometimes we can explicitly declare the pointer to be
* signed, but other times we have to explicitly sign-extend the value
* in software.
*/
#ifndef __CHAR_UNSIGNED__
# define TclGetInt1AtPtr(p) ((int) *((char *) p))
#else
# ifdef HAVE_SIGNED_CHAR
# define TclGetInt1AtPtr(p) ((int) *((signed char *) p))
# else
# define TclGetInt1AtPtr(p) (((int) *((char *) p)) \
| ((*(p) & 0200) ? (-256) : 0))
# endif
#endif
#define TclGetInt4AtPtr(p) (((int) TclGetInt1AtPtr(p) << 24) | \
(*((p)+1) << 16) | \
(*((p)+2) << 8) | \
(*((p)+3)))
#define TclGetUInt1AtPtr(p) ((unsigned int) *(p))
#define TclGetUInt4AtPtr(p) ((unsigned int) (*(p) << 24) | \
(*((p)+1) << 16) | \
(*((p)+2) << 8) | \
(*((p)+3)))
/*
* Macros used to compute the minimum and maximum of two integers.
* The ANSI C "prototypes" for these macros are:
*
* EXTERN int TclMin _ANSI_ARGS_((int i, int j));
* EXTERN int TclMax _ANSI_ARGS_((int i, int j));
*/
#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j))
#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j))
/*
* DTrace probe macros (NOPs if DTrace support is not enabled).
*/
/*
* Define the following macros to enable debug logging of the DTrace proc,
* cmd, and inst probes. Note that this does _not_ require a platform with
* DTrace, it simply logs all probe output to /tmp/tclDTraceDebug-[pid].log.
*
* If the second macro is defined, logging to file starts immediately,
* otherwise only after the first call to [tcl::dtrace]. Note that the debug
* probe data is always computed, even when it is not logged to file.
*
* Defining the third macro enables debug logging of inst probes (disabled
* by default due to the significant performance impact).
*/
/*
#define TCL_DTRACE_DEBUG 1
#define TCL_DTRACE_DEBUG_LOG_ENABLED 1
#define TCL_DTRACE_DEBUG_INST_PROBES 1
*/
#if !(defined(TCL_DTRACE_DEBUG) && defined(__GNUC__))
#ifdef USE_DTRACE
#include "tclDTrace.h"
#if defined(__GNUC__) && __GNUC__ > 2
/* Use gcc branch prediction hint to minimize cost of DTrace ENABLED checks. */
#define unlikely(x) (__builtin_expect((x), 0))
#else
#define unlikely(x) (x)
#endif
#define TCL_DTRACE_PROC_ENTRY_ENABLED() unlikely(TCL_PROC_ENTRY_ENABLED())
#define TCL_DTRACE_PROC_RETURN_ENABLED() unlikely(TCL_PROC_RETURN_ENABLED())
#define TCL_DTRACE_PROC_RESULT_ENABLED() unlikely(TCL_PROC_RESULT_ENABLED())
#define TCL_DTRACE_PROC_ARGS_ENABLED() unlikely(TCL_PROC_ARGS_ENABLED())
#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) TCL_PROC_ENTRY(a0, a1, a2)
#define TCL_DTRACE_PROC_RETURN(a0, a1) TCL_PROC_RETURN(a0, a1)
#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) TCL_PROC_RESULT(a0, a1, a2, a3)
#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
TCL_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9)
#define TCL_DTRACE_CMD_ENTRY_ENABLED() unlikely(TCL_CMD_ENTRY_ENABLED())
#define TCL_DTRACE_CMD_RETURN_ENABLED() unlikely(TCL_CMD_RETURN_ENABLED())
#define TCL_DTRACE_CMD_RESULT_ENABLED() unlikely(TCL_CMD_RESULT_ENABLED())
#define TCL_DTRACE_CMD_ARGS_ENABLED() unlikely(TCL_CMD_ARGS_ENABLED())
#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) TCL_CMD_ENTRY(a0, a1, a2)
#define TCL_DTRACE_CMD_RETURN(a0, a1) TCL_CMD_RETURN(a0, a1)
#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) TCL_CMD_RESULT(a0, a1, a2, a3)
#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
TCL_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9)
#define TCL_DTRACE_INST_START_ENABLED() unlikely(TCL_INST_START_ENABLED())
#define TCL_DTRACE_INST_DONE_ENABLED() unlikely(TCL_INST_DONE_ENABLED())
#define TCL_DTRACE_INST_START(a0, a1, a2) TCL_INST_START(a0, a1, a2)
#define TCL_DTRACE_INST_DONE(a0, a1, a2) TCL_INST_DONE(a0, a1, a2)
#define TCL_DTRACE_TCL_PROBE_ENABLED() unlikely(TCL_TCL_PROBE_ENABLED())
#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
TCL_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9)
#define TCL_DTRACE_DEBUG_LOG()
#else /* USE_DTRACE */
#define TCL_DTRACE_PROC_ENTRY_ENABLED() 0
#define TCL_DTRACE_PROC_RETURN_ENABLED() 0
#define TCL_DTRACE_PROC_RESULT_ENABLED() 0
#define TCL_DTRACE_PROC_ARGS_ENABLED() 0
#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) {}
#define TCL_DTRACE_PROC_RETURN(a0, a1) {}
#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) {}
#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {}
#define TCL_DTRACE_CMD_ENTRY_ENABLED() 0
#define TCL_DTRACE_CMD_RETURN_ENABLED() 0
#define TCL_DTRACE_CMD_RESULT_ENABLED() 0
#define TCL_DTRACE_CMD_ARGS_ENABLED() 0
#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) {}
#define TCL_DTRACE_CMD_RETURN(a0, a1) {}
#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) {}
#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {}
#define TCL_DTRACE_INST_START_ENABLED() 0
#define TCL_DTRACE_INST_DONE_ENABLED() 0
#define TCL_DTRACE_INST_START(a0, a1, a2) {}
#define TCL_DTRACE_INST_DONE(a0, a1, a2) {}
#define TCL_DTRACE_TCL_PROBE_ENABLED() 0
#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {}
#endif /* USE_DTRACE */
#else /* TCL_DTRACE_DEBUG */
#define USE_DTRACE 1
#if !defined(TCL_DTRACE_DEBUG_LOG_ENABLED) || !(TCL_DTRACE_DEBUG_LOG_ENABLED)
#undef TCL_DTRACE_DEBUG_LOG_ENABLED
#define TCL_DTRACE_DEBUG_LOG_ENABLED 0
#endif
#if !defined(TCL_DTRACE_DEBUG_INST_PROBES) || !(TCL_DTRACE_DEBUG_INST_PROBES)
#undef TCL_DTRACE_DEBUG_INST_PROBES
#define TCL_DTRACE_DEBUG_INST_PROBES 0
#endif
MODULE_SCOPE int tclDTraceDebugEnabled, tclDTraceDebugIndent;
MODULE_SCOPE FILE *tclDTraceDebugLog;
MODULE_SCOPE void TclDTraceOpenDebugLog(void);
MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi);
#define TCL_DTRACE_DEBUG_LOG() \
int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED;\
int tclDTraceDebugIndent = 0; \
FILE *tclDTraceDebugLog = NULL; \
void TclDTraceOpenDebugLog(void) { char n[35]; \
sprintf(n, "/tmp/tclDTraceDebug-%lu.log", (unsigned long) getpid()); \
tclDTraceDebugLog = fopen(n, "a"); } \
#define TclDTraceDbgMsg(p, m, ...) do { if (tclDTraceDebugEnabled) { \
int _l, _t = 0; if (!tclDTraceDebugLog) { TclDTraceOpenDebugLog(); } \
fprintf(tclDTraceDebugLog, "%.12s:%.4d:%n", strrchr(__FILE__, '/') + \
1, __LINE__, &_l); _t += _l; \
fprintf(tclDTraceDebugLog, " %.*s():%n", (_t < 18 ? 18 - _t : 0) + \
18, __func__, &_l); _t += _l; \
fprintf(tclDTraceDebugLog, "%*s" p "%n", (_t < 40 ? 40 - _t : 0) + \
2 * tclDTraceDebugIndent, "", &_l); _t += _l; \
fprintf(tclDTraceDebugLog, "%*s" m "\n", (_t < 64 ? 64 - _t : 1), "", \
##__VA_ARGS__); fflush(tclDTraceDebugLog); \
} } while (0)
#define TCL_DTRACE_PROC_ENTRY_ENABLED() 1
#define TCL_DTRACE_PROC_RETURN_ENABLED() 1
#define TCL_DTRACE_PROC_RESULT_ENABLED() 1
#define TCL_DTRACE_PROC_ARGS_ENABLED() 1
#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) \
tclDTraceDebugIndent++; \
TclDTraceDbgMsg("-> proc-entry", "%s %d %p", a0, a1, a2)
#define TCL_DTRACE_PROC_RETURN(a0, a1) \
TclDTraceDbgMsg("<- proc-return", "%s %d", a0, a1); \
tclDTraceDebugIndent--
#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) \
TclDTraceDbgMsg(" | proc-result", "%s %d %s %p", a0, a1, a2, a3)
#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
TclDTraceDbgMsg(" | proc-args", "%s %s %s %s %s %s %s %s %s %s", a0, \
a1, a2, a3, a4, a5, a6, a7, a8, a9)
#define TCL_DTRACE_CMD_ENTRY_ENABLED() 1
#define TCL_DTRACE_CMD_RETURN_ENABLED() 1
#define TCL_DTRACE_CMD_RESULT_ENABLED() 1
#define TCL_DTRACE_CMD_ARGS_ENABLED() 1
#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) \
tclDTraceDebugIndent++; \
TclDTraceDbgMsg("-> cmd-entry", "%s %d %p", a0, a1, a2)
#define TCL_DTRACE_CMD_RETURN(a0, a1) \
TclDTraceDbgMsg("<- cmd-return", "%s %d", a0, a1); \
tclDTraceDebugIndent--
#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) \
TclDTraceDbgMsg(" | cmd-result", "%s %d %s %p", a0, a1, a2, a3)
#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
TclDTraceDbgMsg(" | cmd-args", "%s %s %s %s %s %s %s %s %s %s", a0, \
a1, a2, a3, a4, a5, a6, a7, a8, a9)
#define TCL_DTRACE_INST_START_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES
#define TCL_DTRACE_INST_DONE_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES
#define TCL_DTRACE_INST_START(a0, a1, a2) \
TclDTraceDbgMsg(" | inst-start", "%s %d %p", a0, a1, a2)
#define TCL_DTRACE_INST_DONE(a0, a1, a2) \
TclDTraceDbgMsg(" | inst-end", "%s %d %p", a0, a1, a2)
#define TCL_DTRACE_TCL_PROBE_ENABLED() 1
#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
tclDTraceDebugEnabled = 1; \
TclDTraceDbgMsg(" | tcl-probe", "%s %s %s %s %s %s %s %s %s %s", a0, \
a1, a2, a3, a4, a5, a6, a7, a8, a9)
#endif /* TCL_DTRACE_DEBUG */
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLCOMPILATION */
tcl8.4.20/generic/tclCmdIL.c 0000644 0036047 0045461 00000356163 11737050674 014150 0 ustar dgp 771div /*
* tclCmdIL.c --
*
* This file contains the top-level command routines for most of
* the Tcl built-in commands whose names begin with the letters
* I through L. It contains only commands in the generic core
* (i.e. those that don't depend much upon UNIX facilities).
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1993-1997 Lucent Technologies.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"
/*
* During execution of the "lsort" command, structures of the following
* type are used to arrange the objects being sorted into a collection
* of linked lists.
*/
typedef struct SortElement {
Tcl_Obj *objPtr; /* Object being sorted. */
int count; /* number of same elements in list */
struct SortElement *nextPtr; /* Next element in the list, or
* NULL for end of list. */
} SortElement;
/*
* The "lsort" command needs to pass certain information down to the
* function that compares two list elements, and the comparison function
* needs to pass success or failure information back up to the top-level
* "lsort" command. The following structure is used to pass this
* information.
*/
typedef struct SortInfo {
int isIncreasing; /* Nonzero means sort in increasing order. */
int sortMode; /* The sort mode. One of SORTMODE_*
* values defined below */
Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode
* is SORTMODE_COMMAND. Pre-initialized to
* hold base of command.*/
int index; /* If the -index option was specified, this
* holds the index of the list element
* to extract for comparison. If -index
* wasn't specified, this is -1. */
Tcl_Interp *interp; /* The interpreter in which the sortis
* being done. */
int resultCode; /* Completion code for the lsort command.
* If an error occurs during the sort this
* is changed from TCL_OK to TCL_ERROR. */
} SortInfo;
/*
* The "sortMode" field of the SortInfo structure can take on any of the
* following values.
*/
#define SORTMODE_ASCII 0
#define SORTMODE_INTEGER 1
#define SORTMODE_REAL 2
#define SORTMODE_COMMAND 3
#define SORTMODE_DICTIONARY 4
/*
* Magic values for the index field of the SortInfo structure.
* Note that the index "end-1" will be translated to SORTIDX_END-1, etc.
*/
#define SORTIDX_NONE -1 /* Not indexed; use whole value. */
#define SORTIDX_END -2 /* Indexed from end. */
/*
* Forward declarations for procedures defined in this file:
*/
static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *listPtr, CONST char *pattern,
int includeLinks));
static int DictionaryCompare _ANSI_ARGS_((char *left,
char *right));
static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
#ifdef TCL_TIP280
/* TIP #280 - New 'info' subcommand 'frame' */
static int InfoFrameCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
#endif
static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoNameOfExecutableCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt,
SortInfo *infoPtr));
static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr,
SortElement *rightPtr, SortInfo *infoPtr));
static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
Tcl_Obj *second, SortInfo *infoPtr));
/*
*----------------------------------------------------------------------
*
* Tcl_IfObjCmd --
*
* This procedure is invoked to process the "if" Tcl command.
* See the user documentation for details on what it does.
*
* With the bytecode compiler, this procedure is only called when
* a command name is computed at runtime, and is "if" or the name
* to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_IfObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int thenScriptIndex = 0; /* then script to be evaled after syntax check */
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
int i, result, value;
char *clause;
i = 1;
while (1) {
/*
* At this point in the loop, objv and objc refer to an expression
* to test, either for the main expression or an expression
* following an "elseif". The arguments after the expression must
* be "then" (optional) and a script to execute if the expression is
* true.
*/
if (i >= objc) {
clause = Tcl_GetString(objv[i-1]);
Tcl_AppendResult(interp, "wrong # args: no expression after \"",
clause, "\" argument", (char *) NULL);
return TCL_ERROR;
}
if (!thenScriptIndex) {
result = Tcl_ExprBooleanObj(interp, objv[i], &value);
if (result != TCL_OK) {
return result;
}
}
i++;
if (i >= objc) {
missingScript:
clause = Tcl_GetString(objv[i-1]);
Tcl_AppendResult(interp, "wrong # args: no script following \"",
clause, "\" argument", (char *) NULL);
return TCL_ERROR;
}
clause = Tcl_GetString(objv[i]);
if ((i < objc) && (strcmp(clause, "then") == 0)) {
i++;
}
if (i >= objc) {
goto missingScript;
}
if (value) {
thenScriptIndex = i;
value = 0;
}
/*
* The expression evaluated to false. Skip the command, then
* see if there is an "else" or "elseif" clause.
*/
i++;
if (i >= objc) {
if (thenScriptIndex) {
#ifndef TCL_TIP280
return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
#else
/* TIP #280. Make invoking context available to branch */
return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
iPtr->cmdFramePtr,thenScriptIndex);
#endif
}
return TCL_OK;
}
clause = Tcl_GetString(objv[i]);
if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
i++;
continue;
}
break;
}
/*
* Couldn't find a "then" or "elseif" clause to execute. Check now
* for an "else" clause. We know that there's at least one more
* argument when we get here.
*/
if (strcmp(clause, "else") == 0) {
i++;
if (i >= objc) {
Tcl_AppendResult(interp,
"wrong # args: no script following \"else\" argument",
(char *) NULL);
return TCL_ERROR;
}
}
if (i < objc - 1) {
Tcl_AppendResult(interp,
"wrong # args: extra words after \"else\" clause in \"if\" command",
(char *) NULL);
return TCL_ERROR;
}
if (thenScriptIndex) {
#ifndef TCL_TIP280
return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
#else
/* TIP #280. Make invoking context available to branch/else */
return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
iPtr->cmdFramePtr,thenScriptIndex);
#endif
}
#ifndef TCL_TIP280
return Tcl_EvalObjEx(interp, objv[i], 0);
#else
return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i);
#endif
}
/*
*----------------------------------------------------------------------
*
* Tcl_IncrObjCmd --
*
* This procedure is invoked to process the "incr" Tcl command.
* See the user documentation for details on what it does.
*
* With the bytecode compiler, this procedure is only called when
* a command name is computed at runtime, and is "incr" or the name
* to which "incr" was renamed: e.g., "set z incr; $z i -1"
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_IncrObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
long incrAmount;
Tcl_Obj *newValuePtr;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
return TCL_ERROR;
}
/*
* Calculate the amount to increment by.
*/
if (objc == 2) {
incrAmount = 1;
} else {
if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (reading increment)");
return TCL_ERROR;
}
/*
* Need to be a bit cautious to ensure that [expr]-like rules
* are enforced for interpretation of wide integers, despite
* the fact that the underlying API itself is a 'long' only one.
*/
if (objv[2]->typePtr == &tclIntType) {
incrAmount = objv[2]->internalRep.longValue;
} else if (objv[2]->typePtr == &tclWideIntType) {
TclGetLongFromWide(incrAmount,objv[2]);
} else {
Tcl_WideInt wide;
if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (reading increment)");
return TCL_ERROR;
}
incrAmount = Tcl_WideAsLong(wide);
if ((wide <= Tcl_LongAsWide(LONG_MAX))
&& (wide >= Tcl_LongAsWide(LONG_MIN))) {
objv[2]->typePtr = &tclIntType;
objv[2]->internalRep.longValue = incrAmount;
}
}
}
/*
* Increment the variable's value.
*/
newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount,
TCL_LEAVE_ERR_MSG);
if (newValuePtr == NULL) {
return TCL_ERROR;
}
/*
* Set the interpreter's object result to refer to the variable's new
* value object.
*/
Tcl_SetObjResult(interp, newValuePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_InfoObjCmd --
*
* This procedure is invoked to process the "info" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_InfoObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Arbitrary value passed to the command. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *subCmds[] = {
"args", "body", "cmdcount", "commands",
"complete", "default", "exists",
#ifdef TCL_TIP280
"frame",
#endif
"functions",
"globals", "hostname", "level", "library", "loaded",
"locals", "nameofexecutable", "patchlevel", "procs",
"script", "sharedlibextension", "tclversion", "vars",
(char *) NULL};
enum ISubCmdIdx {
IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
ICompleteIdx, IDefaultIdx, IExistsIdx,
#ifdef TCL_TIP280
IFrameIdx,
#endif
IFunctionsIdx,
IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
};
int index, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
(int *) &index);
if (result != TCL_OK) {
return result;
}
switch (index) {
case IArgsIdx:
result = InfoArgsCmd(clientData, interp, objc, objv);
break;
case IBodyIdx:
result = InfoBodyCmd(clientData, interp, objc, objv);
break;
case ICmdCountIdx:
result = InfoCmdCountCmd(clientData, interp, objc, objv);
break;
case ICommandsIdx:
result = InfoCommandsCmd(clientData, interp, objc, objv);
break;
case ICompleteIdx:
result = InfoCompleteCmd(clientData, interp, objc, objv);
break;
case IDefaultIdx:
result = InfoDefaultCmd(clientData, interp, objc, objv);
break;
case IExistsIdx:
result = InfoExistsCmd(clientData, interp, objc, objv);
break;
#ifdef TCL_TIP280
case IFrameIdx:
/* TIP #280 - New method 'frame' */
result = InfoFrameCmd(clientData, interp, objc, objv);
break;
#endif
case IFunctionsIdx:
result = InfoFunctionsCmd(clientData, interp, objc, objv);
break;
case IGlobalsIdx:
result = InfoGlobalsCmd(clientData, interp, objc, objv);
break;
case IHostnameIdx:
result = InfoHostnameCmd(clientData, interp, objc, objv);
break;
case ILevelIdx:
result = InfoLevelCmd(clientData, interp, objc, objv);
break;
case ILibraryIdx:
result = InfoLibraryCmd(clientData, interp, objc, objv);
break;
case ILoadedIdx:
result = InfoLoadedCmd(clientData, interp, objc, objv);
break;
case ILocalsIdx:
result = InfoLocalsCmd(clientData, interp, objc, objv);
break;
case INameOfExecutableIdx:
result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
break;
case IPatchLevelIdx:
result = InfoPatchLevelCmd(clientData, interp, objc, objv);
break;
case IProcsIdx:
result = InfoProcsCmd(clientData, interp, objc, objv);
break;
case IScriptIdx:
result = InfoScriptCmd(clientData, interp, objc, objv);
break;
case ISharedLibExtensionIdx:
result = InfoSharedlibCmd(clientData, interp, objc, objv);
break;
case ITclVersionIdx:
result = InfoTclVersionCmd(clientData, interp, objc, objv);
break;
case IVarsIdx:
result = InfoVarsCmd(clientData, interp, objc, objv);
break;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* InfoArgsCmd --
*
* Called to implement the "info args" command that returns the
* argument list for a procedure. Handles the following syntax:
*
* info args procName
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoArgsCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
char *name;
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *listObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "procname");
return TCL_ERROR;
}
name = Tcl_GetString(objv[2]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"\"", name, "\" isn't a procedure", (char *) NULL);
return TCL_ERROR;
}
/*
* Build a return list containing the arguments.
*/
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
localPtr = localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)) {
Tcl_ListObjAppendElement(interp, listObjPtr,
Tcl_NewStringObj(localPtr->name, -1));
}
}
Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoBodyCmd --
*
* Called to implement the "info body" command that returns the body
* for a procedure. Handles the following syntax:
*
* info body procName
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoBodyCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
char *name;
Proc *procPtr;
Tcl_Obj *bodyPtr, *resultPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "procname");
return TCL_ERROR;
}
name = Tcl_GetString(objv[2]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"\"", name, "\" isn't a procedure", (char *) NULL);
return TCL_ERROR;
}
/*
* Here we used to return procPtr->bodyPtr, except when the body was
* bytecompiled - in that case, the return was a copy of the body's
* string rep. In order to better isolate the implementation details
* of the compiler/engine subsystem, we now always return a copy of
* the string rep. It is important to return a copy so that later
* manipulations of the object do not invalidate the internal rep.
*/
bodyPtr = procPtr->bodyPtr;
if (bodyPtr->bytes == NULL) {
/*
* The string rep might not be valid if the procedure has
* never been run before. [Bug #545644]
*/
(void) Tcl_GetString(bodyPtr);
}
resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoCmdCountCmd --
*
* Called to implement the "info cmdcount" command that returns the
* number of commands that have been executed. Handles the following
* syntax:
*
* info cmdcount
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCmdCountCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoCommandsCmd --
*
* Called to implement the "info commands" command that returns the
* list of commands in the interpreter that match an optional pattern.
* The pattern, if any, consists of an optional sequence of namespace
* names separated by "::" qualifiers, which is followed by a
* glob-style pattern that restricts which commands are returned.
* Handles the following syntax:
*
* info commands ?pattern?
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCommandsCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *cmdName, *pattern;
CONST char *simplePattern;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Namespace *nsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_Obj *listPtr, *elemObjPtr;
int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
Tcl_Command cmd;
/*
* Get the pattern and find the "effective namespace" in which to
* list commands.
*/
if (objc == 2) {
simplePattern = NULL;
nsPtr = currNsPtr;
specificNsInPattern = 0;
} else if (objc == 3) {
/*
* From the pattern, get the effective namespace and the simple
* pattern (no namespace qualifiers or ::'s) at the end. If an
* error was found while parsing the pattern, return it. Otherwise,
* if the namespace wasn't found, just leave nsPtr NULL: we will
* return an empty list since no commands there can be found.
*/
Namespace *dummy1NsPtr, *dummy2NsPtr;
pattern = Tcl_GetString(objv[2]);
TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
/*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
/*
* Exit as quickly as possible if we couldn't find the namespace.
*/
if (nsPtr == NULL) {
return TCL_OK;
}
/*
* Scan through the effective namespace's command table and create a
* list with all commands that match the pattern. If a specific
* namespace was requested in the pattern, qualify the command names
* with the namespace name.
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
/*
* Special case for when the pattern doesn't include any of
* glob's special characters. This lets us avoid scans of any
* hash tables.
*/
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
if (specificNsInPattern) {
cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
} else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable,
simplePattern);
if (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
}
}
} else {
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (specificNsInPattern) {
cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
entryPtr = Tcl_NextHashEntry(&search);
}
/*
* If the effective namespace isn't the global :: namespace, and a
* specific namespace wasn't requested in the pattern, then add in
* all global :: commands that match the simple pattern. Of course,
* we add in only those commands that aren't hidden by a command in
* the effective namespace.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoCompleteCmd --
*
* Called to implement the "info complete" command that determines
* whether a string is a complete Tcl command. Handles the following
* syntax:
*
* info complete command
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCompleteCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "command");
return TCL_ERROR;
}
if (TclObjCommandComplete(objv[2])) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoDefaultCmd --
*
* Called to implement the "info default" command that returns the
* default value for a procedure argument. Handles the following
* syntax:
*
* info default procName arg varName
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoDefaultCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
char *procName, *argName, *varName;
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *valueObjPtr;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
return TCL_ERROR;
}
procName = Tcl_GetString(objv[2]);
argName = Tcl_GetString(objv[3]);
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"\"", procName, "\" isn't a procedure", (char *) NULL);
return TCL_ERROR;
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
localPtr = localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)
&& (strcmp(argName, localPtr->name) == 0)) {
if (localPtr->defValuePtr != NULL) {
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
localPtr->defValuePtr, 0);
if (valueObjPtr == NULL) {
defStoreError:
varName = Tcl_GetString(objv[4]);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't store default value in variable \"",
varName, "\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else {
Tcl_Obj *nullObjPtr = Tcl_NewObj();
Tcl_IncrRefCount(nullObjPtr);
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
nullObjPtr, 0);
Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
if (valueObjPtr == NULL) {
goto defStoreError;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
}
return TCL_OK;
}
}
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"procedure \"", procName, "\" doesn't have an argument \"",
argName, "\"", (char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* InfoExistsCmd --
*
* Called to implement the "info exists" command that determines
* whether a variable exists. Handles the following syntax:
*
* info exists varName
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoExistsCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *varName;
Var *varPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varName");
return TCL_ERROR;
}
varName = Tcl_GetString(objv[2]);
varPtr = TclVarTraceExists(interp, varName);
if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
}
return TCL_OK;
}
#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
*
* InfoFrameCmd --
* TIP #280
*
* Called to implement the "info frame" command that returns the
* location of either the currently executing command, or its caller.
* Handles the following syntax:
*
* info frame ?number?
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoFrameCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if (objc == 2) {
/* just "info frame" */
int levels = (iPtr->cmdFramePtr == NULL
? 0
: iPtr->cmdFramePtr->level);
Tcl_SetObjResult(interp, Tcl_NewIntObj (levels));
return TCL_OK;
} else if (objc == 3) {
/* "info frame level" */
int level;
CmdFrame *framePtr;
if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
return TCL_ERROR;
}
if (level <= 0) {
/* Relative adressing */
if (iPtr->cmdFramePtr == NULL) {
levelError:
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad level \"",
Tcl_GetString(objv[2]),
"\"", (char *) NULL);
return TCL_ERROR;
}
/* Convert to absolute. */
level += iPtr->cmdFramePtr->level;
}
for (framePtr = iPtr->cmdFramePtr;
framePtr != NULL;
framePtr = framePtr->nextPtr) {
if (framePtr->level == level) {
break;
}
}
if (framePtr == NULL) {
goto levelError;
}
/*
* Pull the information and construct the dictionary to return, as
* list. Regarding use of the CmdFrame fields see tclInt.h, and its
* definition.
*/
{
Tcl_Obj* lv [20]; /* Keep uptodate when more keys are added to the dict */
int lc = 0;
/* This array is indexed by the TCL_LOCATION_... values, except
* for _LAST.
*/
static CONST char* typeString [TCL_LOCATION_LAST] = {
"eval", "eval", "eval", "precompiled", "source", "proc"
};
Proc* procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL;
switch (framePtr->type) {
case TCL_LOCATION_EVAL:
/* Evaluation, dynamic script. Type, line, cmd, the latter
* through str. */
lv [lc ++] = Tcl_NewStringObj ("type",-1);
lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
lv [lc ++] = Tcl_NewStringObj ("line",-1);
lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
framePtr->cmd.str.len);
break;
case TCL_LOCATION_EVAL_LIST:
/* List optimized evaluation. Type, line, cmd, the latter
* through listPtr, possibly a frame. */
lv [lc ++] = Tcl_NewStringObj ("type",-1);
lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
lv [lc ++] = Tcl_NewStringObj ("line",-1);
lv [lc ++] = Tcl_NewIntObj (1);
/* We put a duplicate of the command list obj into the result
* to ensure that the 'pure List'-property of the command
* itself is not destroyed. Otherwise the query here would
* disable the list optimization path in Tcl_EvalObjEx.
*/
lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
lv [lc ++] = Tcl_DuplicateObj (framePtr->cmd.listPtr);
break;
case TCL_LOCATION_PREBC:
/* Precompiled. Result contains the type as signal, nothing
* else */
lv [lc ++] = Tcl_NewStringObj ("type",-1);
lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
break;
case TCL_LOCATION_BC: {
/* Execution of bytecode. Talk to the BC engine to fill out
* the frame. */
CmdFrame f = *framePtr;
/* Note: Type BC => f.data.eval.path is not used.
* f.data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc (&f);
/* Now filled: cmd.str.(cmd,len), line */
/* Possibly modified: type, path! */
lv [lc ++] = Tcl_NewStringObj ("type",-1);
lv [lc ++] = Tcl_NewStringObj (typeString [f.type],-1);
lv [lc ++] = Tcl_NewStringObj ("line",-1);
lv [lc ++] = Tcl_NewIntObj (f.line[0]);
if (f.type == TCL_LOCATION_SOURCE) {
lv [lc ++] = Tcl_NewStringObj ("file",-1);
lv [lc ++] = f.data.eval.path;
/* Death of reference by TclGetSrcInfoForPc */
Tcl_DecrRefCount (f.data.eval.path);
}
lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
lv [lc ++] = Tcl_NewStringObj (f.cmd.str.cmd, f.cmd.str.len);
break;
}
case TCL_LOCATION_SOURCE:
/* Evaluation of a script file */
lv [lc ++] = Tcl_NewStringObj ("type",-1);
lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
lv [lc ++] = Tcl_NewStringObj ("line",-1);
lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
lv [lc ++] = Tcl_NewStringObj ("file",-1);
lv [lc ++] = framePtr->data.eval.path;
/* Refcount framePtr->data.eval.path goes up when lv
* is converted into the result list object.
*/
lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
framePtr->cmd.str.len);
break;
case TCL_LOCATION_PROC:
Tcl_Panic ("TCL_LOCATION_PROC found in standard frame");
break;
}
/*
* 'proc'. Common to all frame types. Conditional on having an
* associated Procedure CallFrame.
*/
if (procPtr != NULL) {
Tcl_HashEntry* namePtr = procPtr->cmdPtr->hPtr;
/*
* ITcl seems to provide us with weird, maybe bogus Command
* structures (methods?) which may have no HashEntry pointing
* to the name information, or a HashEntry without owning
* HashTable. Therefore check again that our data is valid.
*/
if (namePtr && namePtr->tablePtr) {
char* procName = Tcl_GetHashKey (namePtr->tablePtr, namePtr);
char* nsName = procPtr->cmdPtr->nsPtr->fullName;
lv [lc ++] = Tcl_NewStringObj ("proc",-1);
lv [lc ++] = Tcl_NewStringObj (nsName,-1);
if (strcmp (nsName, "::") != 0) {
Tcl_AppendToObj (lv [lc-1], "::", -1);
}
Tcl_AppendToObj (lv [lc-1], procName, -1);
}
}
/* 'level'. Common to all frame types. Conditional on having an
* associated _visible_ CallFrame */
if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) {
CallFrame* current = framePtr->framePtr;
CallFrame* top = iPtr->varFramePtr;
CallFrame* idx;
for (idx = top;
idx != NULL;
idx = idx->callerVarPtr) {
if (idx == current) {
int c = framePtr->framePtr->level;
int t = iPtr->varFramePtr->level;
lv [lc ++] = Tcl_NewStringObj ("level",-1);
lv [lc ++] = Tcl_NewIntObj (t - c);
break;
}
}
}
Tcl_SetObjResult(interp, Tcl_NewListObj (lc, lv));
return TCL_OK;
}
}
Tcl_WrongNumArgs(interp, 2, objv, "?number?");
return TCL_ERROR;
}
#endif
/*
*----------------------------------------------------------------------
*
* InfoFunctionsCmd --
*
* Called to implement the "info functions" command that returns the
* list of math functions matching an optional pattern. Handles the
* following syntax:
*
* info functions ?pattern?
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoFunctionsCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *pattern;
Tcl_Obj *listPtr;
if (objc == 2) {
pattern = NULL;
} else if (objc == 3) {
pattern = Tcl_GetString(objv[2]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
listPtr = Tcl_ListMathFuncs(interp, pattern);
if (listPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoGlobalsCmd --
*
* Called to implement the "info globals" command that returns the list
* of global variables matching an optional pattern. Handles the
* following syntax:
*
* info globals ?pattern?
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoGlobalsCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *varName, *pattern;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Var *varPtr;
Tcl_Obj *listPtr;
if (objc == 2) {
pattern = NULL;
} else if (objc == 3) {
pattern = Tcl_GetString(objv[2]);
/*
* Strip leading global-namespace qualifiers. [Bug 1057461]
*/
if (pattern[0] == ':' && pattern[1] == ':') {
while (*pattern == ':') {
pattern++;
}
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
/*
* Scan through the global :: namespace's variable table and create a
* list of all global variables that match the pattern.
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if (pattern != NULL && TclMatchIsTrivial(pattern)) {
entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern);
if (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(pattern, -1));
}
}
} else {
for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (TclIsVarUndefined(varPtr)) {
continue;
}
varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
}
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoHostnameCmd --
*
* Called to implement the "info hostname" command that returns the
* host name. Handles the following syntax:
*
* info hostname
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoHostnameCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
CONST char *name;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
name = Tcl_GetHostName();
if (name) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);
return TCL_OK;
} else {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"unable to determine name of host", -1);
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
* InfoLevelCmd --
*
* Called to implement the "info level" command that returns
* information about the call stack. Handles the following syntax:
*
* info level ?number?
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLevelCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
int level;
CallFrame *framePtr;
Tcl_Obj *listPtr;
if (objc == 2) { /* just "info level" */
if (iPtr->varFramePtr == NULL) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
} else {
Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
}
return TCL_OK;
} else if (objc == 3) {
if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
return TCL_ERROR;
}
if (level <= 0) {
if (iPtr->varFramePtr == NULL) {
levelError:
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad level \"",
Tcl_GetString(objv[2]),
"\"", (char *) NULL);
return TCL_ERROR;
}
level += iPtr->varFramePtr->level;
}
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
framePtr = framePtr->callerVarPtr) {
if (framePtr->level == level) {
break;
}
}
if (framePtr == NULL) {
goto levelError;
}
listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
Tcl_WrongNumArgs(interp, 2, objv, "?number?");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* InfoLibraryCmd --
*
* Called to implement the "info library" command that returns the
* library directory for the Tcl installation. Handles the following
* syntax:
*
* info library
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLibraryCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
CONST char *libDirName;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
if (libDirName != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
return TCL_OK;
}
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"no library has been specified for Tcl", -1);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* InfoLoadedCmd --
*
* Called to implement the "info loaded" command that returns the
* packages that have been loaded into an interpreter. Handles the
* following syntax:
*
* info loaded ?interp?
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLoadedCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *interpName;
int result;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
return TCL_ERROR;
}
if (objc == 2) { /* get loaded pkgs in all interpreters */
interpName = NULL;
} else { /* get pkgs just in specified interp */
interpName = Tcl_GetString(objv[2]);
}
result = TclGetLoadedPackages(interp, interpName);
return result;
}
/*
*----------------------------------------------------------------------
*
* InfoLocalsCmd --
*
* Called to implement the "info locals" command to return a list of
* local variables that match an optional pattern. Handles the
* following syntax:
*
* info locals ?pattern?
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLocalsCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
char *pattern;
Tcl_Obj *listPtr;
if (objc == 2) {
pattern = NULL;
} else if (objc == 3) {
pattern = Tcl_GetString(objv[2]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) {
return TCL_OK;
}
/*
* Return a list containing names of first the compiled locals (i.e. the
* ones stored in the call frame), then the variables in the local hash
* table (if one exists).
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
AppendLocals(interp, listPtr, pattern, 0);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AppendLocals --
*
* Append the local variables for the current frame to the
* specified list object.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
AppendLocals(interp, listPtr, pattern, includeLinks)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Obj *listPtr; /* List object to append names to. */
CONST char *pattern; /* Pattern to match against. */
int includeLinks; /* 1 if upvars should be included, else 0. */
{
Interp *iPtr = (Interp *) interp;
CompiledLocal *localPtr;
Var *varPtr;
int i, localVarCt;
char *varName;
Tcl_HashTable *localVarTablePtr;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
localVarCt = iPtr->varFramePtr->numCompiledLocals;
varPtr = iPtr->varFramePtr->compiledLocals;
localVarTablePtr = iPtr->varFramePtr->varTablePtr;
for (i = 0; i < localVarCt; i++) {
/*
* Skip nameless (temporary) variables and undefined variables
*/
if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)
&& (includeLinks || !TclIsVarLink(varPtr))) {
varName = varPtr->name;
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
}
}
varPtr++;
localPtr = localPtr->nextPtr;
}
if (localVarTablePtr != NULL) {
for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
&& (includeLinks || !TclIsVarLink(varPtr))) {
varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
if ((pattern == NULL)
|| Tcl_StringMatch(varName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
}
}
}
}
}
/*
*----------------------------------------------------------------------
*
* InfoNameOfExecutableCmd --
*
* Called to implement the "info nameofexecutable" command that returns
* the name of the binary file running this application. Handles the
* following syntax:
*
* info nameofexecutable
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoNameOfExecutableCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
CONST char *nameOfExecutable;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
nameOfExecutable = Tcl_GetNameOfExecutable();
if (nameOfExecutable != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), nameOfExecutable, -1);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoPatchLevelCmd --
*
* Called to implement the "info patchlevel" command that returns the
* default value for an argument to a procedure. Handles the following
* syntax:
*
* info patchlevel
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoPatchLevelCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
CONST char *patchlevel;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
if (patchlevel != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
return TCL_OK;
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* InfoProcsCmd --
*
* Called to implement the "info procs" command that returns the
* list of procedures in the interpreter that match an optional pattern.
* The pattern, if any, consists of an optional sequence of namespace
* names separated by "::" qualifiers, which is followed by a
* glob-style pattern that restricts which commands are returned.
* Handles the following syntax:
*
* info procs ?pattern?
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoProcsCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *cmdName, *pattern;
CONST char *simplePattern;
Namespace *nsPtr;
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
#endif
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_Obj *listPtr, *elemObjPtr;
int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Command *cmdPtr, *realCmdPtr;
/*
* Get the pattern and find the "effective namespace" in which to
* list procs.
*/
if (objc == 2) {
simplePattern = NULL;
nsPtr = currNsPtr;
specificNsInPattern = 0;
} else if (objc == 3) {
/*
* From the pattern, get the effective namespace and the simple
* pattern (no namespace qualifiers or ::'s) at the end. If an
* error was found while parsing the pattern, return it. Otherwise,
* if the namespace wasn't found, just leave nsPtr NULL: we will
* return an empty list since no commands there can be found.
*/
Namespace *dummy1NsPtr, *dummy2NsPtr;
pattern = Tcl_GetString(objv[2]);
TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
/*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
&simplePattern);
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
if (nsPtr == NULL) {
return TCL_OK;
}
/*
* Scan through the effective namespace's command table and create a
* list with all procs that match the pattern. If a specific
* namespace was requested in the pattern, qualify the command names
* with the namespace name.
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
goto simpleProcOK;
}
} else {
simpleProcOK:
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
} else
#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */
{
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
goto procOK;
}
} else {
procOK:
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
/*
* If the effective namespace isn't the global :: namespace, and a
* specific namespace wasn't requested in the pattern, then add in
* all global :: procs that match the simple pattern. Of course,
* we add in only those procs that aren't hidden by a proc in
* the effective namespace.
*/
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
/*
* If "info procs" worked like "info commands", returning the
* commands also seen in the global namespace, then you would
* include this code. As this could break backwards compatibilty
* with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the
* behavior slightly different.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
realCmdPtr = (Command *) TclGetOriginalCommand(
(Tcl_Command) cmdPtr);
if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL)
&& TclIsProc(realCmdPtr))) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
}
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
}
#endif
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoScriptCmd --
*
* Called to implement the "info script" command that returns the
* script file that is currently being evaluated. Handles the
* following syntax:
*
* info script ?newName?
*
* If newName is specified, it will set that as the internal name.
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message. It may change the
* internal script filename.
*
*----------------------------------------------------------------------
*/
static int
InfoScriptCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 2, objv, "?filename?");
return TCL_ERROR;
}
if (objc == 3) {
if (iPtr->scriptFile != NULL) {
Tcl_DecrRefCount(iPtr->scriptFile);
}
iPtr->scriptFile = objv[2];
Tcl_IncrRefCount(iPtr->scriptFile);
}
if (iPtr->scriptFile != NULL) {
Tcl_SetObjResult(interp, iPtr->scriptFile);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoSharedlibCmd --
*
* Called to implement the "info sharedlibextension" command that
* returns the file extension used for shared libraries. Handles the
* following syntax:
*
* info sharedlibextension
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoSharedlibCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
#ifdef TCL_SHLIB_EXT
Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
#endif
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoTclVersionCmd --
*
* Called to implement the "info tclversion" command that returns the
* version number for this Tcl library. Handles the following syntax:
*
* info tclversion
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoTclVersionCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
CONST char *version;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
version = Tcl_GetVar(interp, "tcl_version",
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
if (version != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
return TCL_OK;
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* InfoVarsCmd --
*
* Called to implement the "info vars" command that returns the
* list of variables in the interpreter that match an optional pattern.
* The pattern, if any, consists of an optional sequence of namespace
* names separated by "::" qualifiers, which is followed by a
* glob-style pattern that restricts which variables are returned.
* Handles the following syntax:
*
* info vars ?pattern?
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoVarsCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
char *varName, *pattern;
CONST char *simplePattern;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Var *varPtr;
Namespace *nsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_Obj *listPtr, *elemObjPtr;
int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
/*
* Get the pattern and find the "effective namespace" in which to
* list variables. We only use this effective namespace if there's
* no active Tcl procedure frame.
*/
if (objc == 2) {
simplePattern = NULL;
nsPtr = currNsPtr;
specificNsInPattern = 0;
} else if (objc == 3) {
/*
* From the pattern, get the effective namespace and the simple
* pattern (no namespace qualifiers or ::'s) at the end. If an
* error was found while parsing the pattern, return it. Otherwise,
* if the namespace wasn't found, just leave nsPtr NULL: we will
* return an empty list since no variables there can be found.
*/
Namespace *dummy1NsPtr, *dummy2NsPtr;
pattern = Tcl_GetString(objv[2]);
TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
/*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
&simplePattern);
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
/*
* If the namespace specified in the pattern wasn't found, just return.
*/
if (nsPtr == NULL) {
return TCL_OK;
}
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if ((iPtr->varFramePtr == NULL)
|| !iPtr->varFramePtr->isProcCallFrame
|| specificNsInPattern) {
/*
* There is no frame pointer, the frame pointer was pushed only
* to activate a namespace, or we are in a procedure call frame
* but a specific namespace was specified. Create a list containing
* only the variables in the effective namespace's variable table.
*/
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
/*
* If we can just do hash lookups, that simplifies things
* a lot.
*/
entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern);
if (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
} else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable,
simplePattern);
if (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(simplePattern, -1));
}
}
}
} else {
/*
* Have to scan the tables of variables.
*/
entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(varName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
/*
* If the effective namespace isn't the global ::
* namespace, and a specific namespace wasn't requested in
* the pattern (i.e., the pattern only specifies variable
* names), then add in all global :: variables that match
* the simple pattern. Of course, add in only those
* variables that aren't hidden by a variable in the
* effective namespace.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
varName = Tcl_GetHashKey(&globalNsPtr->varTable,
entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->varTable,
varName) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
}
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
}
}
} else if (((Interp *)interp)->varFramePtr->procPtr != NULL) {
AppendLocals(interp, listPtr, simplePattern, 1);
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_JoinObjCmd --
*
* This procedure is invoked to process the "join" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_JoinObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
char *joinString, *bytes;
int joinLength, listLen, length, i, result;
Tcl_Obj **elemPtrs;
Tcl_Obj *resObjPtr;
if (objc == 2) {
joinString = " ";
joinLength = 1;
} else if (objc == 3) {
joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
return TCL_ERROR;
}
/*
* Make sure the list argument is a list object and get its length and
* a pointer to its array of element pointers.
*/
result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
/*
* Now concatenate strings to form the "joined" result. We append
* directly into the interpreter's result object.
*/
resObjPtr = Tcl_GetObjResult(interp);
for (i = 0; i < listLen; i++) {
bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
if (i > 0) {
Tcl_AppendToObj(resObjPtr, joinString, joinLength);
}
Tcl_AppendToObj(resObjPtr, bytes, length);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LindexObjCmd --
*
* This object-based procedure is invoked to process the "lindex" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_LindexObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *elemPtr; /* Pointer to the element being extracted */
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?");
return TCL_ERROR;
}
/*
* If objc == 3, then objv[ 2 ] may be either a single index or
* a list of indices: go to TclLindexList to determine which.
* If objc >= 4, or objc == 2, then objv[ 2 .. objc-2 ] are all
* single indices and processed as such in TclLindexFlat.
*/
if ( objc == 3 ) {
elemPtr = TclLindexList( interp, objv[ 1 ], objv[ 2 ] );
} else {
elemPtr = TclLindexFlat( interp, objv[ 1 ], objc-2, objv+2 );
}
/*
* Set the interpreter's object result to the last element extracted
*/
if ( elemPtr == NULL ) {
return TCL_ERROR;
} else {
Tcl_SetObjResult(interp, elemPtr);
Tcl_DecrRefCount( elemPtr );
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
* TclLindexList --
*
* This procedure handles the 'lindex' command when objc==3.
*
* Results:
* Returns a pointer to the object extracted, or NULL if an
* error occurred.
*
* Side effects:
* None.
*
* If objv[1] can be parsed as a list, TclLindexList handles extraction
* of the desired element locally. Otherwise, it invokes
* TclLindexFlat to treat objv[1] as a scalar.
*
* The reference count of the returned object includes one reference
* corresponding to the pointer returned. Thus, the calling code will
* usually do something like:
* Tcl_SetObjResult( interp, result );
* Tcl_DecrRefCount( result );
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLindexList( interp, listPtr, argPtr )
Tcl_Interp* interp; /* Tcl interpreter */
Tcl_Obj* listPtr; /* List being unpacked */
Tcl_Obj* argPtr; /* Index or index list */
{
Tcl_Obj **elemPtrs; /* Elements of the list being manipulated. */
int listLen; /* Length of the list being manipulated. */
int index; /* Index into the list */
int result; /* Result returned from a Tcl library call */
int i; /* Current index number */
Tcl_Obj** indices; /* Array of list indices */
int indexCount; /* Size of the array of list indices */
Tcl_Obj* oldListPtr; /* Temp location to preserve the list
* pointer when replacing it with a sublist */
/*
* Determine whether argPtr designates a list or a single index.
* We have to be careful about the order of the checks to avoid
* repeated shimmering; see TIP#22 and TIP#33 for the details.
*/
if ( argPtr->typePtr != &tclListType
&& TclGetIntForIndex( NULL , argPtr, 0, &index ) == TCL_OK ) {
/*
* argPtr designates a single index.
*/
return TclLindexFlat( interp, listPtr, 1, &argPtr );
} else if ( Tcl_ListObjGetElements( NULL, argPtr, &indexCount, &indices )
!= TCL_OK ) {
/*
* argPtr designates something that is neither an index nor a
* well-formed list. Report the error via TclLindexFlat.
*/
return TclLindexFlat( interp, listPtr, 1, &argPtr );
}
/*
* Record the reference to the list that we are maintaining in
* the activation record.
*/
Tcl_IncrRefCount( listPtr );
/*
* argPtr designates a list, and the 'else if' above has parsed it
* into indexCount and indices.
*/
for ( i = 0; i < indexCount; ++i ) {
/*
* Convert the current listPtr to a list if necessary.
*/
result = Tcl_ListObjGetElements( interp, listPtr,
&listLen, &elemPtrs);
if (result != TCL_OK) {
Tcl_DecrRefCount( listPtr );
return NULL;
}
/*
* Get the index from indices[ i ]
*/
result = TclGetIntForIndex( interp, indices[ i ],
/*endValue*/ (listLen - 1),
&index );
if ( result != TCL_OK ) {
/*
* Index could not be parsed
*/
Tcl_DecrRefCount( listPtr );
return NULL;
} else if ( index < 0
|| index >= listLen ) {
/*
* Index is out of range
*/
Tcl_DecrRefCount( listPtr );
listPtr = Tcl_NewObj();
Tcl_IncrRefCount( listPtr );
return listPtr;
}
/*
* Make sure listPtr still refers to a list object.
* If it shared a Tcl_Obj structure with the arguments, then
* it might have just been converted to something else.
*/
if (listPtr->typePtr != &tclListType) {
result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
&elemPtrs);
if (result != TCL_OK) {
Tcl_DecrRefCount( listPtr );
return NULL;
}
}
/*
* Extract the pointer to the appropriate element
*/
oldListPtr = listPtr;
listPtr = elemPtrs[ index ];
Tcl_IncrRefCount( listPtr );
Tcl_DecrRefCount( oldListPtr );
/*
* The work we did above may have caused the internal rep
* of *argPtr to change to something else. Get it back.
*/
result = Tcl_ListObjGetElements( interp, argPtr,
&indexCount, &indices );
if ( result != TCL_OK ) {
/*
* This can't happen unless some extension corrupted a Tcl_Obj.
*/
Tcl_DecrRefCount( listPtr );
return NULL;
}
} /* end for */
/*
* Return the last object extracted. Its reference count will include
* the reference being returned.
*/
return listPtr;
}
/*
*----------------------------------------------------------------------
*
* TclLindexFlat --
*
* This procedure handles the 'lindex' command, given that the
* arguments to the command are known to be a flat list.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
* This procedure is called from either tclExecute.c or
* Tcl_LindexObjCmd whenever either is presented with
* objc == 2 or objc >= 4. It is also called from TclLindexList
* for the objc==3 case once it is determined that objv[2] cannot
* be parsed as a list.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLindexFlat( interp, listPtr, indexCount, indexArray )
Tcl_Interp* interp; /* Tcl interpreter */
Tcl_Obj* listPtr; /* Tcl object representing the list */
int indexCount; /* Count of indices */
Tcl_Obj* CONST indexArray[];
/* Array of pointers to Tcl objects
* representing the indices in the
* list */
{
int i; /* Current list index */
int result; /* Result of Tcl library calls */
int listLen; /* Length of the current list being
* processed */
Tcl_Obj** elemPtrs; /* Array of pointers to the elements
* of the current list */
int index; /* Parsed version of the current element
* of indexArray */
Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that
* its ref count can be decremented. */
/*
* Record the reference to the 'listPtr' object that we are
* maintaining in the C activation record.
*/
Tcl_IncrRefCount( listPtr );
for ( i = 0; i < indexCount; ++i ) {
/*
* Convert the current listPtr to a list if necessary.
*/
result = Tcl_ListObjGetElements(interp, listPtr,
&listLen, &elemPtrs);
if (result != TCL_OK) {
Tcl_DecrRefCount( listPtr );
return NULL;
}
/*
* Get the index from objv[i]
*/
result = TclGetIntForIndex( interp, indexArray[ i ],
/*endValue*/ (listLen - 1),
&index );
if ( result != TCL_OK ) {
/* Index could not be parsed */
Tcl_DecrRefCount( listPtr );
return NULL;
} else if ( index < 0
|| index >= listLen ) {
/*
* Index is out of range
*/
Tcl_DecrRefCount( listPtr );
listPtr = Tcl_NewObj();
Tcl_IncrRefCount( listPtr );
return listPtr;
}
/*
* Make sure listPtr still refers to a list object.
* It might have been converted to something else above
* if objv[1] overlaps with one of the other parameters.
*/
if (listPtr->typePtr != &tclListType) {
result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
&elemPtrs);
if (result != TCL_OK) {
Tcl_DecrRefCount( listPtr );
return NULL;
}
}
/*
* Extract the pointer to the appropriate element
*/
oldListPtr = listPtr;
listPtr = elemPtrs[ index ];
Tcl_IncrRefCount( listPtr );
Tcl_DecrRefCount( oldListPtr );
}
return listPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LinsertObjCmd --
*
* This object-based procedure is invoked to process the "linsert" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A new Tcl list object formed by inserting zero or more elements
* into a list.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_LinsertObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
register int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *listPtr;
int index, isDuplicate, len, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
return TCL_ERROR;
}
result = Tcl_ListObjLength(interp, objv[1], &len);
if (result != TCL_OK) {
return result;
}
/*
* Get the index. "end" is interpreted to be the index after the last
* element, such that using it will cause any inserted elements to be
* appended to the list.
*/
result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index);
if (result != TCL_OK) {
return result;
}
if (index > len) {
index = len;
}
/*
* If the list object is unshared we can modify it directly. Otherwise
* we create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
isDuplicate = 0;
if (Tcl_IsShared(listPtr)) {
listPtr = Tcl_DuplicateObj(listPtr);
isDuplicate = 1;
}
if ((objc == 4) && (index == len)) {
/*
* Special case: insert one element at the end of the list.
*/
result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
} else if (objc > 3) {
result = Tcl_ListObjReplace(interp, listPtr, index, 0,
(objc-3), &(objv[3]));
}
if (result != TCL_OK) {
if (isDuplicate) {
Tcl_DecrRefCount(listPtr); /* free unneeded obj */
}
return result;
}
/*
* Set the interpreter's object result.
*/
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjCmd --
*
* This procedure is invoked to process the "list" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ListObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
register int objc; /* Number of arguments. */
register Tcl_Obj *CONST objv[]; /* The argument objects. */
{
/*
* If there are no list elements, the result is an empty object.
* Otherwise modify the interpreter's result object to be a list object.
*/
if (objc > 1) {
Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LlengthObjCmd --
*
* This object-based procedure is invoked to process the "llength" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_LlengthObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
register Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int listLen, result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
result = Tcl_ListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
/*
* Set the interpreter's object result to an integer object holding the
* length.
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LrangeObjCmd --
*
* This procedure is invoked to process the "lrange" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
ClientData notUsed; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
register Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *listPtr;
Tcl_Obj **elemPtrs;
int listLen, first, last, numElems, result;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
/*
* Make sure the list argument is a list object and get its length and
* a pointer to its array of element pointers.
*/
listPtr = objv[1];
result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
/*
* Get the first and last indexes.
*/
result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
&first);
if (result != TCL_OK) {
return result;
}
if (first < 0) {
first = 0;
}
result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
&last);
if (result != TCL_OK) {
return result;
}
if (last >= listLen) {
last = (listLen - 1);
}
if (first > last) {
return TCL_OK; /* the result is an empty object */
}
/*
* Make sure listPtr still refers to a list object. It might have been
* converted to an int above if the argument objects were shared.
*/
if (listPtr->typePtr != &tclListType) {
result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
}
/*
* Extract a range of fields. We modify the interpreter's result object
* to be a list object containing the specified elements.
*/
numElems = (last - first + 1);
Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LreplaceObjCmd --
*
* This object-based procedure is invoked to process the "lreplace"
* Tcl command. See the user documentation for details on what it does.
*
* Results:
* A new Tcl list object formed by replacing zero or more elements of
* a list.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Tcl_Obj *listPtr;
int isDuplicate, first, last, listLen, numToDelete, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"list first last ?element element ...?");
return TCL_ERROR;
}
result = Tcl_ListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
/*
* Get the first and last indexes. "end" is interpreted to be the index
* for the last element, such that using it will cause that element to
* be included for deletion.
*/
result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first);
if (result != TCL_OK) {
return result;
}
result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last);
if (result != TCL_OK) {
return result;
}
if (first < 0) {
first = 0;
}
/*
* Complain if the user asked for a start element that is greater than the
* list length. This won't ever trigger for the "end*" case as that will
* be properly constrained by TclGetIntForIndex because we use listLen-1
* (to allow for replacing the last elem).
*/
if ((first >= listLen) && (listLen > 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"list doesn't contain element ",
Tcl_GetString(objv[2]), (int *) NULL);
return TCL_ERROR;
}
if (last >= listLen) {
last = (listLen - 1);
}
if (first <= last) {
numToDelete = (last - first + 1);
} else {
numToDelete = 0;
}
/*
* If the list object is unshared we can modify it directly, otherwise
* we create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
isDuplicate = 0;
if (Tcl_IsShared(listPtr)) {
listPtr = Tcl_DuplicateObj(listPtr);
isDuplicate = 1;
}
if (objc > 4) {
result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
(objc-4), &(objv[4]));
} else {
result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
0, NULL);
}
if (result != TCL_OK) {
if (isDuplicate) {
Tcl_DecrRefCount(listPtr); /* free unneeded obj */
}
return result;
}
/*
* Set the interpreter's object result.
*/
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LsearchObjCmd --
*
* This procedure is invoked to process the "lsearch" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsearchObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument values. */
{
char *bytes, *patternBytes;
int i, match, mode, index, result, listc, length, elemLen;
int dataType, isIncreasing, lower, upper, patInt, objInt;
int offset, allMatches, inlineReturn, negatedMatch;
double patDouble, objDouble;
Tcl_Obj *patObj, **listv, *listPtr, *startPtr;
Tcl_RegExp regexp = NULL;
static CONST char *options[] = {
"-all", "-ascii", "-decreasing", "-dictionary",
"-exact", "-glob", "-increasing", "-inline",
"-integer", "-not", "-real", "-regexp",
"-sorted", "-start", NULL
};
enum options {
LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY,
LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INLINE,
LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP,
LSEARCH_SORTED, LSEARCH_START
};
enum datatypes {
ASCII, DICTIONARY, INTEGER, REAL
};
enum modes {
EXACT, GLOB, REGEXP, SORTED
};
mode = GLOB;
dataType = ASCII;
isIncreasing = 1;
allMatches = 0;
inlineReturn = 0;
negatedMatch = 0;
listPtr = NULL;
startPtr = NULL;
offset = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern");
return TCL_ERROR;
}
for (i = 1; i < objc-2; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
!= TCL_OK) {
if (startPtr) {
Tcl_DecrRefCount(startPtr);
}
return TCL_ERROR;
}
switch ((enum options) index) {
case LSEARCH_ALL: /* -all */
allMatches = 1;
break;
case LSEARCH_ASCII: /* -ascii */
dataType = ASCII;
break;
case LSEARCH_DECREASING: /* -decreasing */
isIncreasing = 0;
break;
case LSEARCH_DICTIONARY: /* -dictionary */
dataType = DICTIONARY;
break;
case LSEARCH_EXACT: /* -increasing */
mode = EXACT;
break;
case LSEARCH_GLOB: /* -glob */
mode = GLOB;
break;
case LSEARCH_INCREASING: /* -increasing */
isIncreasing = 1;
break;
case LSEARCH_INLINE: /* -inline */
inlineReturn = 1;
break;
case LSEARCH_INTEGER: /* -integer */
dataType = INTEGER;
break;
case LSEARCH_NOT: /* -not */
negatedMatch = 1;
break;
case LSEARCH_REAL: /* -real */
dataType = REAL;
break;
case LSEARCH_REGEXP: /* -regexp */
mode = REGEXP;
break;
case LSEARCH_SORTED: /* -sorted */
mode = SORTED;
break;
case LSEARCH_START: /* -start */
/*
* If there was a previous -start option, release its saved
* index because it will either be replaced or there will be
* an error.
*/
if (startPtr) {
Tcl_DecrRefCount(startPtr);
}
if (i > objc-4) {
Tcl_AppendResult(interp, "missing starting index", NULL);
return TCL_ERROR;
}
i++;
if (objv[i] == objv[objc - 2]) {
/*
* Take copy to prevent shimmering problems. Note
* that it does not matter if the index obj is also a
* component of the list being searched. We only need
* to copy where the list and the index are
* one-and-the-same.
*/
startPtr = Tcl_DuplicateObj(objv[i]);
} else {
startPtr = objv[i];
Tcl_IncrRefCount(startPtr);
}
}
}
if ((enum modes) mode == REGEXP) {
/*
* We can shimmer regexp/list if listv[i] == pattern, so get the
* regexp rep before the list rep. First time round, omit the interp
* and hope that the compilation will succeed. If it fails, we'll
* recompile in "expensive" mode with a place to put error messages.
*/
regexp = Tcl_GetRegExpFromObj(NULL, objv[objc - 1],
TCL_REG_ADVANCED | TCL_REG_NOSUB);
if (regexp == NULL) {
/*
* Failed to compile the RE. Try again without the TCL_REG_NOSUB
* flag in case the RE had sub-expressions in it [Bug 1366683].
* If this fails, an error message will be left in the
* interpreter.
*/
regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1],
TCL_REG_ADVANCED);
}
if (regexp == NULL) {
if (startPtr) {
Tcl_DecrRefCount(startPtr);
}
return TCL_ERROR;
}
}
/*
* Make sure the list argument is a list object and get its length and
* a pointer to its array of element pointers.
*/
result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv);
if (result != TCL_OK) {
if (startPtr) {
Tcl_DecrRefCount(startPtr);
}
return result;
}
/*
* Get the user-specified start offset.
*/
if (startPtr) {
result = TclGetIntForIndex(interp, startPtr, listc-1, &offset);
Tcl_DecrRefCount(startPtr);
if (result != TCL_OK) {
return result;
}
/*
* If the search started past the end of the list, we just return a
* "did not match anything at all" result straight away. [Bug 1374778]
*/
if (offset > listc-1) {
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
}
return TCL_OK;
}
if (offset < 0) {
offset = 0;
}
}
patObj = objv[objc - 1];
patternBytes = NULL;
if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) {
switch ((enum datatypes) dataType) {
case ASCII:
case DICTIONARY:
patternBytes = Tcl_GetStringFromObj(patObj, &length);
break;
case INTEGER:
result = Tcl_GetIntFromObj(interp, patObj, &patInt);
if (result != TCL_OK) {
return result;
}
Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
break;
case REAL:
result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
if (result != TCL_OK) {
return result;
}
Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
break;
}
} else {
patternBytes = Tcl_GetStringFromObj(patObj, &length);
}
/*
* Set default index value to -1, indicating failure; if we find the
* item in the course of our search, index will be set to the correct
* value.
*/
index = -1;
match = 0;
if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) {
/*
* If the data is sorted, we can do a more intelligent search.
* Note that there is no point in being smart when -all was
* specified; in that case, we have to look at all items anyway,
* and there is no sense in doing this when the match sense is
* inverted.
*/
lower = offset - 1;
upper = listc;
while (lower + 1 != upper) {
i = (lower + upper)/2;
switch ((enum datatypes) dataType) {
case ASCII:
bytes = Tcl_GetString(listv[i]);
match = strcmp(patternBytes, bytes);
break;
case DICTIONARY:
bytes = Tcl_GetString(listv[i]);
match = DictionaryCompare(patternBytes, bytes);
break;
case INTEGER:
result = Tcl_GetIntFromObj(interp, listv[i], &objInt);
if (result != TCL_OK) {
return result;
}
if (patInt == objInt) {
match = 0;
} else if (patInt < objInt) {
match = -1;
} else {
match = 1;
}
break;
case REAL:
result = Tcl_GetDoubleFromObj(interp, listv[i], &objDouble);
if (result != TCL_OK) {
return result;
}
if (patDouble == objDouble) {
match = 0;
} else if (patDouble < objDouble) {
match = -1;
} else {
match = 1;
}
break;
}
if (match == 0) {
/*
* Normally, binary search is written to stop when it
* finds a match. If there are duplicates of an element in
* the list, our first match might not be the first occurance.
* Consider: 0 0 0 1 1 1 2 2 2
* To maintain consistancy with standard lsearch semantics,
* we must find the leftmost occurance of the pattern in the
* list. Thus we don't just stop searching here. This
* variation means that a search always makes log n
* comparisons (normal binary search might "get lucky" with
* an early comparison).
*/
index = i;
upper = i;
} else if (match > 0) {
if (isIncreasing) {
lower = i;
} else {
upper = i;
}
} else {
if (isIncreasing) {
upper = i;
} else {
lower = i;
}
}
}
} else {
/*
* We need to do a linear search, because (at least one) of:
* - our matcher can only tell equal vs. not equal
* - our matching sense is negated
* - we're building a list of all matched items
*/
if (allMatches) {
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
}
for (i = offset; i < listc; i++) {
match = 0;
switch ((enum modes) mode) {
case SORTED:
case EXACT:
switch ((enum datatypes) dataType) {
case ASCII:
bytes = Tcl_GetStringFromObj(listv[i], &elemLen);
if (length == elemLen) {
match = (memcmp(bytes, patternBytes,
(size_t) length) == 0);
}
break;
case DICTIONARY:
bytes = Tcl_GetString(listv[i]);
match = (DictionaryCompare(bytes, patternBytes) == 0);
break;
case INTEGER:
result = Tcl_GetIntFromObj(interp, listv[i], &objInt);
if (result != TCL_OK) {
if (listPtr) {
Tcl_DecrRefCount(listPtr);
}
return result;
}
match = (objInt == patInt);
break;
case REAL:
result = Tcl_GetDoubleFromObj(interp, listv[i],
&objDouble);
if (result != TCL_OK) {
if (listPtr) {
Tcl_DecrRefCount(listPtr);
}
return result;
}
match = (objDouble == patDouble);
break;
}
break;
case GLOB:
match = Tcl_StringMatch(Tcl_GetString(listv[i]),
patternBytes);
break;
case REGEXP:
match = Tcl_RegExpExecObj(interp, regexp, listv[i], 0, 0, 0);
if (match < 0) {
Tcl_DecrRefCount(patObj);
if (listPtr) {
Tcl_DecrRefCount(listPtr);
}
return TCL_ERROR;
}
break;
}
/*
* Invert match condition for -not
*/
if (negatedMatch) {
match = !match;
}
if (match != 0) {
if (!allMatches) {
index = i;
break;
} else if (inlineReturn) {
/*
* Note that these appends are not expected to fail.
*/
Tcl_ListObjAppendElement(interp, listPtr, listv[i]);
} else {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewIntObj(i));
}
}
}
}
/*
* Return everything or a single value.
*/
if (allMatches) {
Tcl_SetObjResult(interp, listPtr);
} else if (!inlineReturn) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
} else if (index < 0) {
/*
* Is this superfluous? The result should be a blank object
* by default...
*/
Tcl_SetObjResult(interp, Tcl_NewObj());
} else {
Tcl_SetObjResult(interp, listv[index]);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LsetObjCmd --
*
* This procedure is invoked to process the "lset" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsetObjCmd( clientData, interp, objc, objv )
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument values. */
{
Tcl_Obj* listPtr; /* Pointer to the list being altered. */
Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable */
/* Check parameter count */
if ( objc < 3 ) {
Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" );
return TCL_ERROR;
}
/* Look up the list variable's value */
listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL,
TCL_LEAVE_ERR_MSG );
if ( listPtr == NULL ) {
return TCL_ERROR;
}
/*
* Substitute the value in the value. Return either the value or
* else an unshared copy of it.
*/
if ( objc == 4 ) {
finalValuePtr = TclLsetList( interp, listPtr,
objv[ 2 ], objv[ 3 ] );
} else {
finalValuePtr = TclLsetFlat( interp, listPtr,
objc-3, objv+2, objv[ objc-1 ] );
}
/*
* If substitution has failed, bail out.
*/
if ( finalValuePtr == NULL ) {
return TCL_ERROR;
}
/* Finally, update the variable so that traces fire. */
listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr,
TCL_LEAVE_ERR_MSG );
Tcl_DecrRefCount( finalValuePtr );
if ( listPtr == NULL ) {
return TCL_ERROR;
}
/* Return the new value of the variable as the interpreter result. */
Tcl_SetObjResult( interp, listPtr );
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LsortObjCmd --
*
* This procedure is invoked to process the "lsort" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsortObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument values. */
{
int i, index, unique;
Tcl_Obj *resultPtr;
int length;
Tcl_Obj *cmdPtr, **listObjPtrs;
SortElement *elementArray;
SortElement *elementPtr;
SortInfo sortInfo; /* Information about this sort that
* needs to be passed to the
* comparison function */
static CONST char *switches[] = {
"-ascii", "-command", "-decreasing", "-dictionary", "-increasing",
"-index", "-integer", "-real", "-unique", (char *) NULL
};
resultPtr = Tcl_GetObjResult(interp);
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
return TCL_ERROR;
}
/*
* Parse arguments to set up the mode for the sort.
*/
sortInfo.isIncreasing = 1;
sortInfo.sortMode = SORTMODE_ASCII;
sortInfo.index = SORTIDX_NONE;
sortInfo.interp = interp;
sortInfo.resultCode = TCL_OK;
cmdPtr = NULL;
unique = 0;
for (i = 1; i < objc-1; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
!= TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case 0: /* -ascii */
sortInfo.sortMode = SORTMODE_ASCII;
break;
case 1: /* -command */
if (i == (objc-2)) {
Tcl_AppendToObj(resultPtr,
"\"-command\" option must be followed by comparison command",
-1);
return TCL_ERROR;
}
sortInfo.sortMode = SORTMODE_COMMAND;
cmdPtr = objv[i+1];
i++;
break;
case 2: /* -decreasing */
sortInfo.isIncreasing = 0;
break;
case 3: /* -dictionary */
sortInfo.sortMode = SORTMODE_DICTIONARY;
break;
case 4: /* -increasing */
sortInfo.isIncreasing = 1;
break;
case 5: /* -index */
if (i == (objc-2)) {
Tcl_AppendToObj(resultPtr,
"\"-index\" option must be followed by list index",
-1);
return TCL_ERROR;
}
if (TclGetIntForIndex(interp, objv[i+1], SORTIDX_END,
&sortInfo.index) != TCL_OK) {
return TCL_ERROR;
}
i++;
break;
case 6: /* -integer */
sortInfo.sortMode = SORTMODE_INTEGER;
break;
case 7: /* -real */
sortInfo.sortMode = SORTMODE_REAL;
break;
case 8: /* -unique */
unique = 1;
break;
}
}
if (sortInfo.sortMode == SORTMODE_COMMAND) {
/*
* The existing command is a list. We want to flatten it, append
* two dummy arguments on the end, and replace these arguments
* later.
*/
Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr);
Tcl_Obj *newObjPtr = Tcl_NewObj();
Tcl_IncrRefCount(newCommandPtr);
if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr)
!= TCL_OK) {
Tcl_DecrRefCount(newCommandPtr);
Tcl_IncrRefCount(newObjPtr);
Tcl_DecrRefCount(newObjPtr);
return TCL_ERROR;
}
Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sortInfo.compareCmdPtr = newCommandPtr;
}
sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
&length, &listObjPtrs);
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
for (i=0; i < length; i++){
elementArray[i].objPtr = listObjPtrs[i];
elementArray[i].count = 0;
elementArray[i].nextPtr = &elementArray[i+1];
/*
* When sorting using a command, we are reentrant and therefore might
* have the representation of the list being sorted shimmered out from
* underneath our feet. Increment the reference counts of the elements
* to sort to prevent this. [Bug 1675116]
*/
Tcl_IncrRefCount(elementArray[i].objPtr);
}
elementArray[length-1].nextPtr = NULL;
elementPtr = MergeSort(elementArray, &sortInfo);
if (sortInfo.resultCode == TCL_OK) {
/*
* Note: must clear the interpreter's result object: it could
* have been set by the -command script.
*/
Tcl_ResetResult(interp);
resultPtr = Tcl_GetObjResult(interp);
if (unique) {
for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
if (elementPtr->count == 0) {
Tcl_ListObjAppendElement(interp, resultPtr,
elementPtr->objPtr);
}
}
} else {
for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
Tcl_ListObjAppendElement(interp, resultPtr,
elementPtr->objPtr);
}
}
}
for (i=0; inextPtr;
elementPtr->nextPtr = 0;
for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
subList[i] = NULL;
}
if (i >= NUM_LISTS) {
i = NUM_LISTS-1;
}
subList[i] = elementPtr;
}
elementPtr = NULL;
for (i = 0; i < NUM_LISTS; i++){
elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
}
return elementPtr;
}
/*
*----------------------------------------------------------------------
*
* MergeLists -
*
* This procedure combines two sorted lists of SortElement structures
* into a single sorted list.
*
* Results:
* The unified list of SortElement structures.
*
* Side effects:
* None, unless a user-defined comparison command does something
* weird.
*
*----------------------------------------------------------------------
*/
static SortElement *
MergeLists(leftPtr, rightPtr, infoPtr)
SortElement *leftPtr; /* First list to be merged; may be
* NULL. */
SortElement *rightPtr; /* Second list to be merged; may be
* NULL. */
SortInfo *infoPtr; /* Information needed by the
* comparison operator. */
{
SortElement *headPtr;
SortElement *tailPtr;
int cmp;
if (leftPtr == NULL) {
return rightPtr;
}
if (rightPtr == NULL) {
return leftPtr;
}
cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);
if (cmp > 0) {
tailPtr = rightPtr;
rightPtr = rightPtr->nextPtr;
} else {
if (cmp == 0) {
leftPtr->count++;
}
tailPtr = leftPtr;
leftPtr = leftPtr->nextPtr;
}
headPtr = tailPtr;
while ((leftPtr != NULL) && (rightPtr != NULL)) {
cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);
if (cmp > 0) {
tailPtr->nextPtr = rightPtr;
tailPtr = rightPtr;
rightPtr = rightPtr->nextPtr;
} else {
if (cmp == 0) {
leftPtr->count++;
}
tailPtr->nextPtr = leftPtr;
tailPtr = leftPtr;
leftPtr = leftPtr->nextPtr;
}
}
if (leftPtr != NULL) {
tailPtr->nextPtr = leftPtr;
} else {
tailPtr->nextPtr = rightPtr;
}
return headPtr;
}
/*
*----------------------------------------------------------------------
*
* SortCompare --
*
* This procedure is invoked by MergeLists to determine the proper
* ordering between two elements.
*
* Results:
* A negative results means the the first element comes before the
* second, and a positive results means that the second element
* should come first. A result of zero means the two elements
* are equal and it doesn't matter which comes first.
*
* Side effects:
* None, unless a user-defined comparison command does something
* weird.
*
*----------------------------------------------------------------------
*/
static int
SortCompare(objPtr1, objPtr2, infoPtr)
Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */
SortInfo *infoPtr; /* Information passed from the
* top-level "lsort" command */
{
int order, listLen, index;
Tcl_Obj *objPtr;
char buffer[TCL_INTEGER_SPACE];
order = 0;
if (infoPtr->resultCode != TCL_OK) {
/*
* Once an error has occurred, skip any future comparisons
* so as to preserve the error message in sortInterp->result.
*/
return order;
}
if (infoPtr->index != SORTIDX_NONE) {
/*
* The "-index" option was specified. Treat each object as a
* list, extract the requested element from each list, and
* compare the elements, not the lists. "end"-relative indices
* are signaled here with large negative values.
*/
if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (infoPtr->index < SORTIDX_NONE) {
index = listLen + infoPtr->index + 1;
} else {
index = infoPtr->index;
}
if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)
!= TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (objPtr == NULL) {
objPtr = objPtr1;
missingElement:
TclFormatInt(buffer, infoPtr->index);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
"element ", buffer, " missing from sublist \"",
Tcl_GetString(objPtr), "\"", (char *) NULL);
infoPtr->resultCode = TCL_ERROR;
return order;
}
objPtr1 = objPtr;
if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (infoPtr->index < SORTIDX_NONE) {
index = listLen + infoPtr->index + 1;
} else {
index = infoPtr->index;
}
if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)
!= TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (objPtr == NULL) {
objPtr = objPtr2;
goto missingElement;
}
objPtr2 = objPtr;
}
if (infoPtr->sortMode == SORTMODE_ASCII) {
order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));
} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
order = DictionaryCompare(
Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));
} else if (infoPtr->sortMode == SORTMODE_INTEGER) {
long a, b;
if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
|| (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b)
!= TCL_OK)) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (a > b) {
order = 1;
} else if (b > a) {
order = -1;
}
} else if (infoPtr->sortMode == SORTMODE_REAL) {
double a, b;
if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
|| (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
!= TCL_OK)) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (a > b) {
order = 1;
} else if (b > a) {
order = -1;
}
} else {
Tcl_Obj **objv, *paramObjv[2];
int objc;
paramObjv[0] = objPtr1;
paramObjv[1] = objPtr2;
/*
* We made space in the command list for the two things to
* compare. Replace them and evaluate the result.
*/
Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
2, 2, paramObjv);
Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
&objc, &objv);
infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
if (infoPtr->resultCode != TCL_OK) {
Tcl_AddErrorInfo(infoPtr->interp,
"\n (-compare command)");
return order;
}
/*
* Parse the result of the command.
*/
if (Tcl_GetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
Tcl_ResetResult(infoPtr->interp);
Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
"-compare command returned non-integer result", -1);
infoPtr->resultCode = TCL_ERROR;
return order;
}
}
if (!infoPtr->isIncreasing) {
order = -order;
}
return order;
}
/*
*----------------------------------------------------------------------
*
* DictionaryCompare
*
* This function compares two strings as if they were being used in
* an index or card catalog. The case of alphabetic characters is
* ignored, except to break ties. Thus "B" comes before "b" but
* after "a". Also, integers embedded in the strings compare in
* numerical order. In other words, "x10y" comes after "x9y", not
* before it as it would when using strcmp().
*
* Results:
* A negative result means that the first element comes before the
* second, and a positive result means that the second element
* should come first. A result of zero means the two elements
* are equal and it doesn't matter which comes first.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
DictionaryCompare(left, right)
char *left, *right; /* The strings to compare */
{
Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower;
int diff, zeros;
int secondaryDiff = 0;
while (1) {
if (isdigit(UCHAR(*right)) /* INTL: digit */
&& isdigit(UCHAR(*left))) { /* INTL: digit */
/*
* There are decimal numbers embedded in the two
* strings. Compare them as numbers, rather than
* strings. If one number has more leading zeros than
* the other, the number with more leading zeros sorts
* later, but only as a secondary choice.
*/
zeros = 0;
while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
right++;
zeros--;
}
while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
left++;
zeros++;
}
if (secondaryDiff == 0) {
secondaryDiff = zeros;
}
/*
* The code below compares the numbers in the two
* strings without ever converting them to integers. It
* does this by first comparing the lengths of the
* numbers and then comparing the digit values.
*/
diff = 0;
while (1) {
if (diff == 0) {
diff = UCHAR(*left) - UCHAR(*right);
}
right++;
left++;
if (!isdigit(UCHAR(*right))) { /* INTL: digit */
if (isdigit(UCHAR(*left))) { /* INTL: digit */
return 1;
} else {
/*
* The two numbers have the same length. See
* if their values are different.
*/
if (diff != 0) {
return diff;
}
break;
}
} else if (!isdigit(UCHAR(*left))) { /* INTL: digit */
return -1;
}
}
continue;
}
/*
* Convert character to Unicode for comparison purposes. If either
* string is at the terminating null, do a byte-wise comparison and
* bail out immediately.
*/
if ((*left != '\0') && (*right != '\0')) {
left += Tcl_UtfToUniChar(left, &uniLeft);
right += Tcl_UtfToUniChar(right, &uniRight);
/*
* Convert both chars to lower for the comparison, because
* dictionary sorts are case insensitve. Covert to lower, not
* upper, so chars between Z and a will sort before A (where most
* other interesting punctuations occur)
*/
uniLeftLower = Tcl_UniCharToLower(uniLeft);
uniRightLower = Tcl_UniCharToLower(uniRight);
} else {
diff = UCHAR(*left) - UCHAR(*right);
break;
}
diff = uniLeftLower - uniRightLower;
if (diff) {
return diff;
} else if (secondaryDiff == 0) {
if (Tcl_UniCharIsUpper(uniLeft) &&
Tcl_UniCharIsLower(uniRight)) {
secondaryDiff = -1;
} else if (Tcl_UniCharIsUpper(uniRight)
&& Tcl_UniCharIsLower(uniLeft)) {
secondaryDiff = 1;
}
}
}
if (diff == 0) {
diff = secondaryDiff;
}
return diff;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclPreserve.c 0000644 0036047 0045461 00000032025 11737050674 014777 0 ustar dgp 771div /*
* tclPreserve.c --
*
* This file contains a collection of procedures that are used
* to make sure that widget records and other data structures
* aren't reallocated when there are nested procedures that
* depend on their existence.
*
* Copyright (c) 1991-1994 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.
*/
#include "tclInt.h"
/*
* The following data structure is used to keep track of all the
* Tcl_Preserve calls that are still in effect. It grows as needed
* to accommodate any number of calls in effect.
*/
typedef struct {
ClientData clientData; /* Address of preserved block. */
int refCount; /* Number of Tcl_Preserve calls in effect
* for block. */
int mustFree; /* Non-zero means Tcl_EventuallyFree was
* called while a Tcl_Preserve call was in
* effect, so the structure must be freed
* when refCount becomes zero. */
Tcl_FreeProc *freeProc; /* Procedure to call to free. */
} Reference;
static Reference *refArray; /* First in array of references. */
static int spaceAvl = 0; /* Total number of structures available
* at *firstRefPtr. */
static int inUse = 0; /* Count of structures currently in use
* in refArray. */
#define INITIAL_SIZE 2
TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */
/*
* The following data structure is used to keep track of whether an
* arbitrary block of memory has been deleted. This is used by the
* TclHandle code to avoid the more time-expensive algorithm of
* Tcl_Preserve(). This mechanism is mainly used when we have lots of
* references to a few big, expensive objects that we don't want to live
* any longer than necessary.
*/
typedef struct HandleStruct {
VOID *ptr; /* Pointer to the memory block being
* tracked. This field will become NULL when
* the memory block is deleted. This field
* must be the first in the structure. */
#ifdef TCL_MEM_DEBUG
VOID *ptr2; /* Backup copy of the abpve pointer used to
* ensure that the contents of the handle are
* not changed by anyone else. */
#endif
int refCount; /* Number of TclHandlePreserve() calls in
* effect on this handle. */
} HandleStruct;
/*
*----------------------------------------------------------------------
*
* TclFinalizePreserve --
*
* Called during exit processing to clean up the reference array.
*
* Results:
* None.
*
* Side effects:
* Frees the storage of the reference array.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
void
TclFinalizePreserve()
{
Tcl_MutexLock(&preserveMutex);
if (spaceAvl != 0) {
ckfree((char *) refArray);
refArray = (Reference *) NULL;
inUse = 0;
spaceAvl = 0;
}
Tcl_MutexUnlock(&preserveMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Preserve --
*
* This procedure is used by a procedure to declare its interest
* in a particular block of memory, so that the block will not be
* reallocated until a matching call to Tcl_Release has been made.
*
* Results:
* None.
*
* Side effects:
* Information is retained so that the block of memory will
* not be freed until at least the matching call to Tcl_Release.
*
*----------------------------------------------------------------------
*/
void
Tcl_Preserve(clientData)
ClientData clientData; /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
int i;
/*
* See if there is already a reference for this pointer. If so,
* just increment its reference count.
*/
Tcl_MutexLock(&preserveMutex);
for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
if (refPtr->clientData == clientData) {
refPtr->refCount++;
Tcl_MutexUnlock(&preserveMutex);
return;
}
}
/*
* Make a reference array if it doesn't already exist, or make it
* bigger if it is full.
*/
if (inUse == spaceAvl) {
if (spaceAvl == 0) {
refArray = (Reference *) ckalloc((unsigned)
(INITIAL_SIZE*sizeof(Reference)));
spaceAvl = INITIAL_SIZE;
} else {
Reference *new;
new = (Reference *) ckalloc((unsigned)
(2*spaceAvl*sizeof(Reference)));
memcpy((VOID *) new, (VOID *) refArray,
spaceAvl*sizeof(Reference));
ckfree((char *) refArray);
refArray = new;
spaceAvl *= 2;
}
}
/*
* Make a new entry for the new reference.
*/
refPtr = &refArray[inUse];
refPtr->clientData = clientData;
refPtr->refCount = 1;
refPtr->mustFree = 0;
refPtr->freeProc = TCL_STATIC;
inUse += 1;
Tcl_MutexUnlock(&preserveMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Release --
*
* This procedure is called to cancel a previous call to
* Tcl_Preserve, thereby allowing a block of memory to be
* freed (if no one else cares about it).
*
* Results:
* None.
*
* Side effects:
* If Tcl_EventuallyFree has been called for clientData, and if
* no other call to Tcl_Preserve is still in effect, the block of
* memory is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_Release(clientData)
ClientData clientData; /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
int mustFree;
Tcl_FreeProc *freeProc;
int i;
Tcl_MutexLock(&preserveMutex);
for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
if (refPtr->clientData != clientData) {
continue;
}
refPtr->refCount--;
if (refPtr->refCount == 0) {
/*
* Must remove information from the slot before calling freeProc
* to avoid reentrancy problems if the freeProc calls Tcl_Preserve
* on the same clientData. Copy down the last reference in the
* array to overwrite the current slot.
*/
freeProc = refPtr->freeProc;
mustFree = refPtr->mustFree;
inUse--;
if (i < inUse) {
refArray[i] = refArray[inUse];
}
if (mustFree) {
if (freeProc == TCL_DYNAMIC) {
ckfree((char *) clientData);
} else {
Tcl_MutexUnlock(&preserveMutex);
(*freeProc)((char *) clientData);
return;
}
}
}
Tcl_MutexUnlock(&preserveMutex);
return;
}
Tcl_MutexUnlock(&preserveMutex);
/*
* Reference not found. This is a bug in the caller.
*/
panic("Tcl_Release couldn't find reference for 0x%x", clientData);
}
/*
*----------------------------------------------------------------------
*
* Tcl_EventuallyFree --
*
* Free up a block of memory, unless a call to Tcl_Preserve is in
* effect for that block. In this case, defer the free until all
* calls to Tcl_Preserve have been undone by matching calls to
* Tcl_Release.
*
* Results:
* None.
*
* Side effects:
* Ptr may be released by calling free().
*
*----------------------------------------------------------------------
*/
void
Tcl_EventuallyFree(clientData, freeProc)
ClientData clientData; /* Pointer to malloc'ed block of memory. */
Tcl_FreeProc *freeProc; /* Procedure to actually do free. */
{
Reference *refPtr;
int i;
/*
* See if there is a reference for this pointer. If so, set its
* "mustFree" flag (the flag had better not be set already!).
*/
Tcl_MutexLock(&preserveMutex);
for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
if (refPtr->clientData != clientData) {
continue;
}
if (refPtr->mustFree) {
panic("Tcl_EventuallyFree called twice for 0x%x\n", clientData);
}
refPtr->mustFree = 1;
refPtr->freeProc = freeProc;
Tcl_MutexUnlock(&preserveMutex);
return;
}
Tcl_MutexUnlock(&preserveMutex);
/*
* No reference for this block. Free it now.
*/
if (freeProc == TCL_DYNAMIC) {
ckfree((char *) clientData);
} else {
(*freeProc)((char *)clientData);
}
}
/*
*---------------------------------------------------------------------------
*
* TclHandleCreate --
*
* Allocate a handle that contains enough information to determine
* if an arbitrary malloc'd block has been deleted. This is
* used to avoid the more time-expensive algorithm of Tcl_Preserve().
*
* Results:
* The return value is a TclHandle that refers to the given malloc'd
* block. Doubly dereferencing the returned handle will give
* back the pointer to the block, or will give NULL if the block has
* been deleted.
*
* Side effects:
* The caller must keep track of this handle (generally by storing
* it in a field in the malloc'd block) and call TclHandleFree()
* on this handle when the block is deleted. Everything else that
* wishes to keep track of whether the malloc'd block has been deleted
* should use calls to TclHandlePreserve() and TclHandleRelease()
* on the associated handle.
*
*---------------------------------------------------------------------------
*/
TclHandle
TclHandleCreate(ptr)
VOID *ptr; /* Pointer to an arbitrary block of memory
* to be tracked for deletion. Must not be
* NULL. */
{
HandleStruct *handlePtr;
handlePtr = (HandleStruct *) ckalloc(sizeof(HandleStruct));
handlePtr->ptr = ptr;
#ifdef TCL_MEM_DEBUG
handlePtr->ptr2 = ptr;
#endif
handlePtr->refCount = 0;
return (TclHandle) handlePtr;
}
/*
*---------------------------------------------------------------------------
*
* TclHandleFree --
*
* Called when the arbitrary malloc'd block associated with the
* handle is being deleted. Modifies the handle so that doubly
* dereferencing it will give NULL. This informs any user of the
* handle that the block of memory formerly referenced by the
* handle has been freed.
*
* Results:
* None.
*
* Side effects:
* If nothing is referring to the handle, the handle will be reclaimed.
*
*---------------------------------------------------------------------------
*/
void
TclHandleFree(handle)
TclHandle handle; /* Previously created handle associated
* with a malloc'd block that is being
* deleted. The handle is modified so that
* doubly dereferencing it will give NULL. */
{
HandleStruct *handlePtr;
handlePtr = (HandleStruct *) handle;
#ifdef TCL_MEM_DEBUG
if (handlePtr->refCount == 0x61616161) {
panic("using previously disposed TclHandle %x", handlePtr);
}
if (handlePtr->ptr2 != handlePtr->ptr) {
panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
handlePtr->ptr = NULL;
if (handlePtr->refCount == 0) {
ckfree((char *) handlePtr);
}
}
/*
*---------------------------------------------------------------------------
*
* TclHandlePreserve --
*
* Declare an interest in the arbitrary malloc'd block associated
* with the handle.
*
* Results:
* The return value is the handle argument, with its ref count
* incremented.
*
* Side effects:
* For each call to TclHandlePreserve(), there should be a matching
* call to TclHandleRelease() when the caller is no longer interested
* in the malloc'd block associated with the handle.
*
*---------------------------------------------------------------------------
*/
TclHandle
TclHandlePreserve(handle)
TclHandle handle; /* Declare an interest in the block of
* memory referenced by this handle. */
{
HandleStruct *handlePtr;
handlePtr = (HandleStruct *) handle;
#ifdef TCL_MEM_DEBUG
if (handlePtr->refCount == 0x61616161) {
panic("using previously disposed TclHandle %x", handlePtr);
}
if ((handlePtr->ptr != NULL)
&& (handlePtr->ptr != handlePtr->ptr2)) {
panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
handlePtr->refCount++;
return handle;
}
/*
*---------------------------------------------------------------------------
*
* TclHandleRelease --
*
* This procedure is called to release an interest in the malloc'd
* block associated with the handle.
*
* Results:
* None.
*
* Side effects:
* The ref count of the handle is decremented. If the malloc'd block
* has been freed and if no one is using the handle any more, the
* handle will be reclaimed.
*
*---------------------------------------------------------------------------
*/
void
TclHandleRelease(handle)
TclHandle handle; /* Unregister interest in the block of
* memory referenced by this handle. */
{
HandleStruct *handlePtr;
handlePtr = (HandleStruct *) handle;
#ifdef TCL_MEM_DEBUG
if (handlePtr->refCount == 0x61616161) {
panic("using previously disposed TclHandle %x", handlePtr);
}
if ((handlePtr->ptr != NULL)
&& (handlePtr->ptr != handlePtr->ptr2)) {
panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
handlePtr->refCount--;
if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) {
ckfree((char *) handlePtr);
}
}
tcl8.4.20/generic/tclCompExpr.c 0000644 0036047 0045461 00000066760 12052456743 014754 0 ustar dgp 771div /*
* tclCompExpr.c --
*
* This file contains the code to compile Tcl expressions.
*
* Copyright (c) 1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
* The stuff below is a bit of a hack so that this file can be used in
* environments that include no UNIX, i.e. no errno: just arrange to use
* the errno from tclExecute.c here.
*/
#ifndef TCL_GENERIC_ONLY
#include "tclPort.h"
#else
#define NO_ERRNO_H
#endif
#ifdef NO_ERRNO_H
extern int errno; /* Use errno from tclExecute.c. */
#define ERANGE 34
#endif
/*
* Boolean variable that controls whether expression compilation tracing
* is enabled.
*/
#ifdef TCL_COMPILE_DEBUG
static int traceExprComp = 0;
#endif /* TCL_COMPILE_DEBUG */
/*
* The ExprInfo structure describes the state of compiling an expression.
* A pointer to an ExprInfo record is passed among the routines in
* this module.
*/
typedef struct ExprInfo {
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Structure filled with information about
* the parsed expression. */
CONST char *expr; /* The expression that was originally passed
* to TclCompileExpr. */
CONST char *lastChar; /* Points just after last byte of expr. */
int hasOperators; /* Set 1 if the expr has operators; 0 if
* expr is only a primary. If 1 after
* compiling an expr, a tryCvtToNumeric
* instruction is emitted to convert the
* primary to a number if possible. */
} ExprInfo;
/*
* Definitions of numeric codes representing each expression operator.
* The order of these must match the entries in the operatorTable below.
* Also the codes for the relational operators (OP_LESS, OP_GREATER,
* OP_LE, OP_GE, OP_EQ, and OP_NE) must be consecutive and in that order.
* Note that OP_PLUS and OP_MINUS represent both unary and binary operators.
*/
#define OP_MULT 0
#define OP_DIVIDE 1
#define OP_MOD 2
#define OP_PLUS 3
#define OP_MINUS 4
#define OP_LSHIFT 5
#define OP_RSHIFT 6
#define OP_LESS 7
#define OP_GREATER 8
#define OP_LE 9
#define OP_GE 10
#define OP_EQ 11
#define OP_NEQ 12
#define OP_BITAND 13
#define OP_BITXOR 14
#define OP_BITOR 15
#define OP_LAND 16
#define OP_LOR 17
#define OP_QUESTY 18
#define OP_LNOT 19
#define OP_BITNOT 20
#define OP_STREQ 21
#define OP_STRNEQ 22
/*
* Table describing the expression operators. Entries in this table must
* correspond to the definitions of numeric codes for operators just above.
*/
static int opTableInitialized = 0; /* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(opMutex)
typedef struct OperatorDesc {
CONST char *name; /* Name of the operator. */
int numOperands; /* Number of operands. 0 if the operator
* requires special handling. */
int instruction; /* Instruction opcode for the operator.
* Ignored if numOperands is 0. */
} OperatorDesc;
static CONST OperatorDesc operatorTable[] = {
{"*", 2, INST_MULT},
{"/", 2, INST_DIV},
{"%", 2, INST_MOD},
{"+", 0, 0},
{"-", 0, 0},
{"<<", 2, INST_LSHIFT},
{">>", 2, INST_RSHIFT},
{"<", 2, INST_LT},
{">", 2, INST_GT},
{"<=", 2, INST_LE},
{">=", 2, INST_GE},
{"==", 2, INST_EQ},
{"!=", 2, INST_NEQ},
{"&", 2, INST_BITAND},
{"^", 2, INST_BITXOR},
{"|", 2, INST_BITOR},
{"&&", 0, 0},
{"||", 0, 0},
{"?", 0, 0},
{"!", 1, INST_LNOT},
{"~", 1, INST_BITNOT},
{"eq", 2, INST_STR_EQ},
{"ne", 2, INST_STR_NEQ},
{NULL, 0, 0}
};
/*
* Hashtable used to map the names of expression operators to the index
* of their OperatorDesc description.
*/
static Tcl_HashTable opHashTable;
/*
* Declarations for local procedures to this file:
*/
static int CompileCondExpr _ANSI_ARGS_((
Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
CompileEnv *envPtr, Tcl_Token **endPtrPtr));
static int CompileLandOrLorExpr _ANSI_ARGS_((
Tcl_Token *exprTokenPtr, int opIndex,
ExprInfo *infoPtr, CompileEnv *envPtr,
Tcl_Token **endPtrPtr));
static int CompileMathFuncCall _ANSI_ARGS_((
Tcl_Token *exprTokenPtr, CONST char *funcName,
ExprInfo *infoPtr, CompileEnv *envPtr,
Tcl_Token **endPtrPtr));
static int CompileSubExpr _ANSI_ARGS_((
Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
CompileEnv *envPtr));
static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr));
/*
* Macro used to debug the execution of the expression compiler.
*/
#ifdef TCL_COMPILE_DEBUG
#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \
if (traceExprComp) { \
fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \
(exprLength), (exprBytes), (tokenLength), (tokenBytes)); \
}
#else
#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength)
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* TclCompileExpr --
*
* This procedure compiles a string containing a Tcl expression into
* Tcl bytecodes. This procedure is the top-level interface to the
* the expression compilation module, and is used by such public
* procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong,
* Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj.
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* Adds instructions to envPtr to evaluate the expression at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileExpr(interp, script, numBytes, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
CONST char *script; /* The source script to compile. */
int numBytes; /* Number of bytes in script. If < 0, the
* string consists of all bytes up to the
* first null character. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
ExprInfo info;
Tcl_Parse parse;
Tcl_HashEntry *hPtr;
int new, i, code;
/*
* If this is the first time we've been called, initialize the table
* of expression operators.
*/
if (numBytes < 0) {
numBytes = (script? strlen(script) : 0);
}
if (!opTableInitialized) {
Tcl_MutexLock(&opMutex);
if (!opTableInitialized) {
Tcl_InitHashTable(&opHashTable, TCL_STRING_KEYS);
for (i = 0; operatorTable[i].name != NULL; i++) {
hPtr = Tcl_CreateHashEntry(&opHashTable,
operatorTable[i].name, &new);
if (new) {
Tcl_SetHashValue(hPtr, (ClientData) i);
}
}
opTableInitialized = 1;
}
Tcl_MutexUnlock(&opMutex);
}
/*
* Initialize the structure containing information abvout this
* expression compilation.
*/
info.interp = interp;
info.parsePtr = &parse;
info.expr = script;
info.lastChar = (script + numBytes);
info.hasOperators = 0;
/*
* Parse the expression then compile it.
*/
code = Tcl_ParseExpr(interp, script, numBytes, &parse);
if (code != TCL_OK) {
goto done;
}
#ifdef TCL_TIP280
/* TIP #280 : Track Lines within the expression */
TclAdvanceLines (&envPtr->line, script, parse.tokenPtr->start);
#endif
code = CompileSubExpr(parse.tokenPtr, &info, envPtr);
if (code != TCL_OK) {
Tcl_FreeParse(&parse);
goto done;
}
if (!info.hasOperators) {
/*
* Attempt to convert the primary's object to an int or double.
* This is done in order to support Tcl's policy of interpreting
* operands if at all possible as first integers, else
* floating-point numbers.
*/
TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
}
Tcl_FreeParse(&parse);
done:
return code;
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeCompilation --
*
* Clean up the compilation environment so it can later be
* properly reinitialized. This procedure is called by Tcl_Finalize().
*
* Results:
* None.
*
* Side effects:
* Cleans up the compilation environment. At the moment, just the
* table of expression operators is freed.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeCompilation()
{
Tcl_MutexLock(&opMutex);
if (opTableInitialized) {
Tcl_DeleteHashTable(&opHashTable);
opTableInitialized = 0;
}
Tcl_MutexUnlock(&opMutex);
}
/*
*----------------------------------------------------------------------
*
* CompileSubExpr --
*
* Given a pointer to a TCL_TOKEN_SUB_EXPR token describing a
* subexpression, this procedure emits instructions to evaluate the
* subexpression at runtime.
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* Adds instructions to envPtr to evaluate the subexpression.
*
*----------------------------------------------------------------------
*/
static int
CompileSubExpr(exprTokenPtr, infoPtr, envPtr)
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* to compile. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Interp *interp = infoPtr->interp;
Tcl_Token *tokenPtr, *endPtr = NULL; /* silence gcc 4 warning */
Tcl_Token *afterSubexprPtr;
CONST OperatorDesc *opDescPtr;
Tcl_HashEntry *hPtr;
CONST char *operator;
Tcl_DString opBuf;
int objIndex, opIndex, length, code;
char buffer[TCL_UTF_MAX];
if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) {
panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n",
exprTokenPtr->type);
}
code = TCL_OK;
/*
* Switch on the type of the first token after the subexpression token.
* After processing it, advance tokenPtr to point just after the
* subexpression's last token.
*/
tokenPtr = exprTokenPtr+1;
TRACE(exprTokenPtr->start, exprTokenPtr->size,
tokenPtr->start, tokenPtr->size);
switch (tokenPtr->type) {
case TCL_TOKEN_WORD:
code = TclCompileTokens(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
break;
case TCL_TOKEN_TEXT:
if (tokenPtr->size > 0) {
objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start,
tokenPtr->size);
} else {
objIndex = TclRegisterNewLiteral(envPtr, "", 0);
}
TclEmitPush(objIndex, envPtr);
tokenPtr += 1;
break;
case TCL_TOKEN_BS:
length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
(int *) NULL, buffer);
if (length > 0) {
objIndex = TclRegisterNewLiteral(envPtr, buffer, length);
} else {
objIndex = TclRegisterNewLiteral(envPtr, "", 0);
}
TclEmitPush(objIndex, envPtr);
tokenPtr += 1;
break;
case TCL_TOKEN_COMMAND:
code = TclCompileScript(interp, tokenPtr->start+1,
tokenPtr->size-2, /*nested*/ 0, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += 1;
break;
case TCL_TOKEN_VARIABLE:
code = TclCompileTokens(interp, tokenPtr, 1, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
break;
case TCL_TOKEN_SUB_EXPR:
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
break;
case TCL_TOKEN_OPERATOR:
/*
* Look up the operator. If the operator isn't found, treat it
* as a math function.
*/
Tcl_DStringInit(&opBuf);
operator = Tcl_DStringAppend(&opBuf,
tokenPtr->start, tokenPtr->size);
hPtr = Tcl_FindHashEntry(&opHashTable, operator);
if (hPtr == NULL) {
code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr,
envPtr, &endPtr);
Tcl_DStringFree(&opBuf);
if (code != TCL_OK) {
goto done;
}
tokenPtr = endPtr;
break;
}
Tcl_DStringFree(&opBuf);
opIndex = (int) Tcl_GetHashValue(hPtr);
opDescPtr = &(operatorTable[opIndex]);
/*
* If the operator is "normal", compile it using information
* from the operator table.
*/
if (opDescPtr->numOperands > 0) {
tokenPtr++;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
if (opDescPtr->numOperands == 2) {
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
}
TclEmitOpcode(opDescPtr->instruction, envPtr);
infoPtr->hasOperators = 1;
break;
}
/*
* The operator requires special treatment, and is either
* "+" or "-", or one of "&&", "||" or "?".
*/
switch (opIndex) {
case OP_PLUS:
case OP_MINUS:
tokenPtr++;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
/*
* Check whether the "+" or "-" is unary.
*/
afterSubexprPtr = exprTokenPtr
+ exprTokenPtr->numComponents+1;
if (tokenPtr == afterSubexprPtr) {
TclEmitOpcode(((opIndex==OP_PLUS)?
INST_UPLUS : INST_UMINUS),
envPtr);
break;
}
/*
* The "+" or "-" is binary.
*/
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB),
envPtr);
break;
case OP_LAND:
case OP_LOR:
code = CompileLandOrLorExpr(exprTokenPtr, opIndex,
infoPtr, envPtr, &endPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr = endPtr;
break;
case OP_QUESTY:
code = CompileCondExpr(exprTokenPtr, infoPtr,
envPtr, &endPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr = endPtr;
break;
default:
panic("CompileSubExpr: unexpected operator %d requiring special treatment\n",
opIndex);
} /* end switch on operator requiring special treatment */
infoPtr->hasOperators = 1;
break;
default:
panic("CompileSubExpr: unexpected token type %d\n",
tokenPtr->type);
}
/*
* Verify that the subexpression token had the required number of
* subtokens: that we've advanced tokenPtr just beyond the
* subexpression's last token. For example, a "*" subexpression must
* contain the tokens for exactly two operands.
*/
if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) {
LogSyntaxError(infoPtr);
code = TCL_ERROR;
}
done:
return code;
}
/*
*----------------------------------------------------------------------
*
* CompileLandOrLorExpr --
*
* This procedure compiles a Tcl logical and ("&&") or logical or
* ("||") subexpression.
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_OK is returned, a pointer to the token just after
* the last one in the subexpression is stored at the address in
* endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* Adds instructions to envPtr to evaluate the expression at runtime.
*
*----------------------------------------------------------------------
*/
static int
CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr)
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* containing the "&&" or "||" operator. */
int opIndex; /* A code describing the expression
* operator: either OP_LAND or OP_LOR. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
Tcl_Token **endPtrPtr; /* If successful, a pointer to the token
* just after the last token in the
* subexpression is stored here. */
{
JumpFixup shortCircuitFixup; /* Used to fix up the short circuit jump
* after the first subexpression. */
JumpFixup lhsTrueFixup, lhsEndFixup;
/* Used to fix up jumps used to convert the
* first operand to 0 or 1. */
Tcl_Token *tokenPtr;
int dist, code;
int savedStackDepth = envPtr->currStackDepth;
/*
* Emit code for the first operand.
*/
tokenPtr = exprTokenPtr+2;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
/*
* Convert the first operand to the result that Tcl requires:
* "0" or "1". Eventually we'll use a new instruction for this.
*/
TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup);
TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup);
dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) {
badDist:
panic("CompileLandOrLorExpr: bad jump distance %d\n", dist);
}
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) {
goto badDist;
}
/*
* Emit the "short circuit" jump around the rest of the expression.
* Duplicate the "0" or "1" on top of the stack first to keep the
* jump from consuming it.
*/
TclEmitOpcode(INST_DUP, envPtr);
TclEmitForwardJump(envPtr,
((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP),
&shortCircuitFixup);
/*
* Emit code for the second operand.
*/
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
/*
* Emit a "logical and" or "logical or" instruction. This does not try
* to "short- circuit" the evaluation of both operands, but instead
* ensures that we either have a "1" or a "0" result.
*/
TclEmitOpcode(((opIndex==OP_LAND)? INST_LAND : INST_LOR), envPtr);
/*
* Now that we know the target of the forward jump, update it with the
* correct distance.
*/
dist = (envPtr->codeNext - envPtr->codeStart)
- shortCircuitFixup.codeOffset;
TclFixupForwardJump(envPtr, &shortCircuitFixup, dist, 127);
*endPtrPtr = tokenPtr;
done:
envPtr->currStackDepth = savedStackDepth + 1;
return code;
}
/*
*----------------------------------------------------------------------
*
* CompileCondExpr --
*
* This procedure compiles a Tcl conditional expression:
* condExpr ::= lorExpr ['?' condExpr ':' condExpr]
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_OK is returned, a pointer to the token just after
* the last one in the subexpression is stored at the address in
* endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* Adds instructions to envPtr to evaluate the expression at runtime.
*
*----------------------------------------------------------------------
*/
static int
CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr)
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* containing the "?" operator. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
Tcl_Token **endPtrPtr; /* If successful, a pointer to the token
* just after the last token in the
* subexpression is stored here. */
{
JumpFixup jumpAroundThenFixup, jumpAroundElseFixup;
/* Used to update or replace one-byte jumps
* around the then and else expressions when
* their target PCs are determined. */
Tcl_Token *tokenPtr;
int elseCodeOffset, dist, code;
int savedStackDepth = envPtr->currStackDepth;
/*
* Emit code for the test.
*/
tokenPtr = exprTokenPtr+2;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
/*
* Emit the jump to the "else" expression if the test was false.
*/
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup);
/*
* Compile the "then" expression. Note that if a subexpression is only
* a primary, we need to try to convert it to numeric. We do this to
* support Tcl's policy of interpreting operands if at all possible as
* first integers, else floating-point numbers.
*/
infoPtr->hasOperators = 0;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
if (!infoPtr->hasOperators) {
TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
}
/*
* Emit an unconditional jump around the "else" condExpr.
*/
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
&jumpAroundElseFixup);
/*
* Compile the "else" expression.
*/
envPtr->currStackDepth = savedStackDepth;
elseCodeOffset = (envPtr->codeNext - envPtr->codeStart);
infoPtr->hasOperators = 0;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
if (!infoPtr->hasOperators) {
TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
}
/*
* Fix up the second jump around the "else" expression.
*/
dist = (envPtr->codeNext - envPtr->codeStart)
- jumpAroundElseFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) {
/*
* Update the else expression's starting code offset since it
* moved down 3 bytes too.
*/
elseCodeOffset += 3;
}
/*
* Fix up the first jump to the "else" expression if the test was false.
*/
dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset);
TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127);
*endPtrPtr = tokenPtr;
done:
envPtr->currStackDepth = savedStackDepth + 1;
return code;
}
/*
*----------------------------------------------------------------------
*
* CompileMathFuncCall --
*
* This procedure compiles a call on a math function in an expression:
* mathFuncCall ::= funcName '(' [condExpr {',' condExpr}] ')'
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_OK is returned, a pointer to the token just after
* the last one in the subexpression is stored at the address in
* endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* Adds instructions to envPtr to evaluate the math function at
* runtime.
*
*----------------------------------------------------------------------
*/
static int
CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* containing the math function call. */
CONST char *funcName; /* Name of the math function. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
Tcl_Token **endPtrPtr; /* If successful, a pointer to the token
* just after the last token in the
* subexpression is stored here. */
{
Tcl_Interp *interp = infoPtr->interp;
Interp *iPtr = (Interp *) interp;
MathFunc *mathFuncPtr;
Tcl_HashEntry *hPtr;
Tcl_Token *tokenPtr, *afterSubexprPtr;
int code, i;
/*
* Look up the MathFunc record for the function.
*/
code = TCL_OK;
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
if (hPtr == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown math function \"", funcName, "\"", (char *) NULL);
code = TCL_ERROR;
goto done;
}
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
/*
* If not a builtin function, push an object with the function's name.
*/
if (mathFuncPtr->builtinFuncIndex < 0) {
TclEmitPush(TclRegisterNewLiteral(envPtr, funcName, -1), envPtr);
}
/*
* Compile any arguments for the function.
*/
tokenPtr = exprTokenPtr+2;
afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1);
if (mathFuncPtr->numArgs > 0) {
for (i = 0; i < mathFuncPtr->numArgs; i++) {
if (tokenPtr == afterSubexprPtr) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"too few arguments for math function", -1);
code = TCL_ERROR;
goto done;
}
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
}
if (tokenPtr != afterSubexprPtr) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"too many arguments for math function", -1);
code = TCL_ERROR;
goto done;
}
} else if (tokenPtr != afterSubexprPtr) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"too many arguments for math function", -1);
code = TCL_ERROR;
goto done;
}
/*
* Compile the call on the math function. Note that the "objc" argument
* count for non-builtin functions is incremented by 1 to include the
* function name itself.
*/
if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */
/*
* Adjust the current stack depth by the number of arguments
* of the builtin function. This cannot be handled by the
* TclEmitInstInt1 macro as the number of arguments is not
* passed as an operand.
*/
if (envPtr->maxStackDepth < envPtr->currStackDepth) {
envPtr->maxStackDepth = envPtr->currStackDepth;
}
TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1,
mathFuncPtr->builtinFuncIndex, envPtr);
envPtr->currStackDepth -= mathFuncPtr->numArgs;
} else {
TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
}
*endPtrPtr = afterSubexprPtr;
done:
return code;
}
/*
*----------------------------------------------------------------------
*
* LogSyntaxError --
*
* This procedure is invoked after an error occurs when compiling an
* expression. It sets the interpreter result to an error message
* describing the error.
*
* Results:
* None.
*
* Side effects:
* Sets the interpreter result to an error message describing the
* expression that was being compiled when the error occurred.
*
*----------------------------------------------------------------------
*/
static void
LogSyntaxError(infoPtr)
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
{
int numBytes = (infoPtr->lastChar - infoPtr->expr);
char buffer[100];
sprintf(buffer, "syntax error in expression \"%.*s\"",
((numBytes > 60)? 60 : numBytes), infoPtr->expr);
Tcl_ResetResult(infoPtr->interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
buffer, (char *) NULL);
}
tcl8.4.20/generic/tclIO.h 0000644 0036047 0045461 00000030673 12133546540 013520 0 ustar dgp 771div /*
* tclIO.h --
*
* This file provides the generic portions (those that are the same on
* all platforms and for all channel types) of Tcl's IO facilities.
*
* Copyright (c) 1998-2000 Ajuba Solutions
* Copyright (c) 1995-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.
*/
/*
* Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not
* compile on systems where neither is defined. We want both defined so
* that we can test safely for both. In the code we still have to test for
* both because there may be systems on which both are defined and have
* different values.
*/
#if ((!defined(EWOULDBLOCK)) && (defined(EAGAIN)))
# define EWOULDBLOCK EAGAIN
#endif
#if ((!defined(EAGAIN)) && (defined(EWOULDBLOCK)))
# define EAGAIN EWOULDBLOCK
#endif
#if ((!defined(EAGAIN)) && (!defined(EWOULDBLOCK)))
error one of EWOULDBLOCK or EAGAIN must be defined
#endif
/*
* struct ChannelBuffer:
*
* Buffers data being sent to or from a channel.
*/
typedef struct ChannelBuffer {
int nextAdded; /* The next position into which a character
* will be put in the buffer. */
int nextRemoved; /* Position of next byte to be removed
* from the buffer. */
int bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
char buf[4]; /* Placeholder for real buffer. The real
* buffer occuppies this space + bufSize-4
* bytes. This must be the last field in
* the structure. */
} ChannelBuffer;
#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4)
/*
* How much extra space to allocate in buffer to hold bytes from previous
* buffer (when converting to UTF-8) or to hold bytes that will go to
* next buffer (when converting from UTF-8).
*/
#define BUFFER_PADDING 16
/*
* The following defines the *default* buffer size for channels.
*/
#define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4)
/*
* The following structure describes the information saved from a call to
* "fileevent". This is used later when the event being waited for to
* invoke the saved script in the interpreter designed in this record.
*/
typedef struct EventScriptRecord {
struct Channel *chanPtr; /* The channel for which this script is
* registered. This is used only when an
* error occurs during evaluation of the
* script, to delete the handler. */
Tcl_Obj *scriptPtr; /* Script to invoke. */
Tcl_Interp *interp; /* In what interpreter to invoke script? */
int mask; /* Events must overlap current mask for the
* stored script to be invoked. */
struct EventScriptRecord *nextPtr;
/* Next in chain of records. */
} EventScriptRecord;
/*
* struct Channel:
*
* One of these structures is allocated for each open channel. It contains data
* specific to the channel but which belongs to the generic part of the Tcl
* channel mechanism, and it points at an instance specific (and type
* specific) * instance data, and at a channel type structure.
*/
typedef struct Channel {
struct ChannelState *state; /* Split out state information */
ClientData instanceData; /* Instance-specific data provided by
* creator of channel. */
Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
struct Channel *downChanPtr;/* Refers to channel this one was stacked
* upon. This reference is NULL for normal
* channels. See Tcl_StackChannel. */
struct Channel *upChanPtr; /* Refers to the channel above stacked this
* one. NULL for the top most channel. */
/*
* Intermediate buffers to hold pre-read data for consumption by a
* newly stacked transformation. See 'Tcl_StackChannel'.
*/
ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */
ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */
} Channel;
/*
* struct ChannelState:
*
* One of these structures is allocated for each open channel. It contains data
* specific to the channel but which belongs to the generic part of the Tcl
* channel mechanism, and it points at an instance specific (and type
* specific) * instance data, and at a channel type structure.
*/
typedef struct ChannelState {
CONST char *channelName; /* The name of the channel instance in Tcl
* commands. Storage is owned by the generic IO
* code, is dynamically allocated. */
int flags; /* ORed combination of the flags defined
* below. */
Tcl_Encoding encoding; /* Encoding to apply when reading or writing
* data on this channel. NULL means no
* encoding is applied to data. */
Tcl_EncodingState inputEncodingState;
/* Current encoding state, used when converting
* input data bytes to UTF-8. */
int inputEncodingFlags; /* Encoding flags to pass to conversion
* routine when converting input data bytes to
* UTF-8. May be TCL_ENCODING_START before
* converting first byte and TCL_ENCODING_END
* when EOF is seen. */
Tcl_EncodingState outputEncodingState;
/* Current encoding state, used when converting
* UTF-8 to output data bytes. */
int outputEncodingFlags; /* Encoding flags to pass to conversion
* routine when converting UTF-8 to output
* data bytes. May be TCL_ENCODING_START
* before converting first byte and
* TCL_ENCODING_END when EOF is seen. */
TclEolTranslation inputTranslation;
/* What translation to apply for end of line
* sequences on input? */
TclEolTranslation outputTranslation;
/* What translation to use for generating
* end of line sequences in output? */
int inEofChar; /* If nonzero, use this as a signal of EOF
* on input. */
int outEofChar; /* If nonzero, append this to the channel
* when it is closed if it is open for
* writing. */
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
int refCount; /* How many interpreters hold references to
* this IO channel? */
struct CloseCallback *closeCbPtr;
/* Callbacks registered to be called when the
* channel is closed. */
char *outputStage; /* Temporary staging buffer used when
* translating EOL before converting from
* UTF-8 to external form. */
ChannelBuffer *curOutPtr; /* Current output buffer being filled. */
ChannelBuffer *outQueueHead;/* Points at first buffer in output queue. */
ChannelBuffer *outQueueTail;/* Points at last buffer in output queue. */
ChannelBuffer *saveInBufPtr;/* Buffer saved for input queue - eliminates
* need to allocate a new buffer for "gets"
* that crosses buffer boundaries. */
ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */
ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */
struct ChannelHandler *chPtr;/* List of channel handlers registered
* for this channel. */
int interestMask; /* Mask of all events this channel has
* handlers for. */
EventScriptRecord *scriptRecordPtr;
/* Chain of all scripts registered for
* event handlers ("fileevent") on this
* channel. */
int bufSize; /* What size buffers to allocate? */
Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */
struct CopyState *csPtrR; /* State of background copy for which channel
* is input, or NULL. */
struct CopyState *csPtrW; /* State of background copy for which channel
* is output, or NULL. */
Channel *topChanPtr; /* Refers to topmost channel in a stack.
* Never NULL. */
Channel *bottomChanPtr; /* Refers to bottommost channel in a stack.
* This channel can be relied on to live as
* long as the channel state. Never NULL. */
struct ChannelState *nextCSPtr;
/* Next in list of channels currently open. */
Tcl_ThreadId managingThread; /* TIP #10: Id of the thread managing
* this stack of channels. */
} ChannelState;
/*
* Values for the flags field in Channel. Any ORed combination of the
* following flags can be stored in the field. These flags record various
* options and state bits about the channel. In addition to the flags below,
* the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set.
*/
#define CHANNEL_NONBLOCKING (1<<3) /* Channel is currently in
* nonblocking mode. */
#define CHANNEL_LINEBUFFERED (1<<4) /* Output to the channel must be
* flushed after every newline. */
#define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always
* be flushed immediately. */
#define BUFFER_READY (1<<6) /* Current output buffer (the
* curOutPtr field in the
* channel structure) should be
* output as soon as possible even
* though it may not be full. */
#define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the
* queued output buffers has been
* scheduled. */
#define CHANNEL_CLOSED (1<<8) /* Channel has been closed. No
* further Tcl-level IO on the
* channel is allowed. */
#define CHANNEL_EOF (1<<9) /* EOF occurred on this channel.
* This bit is cleared before every
* input operation. */
#define CHANNEL_STICKY_EOF (1<<10) /* EOF occurred on this channel because
* we saw the input eofChar. This bit
* prevents clearing of the EOF bit
* before every input operation. */
#define CHANNEL_BLOCKED (1<<11) /* EWOULDBLOCK or EAGAIN occurred
* on this channel. This bit is
* cleared before every input or
* output operation. */
#define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input
* translation mode and the last
* byte seen was a "\r". */
#define INPUT_NEED_NL (1<<15) /* Saw a '\r' at end of last buffer,
* and there should be a '\n' at
* beginning of next buffer. */
#define CHANNEL_DEAD (1<<13) /* The channel has been closed by
* the exit handler (on exit) but
* not deallocated. When any IO
* operation sees this flag on a
* channel, it does not call driver
* level functions to avoid referring
* to deallocated data. */
#define CHANNEL_NEED_MORE_DATA (1<<14) /* The last input operation failed
* because there was not enough data
* to complete the operation. This
* flag is set when gets fails to
* get a complete line or when read
* fails to get a complete character.
* When set, file events will not be
* delivered for buffered data until
* the state of the channel changes. */
#define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is
* being used. */
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
#define CHANNEL_TIMER_FEV (1<<17) /* When set the event we are
* notified by is a fileevent
* generated by a timer. We
* don't know if the driver
* has more data and should
* not try to read from it. If
* the system needs more than
* is in the buffers out read
* routines will simulate a
* short read (0 characters
* read) */
#define CHANNEL_HAS_MORE_DATA (1<<18) /* Set by NotifyChannel for a
* channel if and only if the
* channel is configured
* non-blocking, the driver
* for said channel has no
* blockmodeproc, and data has
* arrived for reading at the
* OS level). A GetInput will
* pass reading from the
* driver if the channel is
* non-blocking, without
* blockmode proc and the flag
* has not been set. A read
* will be performed if the
* flag is set. This will
* reset the flag as well. */
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
#define CHANNEL_INCLOSE (1<<19) /* Channel is currently being
* closed. Its structures are
* still live and usable, but
* it may not be closed again
* from within the close handler.
*/
tcl8.4.20/generic/tclTestObj.c 0000644 0036047 0045461 00000107544 12133546540 014560 0 ustar dgp 771div /*
* tclTestObj.c --
*
* This file contains C command procedures for the additional Tcl
* commands that are used for testing implementations of the Tcl object
* types. These commands are not normally included in Tcl
* applications; they're only used for testing.
*
* Copyright (c) 1995-1998 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* An array of Tcl_Obj pointers used in the commands that operate on or get
* the values of Tcl object-valued variables. varPtr[i] is the i-th
* variable's Tcl_Obj *.
*/
#define NUMBER_OF_OBJECT_VARS 20
static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS];
/*
* Forward declarations for procedures defined later in this file:
*/
static int CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp,
int varIndex));
static int GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int *indexPtr));
static void SetVarToObj _ANSI_ARGS_((int varIndex,
Tcl_Obj *objPtr));
int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
static int TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestconvertobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestindexobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestintobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TeststringobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
typedef struct TestString {
int numChars;
size_t allocated;
size_t uallocated;
Tcl_UniChar unicode[2];
} TestString;
/*
*----------------------------------------------------------------------
*
* TclObjTest_Init --
*
* This procedure creates additional commands that are used to test the
* Tcl object support.
*
* Results:
* Returns a standard Tcl completion code, and leaves an error
* message in the interp's result if an error occurs.
*
* Side effects:
* Creates and registers several new testing commands.
*
*----------------------------------------------------------------------
*/
int
TclObjTest_Init(interp)
Tcl_Interp *interp;
{
register int i;
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
varPtr[i] = NULL;
}
Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testobj", TestobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestbooleanobjCmd --
*
* This procedure implements the "testbooleanobj" command. It is used
* to test the boolean Tcl object type implementation.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* Creates and frees boolean objects, and also converts objects to
* have boolean type.
*
*----------------------------------------------------------------------
*/
static int
TestbooleanobjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int varIndex, boolValue;
char *index, *subCmd;
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) {
return TCL_ERROR;
}
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared),
* we must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
} else {
SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "not") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
&boolValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
} else {
SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, or not", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestconvertobjCmd --
*
* This procedure implements the "testconvertobj" command. It is used
* to test converting objects to new types.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* Converts objects to new types.
*
*----------------------------------------------------------------------
*/
static int
TestconvertobjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *subCmd;
char buf[20];
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "double") == 0) {
double d;
if (objc != 3) {
goto wrongNumArgs;
}
if (Tcl_GetDoubleFromObj(interp, objv[2], &d) != TCL_OK) {
return TCL_ERROR;
}
sprintf(buf, "%f", d);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be double", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestdoubleobjCmd --
*
* This procedure implements the "testdoubleobj" command. It is used
* to test the double-precision floating point Tcl object type
* implementation.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* Creates and frees double objects, and also converts objects to
* have double type.
*
*----------------------------------------------------------------------
*/
static int
TestdoubleobjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int varIndex;
double doubleValue;
char *index, *subCmd, *string;
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {
return TCL_ERROR;
}
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared),
* we must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetDoubleObj(varPtr[varIndex], doubleValue);
} else {
SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "mult10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
&doubleValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0));
} else {
SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) ));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
&doubleValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0));
} else {
SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) ));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, mult10, or div10", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestindexobjCmd --
*
* This procedure implements the "testindexobj" command. It is used to
* test the index Tcl object type implementation.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* Creates and frees int objects, and also converts objects to
* have int type.
*
*----------------------------------------------------------------------
*/
static int
TestindexobjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int allowAbbrev, index, index2, setError, i, result;
CONST char **argv;
static CONST char *tablePtr[] = {"a", "b", "check", (char *) NULL};
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
struct IndexRep {
VOID *tablePtr; /* Pointer to the table of strings */
int offset; /* Offset between table entries */
int index; /* Selected index into table. */
};
struct IndexRep *indexRep;
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
/*
* This code checks to be sure that the results of
* Tcl_GetIndexFromObj are properly cached in the object and
* returned on subsequent lookups.
*/
if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr,
"token", 0, &index);
indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr;
indexRep->index = index2;
result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
if (objc < 5) {
Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
return TCL_ERROR;
}
argv = (CONST char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
/*
* Tcl_GetIndexFromObj assumes that the table is statically-allocated
* so that its address is different for each index object. If we
* accidently allocate a table at the same address as that cached in
* the index object, clear out the object's cached state.
*/
if ( objv[3]->typePtr != NULL
&& !strcmp( "index", objv[3]->typePtr->name ) ) {
indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr;
if (indexRep->tablePtr == (VOID *) argv) {
objv[3]->typePtr->freeIntRepProc(objv[3]);
objv[3]->typePtr = NULL;
}
}
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
ckfree((char *) argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TestintobjCmd --
*
* This procedure implements the "testintobj" command. It is used to
* test the int Tcl object type implementation.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* Creates and frees int objects, and also converts objects to
* have int type.
*
*----------------------------------------------------------------------
*/
static int
TestintobjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int intValue, varIndex, i;
long longValue;
char *index, *subCmd, *string;
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared),
* we must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
}
} else if (strcmp(subCmd, "setlong") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "setmaxlong") == 0) {
long maxLong = LONG_MAX;
if (objc != 3) {
goto wrongNumArgs;
}
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], maxLong);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
}
} else if (strcmp(subCmd, "ismaxlong") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
return TCL_ERROR;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp),
((longValue == LONG_MAX)? "1" : "0"), -1);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get2") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
} else if (strcmp(subCmd, "inttoobigtest") == 0) {
/*
* If long ints have more bits than ints on this platform, verify
* that Tcl_GetIntFromObj returns an error if the long int held
* in an integer object's internal representation is too large
* to fit in an int.
*/
if (objc != 3) {
goto wrongNumArgs;
}
#if (INT_MAX == LONG_MAX) /* int is same size as long int */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
#else
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX));
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
return TCL_OK;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
#endif
} else if (strcmp(subCmd, "mult10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
&intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], (intValue * 10));
} else {
SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) ));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
&intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], (intValue / 10));
} else {
SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) ));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, get2, mult10, or div10",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestobjCmd --
*
* This procedure implements the "testobj" command. It is used to test
* the type-independent portions of the Tcl object type implementation.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* Creates and frees objects.
*
*----------------------------------------------------------------------
*/
static int
TestobjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int varIndex, destIndex, i;
char *index, *subCmd, *string;
Tcl_ObjType *targetType;
if (objc < 2) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "assign") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "bug3598580") == 0) {
Tcl_Obj *listObjPtr, *elemObjPtr;
if (objc != 2) {
goto wrongNumArgs;
}
elemObjPtr = Tcl_NewIntObj(123);
listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
/* Replace the single list element through itself, nonsense but legal. */
Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
} else if (strcmp(subCmd, "convert") == 0) {
char *typeName;
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
typeName = Tcl_GetString(objv[3]);
if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no type ", typeName, " found", (char *) NULL);
return TCL_ERROR;
}
if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
!= TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "duplicate") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "freeallvars") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
if (varPtr[i] != NULL) {
Tcl_DecrRefCount(varPtr[i]);
varPtr[i] = NULL;
}
}
} else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) {
if ( objc != 3 ) {
goto wrongNumArgs;
}
index = Tcl_GetString( objv[2] );
if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_InvalidateStringRep( varPtr[varIndex] );
Tcl_SetObjResult( interp, varPtr[varIndex] );
} else if (strcmp(subCmd, "newobj") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(varIndex, Tcl_NewObj());
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "objtype") == 0) {
char *typeName;
/*
* return an object containing the name of the argument's type
* of internal rep. If none exists, return "none".
*/
if (objc != 3) {
goto wrongNumArgs;
}
if (objv[2]->typePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
} else {
typeName = objv[2]->typePtr->name;
Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
}
} else if (strcmp(subCmd, "refcount") == 0) {
char buf[TCL_INTEGER_SPACE];
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
TclFormatInt(buf, varPtr[varIndex]->refCount);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(subCmd, "type") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
varPtr[varIndex]->typePtr->name, -1);
}
} else if (strcmp(subCmd, "types") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
if (Tcl_AppendAllObjTypes(interp,
Tcl_GetObjResult(interp)) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"",
Tcl_GetString(objv[1]),
"\": must be assign, convert, duplicate, freeallvars, ",
"newobj, objcount, objtype, refcount, type, or types",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TeststringobjCmd --
*
* This procedure implements the "teststringobj" command. It is used to
* test the string Tcl object type implementation.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* Creates and frees string objects, and also converts objects to
* have string type.
*
*----------------------------------------------------------------------
*/
static int
TeststringobjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int varIndex, option, i, length;
Tcl_UniChar *unicode;
#define MAX_STRINGS 11
char *index, *string, *strings[MAX_STRINGS+1];
TestString *strPtr;
static CONST char *options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
"set", "set2", "setlength", "ualloc", "getunicode",
"appendself", "appendself2", (char *) NULL
};
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
!= TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0: /* append */
if (objc != 5) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetString(objv[3]);
Tcl_AppendToObj(varPtr[varIndex], string, length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 1: /* appendstrings */
if (objc > (MAX_STRINGS+3)) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
for (i = 3; i < objc; i++) {
strings[i-3] = Tcl_GetString(objv[i]);
}
for ( ; i < 12 + 3; i++) {
strings[i - 3] = NULL;
}
Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
strings[2], strings[3], strings[4], strings[5],
strings[6], strings[7], strings[8], strings[9],
strings[10], strings[11]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 2: /* get */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 3: /* get2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? varPtr[varIndex]->length : -1);
break;
case 5: /* length2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = (int) strPtr->allocated;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
goto wrongNumArgs;
}
/*
* If the object currently bound to the variable with index
* varIndex has ref count 1 (i.e. the object is unshared) we
* can modify that object directly. Otherwise, if RC>1 (i.e.
* the object is shared), we must create a new object to
* modify/set and decrement the old formerly-shared object's
* ref count. This is "copy on write".
*/
string = Tcl_GetStringFromObj(objv[3], &length);
if ((varPtr[varIndex] != NULL)
&& !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetStringObj(varPtr[varIndex], string, length);
} else {
SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 7: /* set2 */
if (objc != 4) {
goto wrongNumArgs;
}
SetVarToObj(varIndex, objv[3]);
break;
case 8: /* setlength */
if (objc != 4) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] != NULL) {
Tcl_SetObjLength(varPtr[varIndex], length);
}
break;
case 9: /* ualloc */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = (int) strPtr->uallocated;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: /* getunicode */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
break;
case 11: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetStringFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 12: /* appendself2 */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetVarToObj --
*
* Utility routine to assign a Tcl_Obj* to a test variable. The
* Tcl_Obj* can be NULL.
*
* Results:
* None.
*
* Side effects:
* This routine handles ref counting details for assignment:
* i.e. the old value's ref count must be decremented (if not NULL) and
* the new one incremented (also if not NULL).
*
*----------------------------------------------------------------------
*/
static void
SetVarToObj(varIndex, objPtr)
int varIndex; /* Designates the assignment variable. */
Tcl_Obj *objPtr; /* Points to object to assign to var. */
{
if (varPtr[varIndex] != NULL) {
Tcl_DecrRefCount(varPtr[varIndex]);
}
varPtr[varIndex] = objPtr;
if (objPtr != NULL) {
Tcl_IncrRefCount(objPtr);
}
}
/*
*----------------------------------------------------------------------
*
* GetVariableIndex --
*
* Utility routine to get a test variable index from the command line.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
GetVariableIndex(interp, string, indexPtr)
Tcl_Interp *interp; /* Interpreter for error reporting. */
char *string; /* String containing a variable index
* specified as a nonnegative number less
* than NUMBER_OF_OBJECT_VARS. */
int *indexPtr; /* Place to store converted result. */
{
int index;
if (Tcl_GetInt(interp, string, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1);
return TCL_ERROR;
}
*indexPtr = index;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* CheckIfVarUnset --
*
* Utility procedure that checks whether a test variable is readable:
* i.e., that varPtr[varIndex] is non-NULL.
*
* Results:
* 1 if the test variable is unset (NULL); 0 otherwise.
*
* Side effects:
* Sets the interpreter result to an error message if the variable is
* unset (NULL).
*
*----------------------------------------------------------------------
*/
static int
CheckIfVarUnset(interp, varIndex)
Tcl_Interp *interp; /* Interpreter for error reporting. */
int varIndex; /* Index of the test variable to check. */
{
if (varPtr[varIndex] == NULL) {
char buf[32 + TCL_INTEGER_SPACE];
sprintf(buf, "variable %d is unset (NULL)", varIndex);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
return 1;
}
return 0;
}
tcl8.4.20/generic/tclPanic.c 0000644 0036047 0045461 00000006266 11737050674 014246 0 ustar dgp 771div /*
* tclPanic.c --
*
* Source code for the "Tcl_Panic" library procedure for Tcl;
* individual applications will probably call Tcl_SetPanicProc()
* to set an application-specific panic procedure.
*
* Copyright (c) 1988-1993 The Regents of the University of California.
* Copyright (c) 1994 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* The panicProc variable contains a pointer to an application
* specific panic procedure.
*/
static Tcl_PanicProc *panicProc = NULL;
/*
* The platformPanicProc variable contains a pointer to a platform
* specific panic procedure, if any. ( TclpPanic may be NULL via
* a macro. )
*/
static Tcl_PanicProc * CONST platformPanicProc = TclpPanic;
/*
*----------------------------------------------------------------------
*
* Tcl_SetPanicProc --
*
* Replace the default panic behavior with the specified functiion.
*
* Results:
* None.
*
* Side effects:
* Sets the panicProc variable.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetPanicProc(proc)
Tcl_PanicProc *proc;
{
panicProc = proc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PanicVA --
*
* Print an error message and kill the process.
*
* Results:
* None.
*
* Side effects:
* The process dies, entering the debugger if possible.
*
*----------------------------------------------------------------------
*/
void
Tcl_PanicVA (format, argList)
CONST char *format; /* Format string, suitable for passing to
* fprintf. */
va_list argList; /* Variable argument list. */
{
char *arg1, *arg2, *arg3, *arg4; /* Additional arguments (variable in
* number) to pass to fprintf. */
char *arg5, *arg6, *arg7, *arg8;
arg1 = va_arg(argList, char *);
arg2 = va_arg(argList, char *);
arg3 = va_arg(argList, char *);
arg4 = va_arg(argList, char *);
arg5 = va_arg(argList, char *);
arg6 = va_arg(argList, char *);
arg7 = va_arg(argList, char *);
arg8 = va_arg(argList, char *);
if (panicProc != NULL) {
(void) (*panicProc)(format, arg1, arg2, arg3, arg4,
arg5, arg6, arg7, arg8);
} else if (platformPanicProc != NULL) {
(void) (*platformPanicProc)(format, arg1, arg2, arg3, arg4,
arg5, arg6, arg7, arg8);
} else {
(void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6,
arg7, arg8);
(void) fprintf(stderr, "\n");
(void) fflush(stderr);
abort();
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_Panic --
*
* Print an error message and kill the process.
*
* Results:
* None.
*
* Side effects:
* The process dies, entering the debugger if possible.
*
*----------------------------------------------------------------------
*/
/* VARARGS ARGSUSED */
void
Tcl_Panic TCL_VARARGS_DEF(CONST char *,arg1)
{
va_list argList;
CONST char *format;
format = TCL_VARARGS_START(CONST char *,arg1,argList);
Tcl_PanicVA(format, argList);
va_end (argList);
}
tcl8.4.20/generic/tclUtf.c 0000644 0036047 0045461 00000131664 11737050674 013753 0 ustar dgp 771div /*
* tclUtf.c --
*
* Routines for manipulating UTF-8 strings.
*
* Copyright (c) 1997-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.
*/
#include "tclInt.h"
/*
* Include the static character classification tables and macros.
*/
#include "tclUniData.c"
/*
* The following macros are used for fast character category tests. The
* x_BITS values are shifted right by the category value to determine whether
* the given category is included in the set.
*/
#define ALPHA_BITS ((1 << UPPERCASE_LETTER) | (1 << LOWERCASE_LETTER) \
| (1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) | (1 << OTHER_LETTER))
#define CONTROL_BITS ((1 << CONTROL) | (1 << FORMAT) | (1 << PRIVATE_USE))
#define DIGIT_BITS (1 << DECIMAL_DIGIT_NUMBER)
#define SPACE_BITS ((1 << SPACE_SEPARATOR) | (1 << LINE_SEPARATOR) \
| (1 << PARAGRAPH_SEPARATOR))
#define WORD_BITS (ALPHA_BITS | DIGIT_BITS | (1 << CONNECTOR_PUNCTUATION))
#define PUNCT_BITS ((1 << CONNECTOR_PUNCTUATION) | \
(1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \
(1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \
(1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION))
#define GRAPH_BITS (WORD_BITS | PUNCT_BITS | \
(1 << NON_SPACING_MARK) | (1 << ENCLOSING_MARK) | \
(1 << COMBINING_SPACING_MARK) | (1 << LETTER_NUMBER) | \
(1 << OTHER_NUMBER) | \
(1 << MATH_SYMBOL) | (1 << CURRENCY_SYMBOL) | \
(1 << MODIFIER_SYMBOL) | (1 << OTHER_SYMBOL))
/*
* Unicode characters less than this value are represented by themselves
* in UTF-8 strings.
*/
#define UNICODE_SELF 0x80
/*
* The following structures are used when mapping between Unicode (UCS-2)
* and UTF-8.
*/
static CONST unsigned char totalBytes[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
#if TCL_UTF_MAX > 3
4,4,4,4,4,4,4,4,
#else
1,1,1,1,1,1,1,1,
#endif
#if TCL_UTF_MAX > 4
5,5,5,5,
#else
1,1,1,1,
#endif
#if TCL_UTF_MAX > 5
6,6,6,6
#else
1,1,1,1
#endif
};
/*
* Procedures used only in this module.
*/
static int UtfCount _ANSI_ARGS_((int ch));
/*
*---------------------------------------------------------------------------
*
* UtfCount --
*
* Find the number of bytes in the Utf character "ch".
*
* Results:
* The return values is the number of bytes in the Utf character "ch".
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
INLINE static int
UtfCount(ch)
int ch; /* The Tcl_UniChar whose size is returned. */
{
if ((ch > 0) && (ch < UNICODE_SELF)) {
return 1;
}
if (ch <= 0x7FF) {
return 2;
}
if (ch <= 0xFFFF) {
return 3;
}
#if TCL_UTF_MAX > 3
if (ch <= 0x1FFFFF) {
return 4;
}
if (ch <= 0x3FFFFFF) {
return 5;
}
if (ch <= 0x7FFFFFFF) {
return 6;
}
#endif
return 3;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UniCharToUtf --
*
* Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the
* provided buffer. Equivalent to Plan 9 runetochar().
*
* Results:
* The return values is the number of bytes in the buffer that
* were consumed.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
INLINE int
Tcl_UniCharToUtf(ch, str)
int ch; /* The Tcl_UniChar to be stored in the
* buffer. */
char *str; /* Buffer in which the UTF-8 representation
* of the Tcl_UniChar is stored. Buffer must
* be large enough to hold the UTF-8 character
* (at most TCL_UTF_MAX bytes). */
{
if ((ch > 0) && (ch < UNICODE_SELF)) {
str[0] = (char) ch;
return 1;
}
if (ch >= 0) {
if (ch <= 0x7FF) {
str[1] = (char) ((ch | 0x80) & 0xBF);
str[0] = (char) ((ch >> 6) | 0xC0);
return 2;
}
if (ch <= 0xFFFF) {
three:
str[2] = (char) ((ch | 0x80) & 0xBF);
str[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
str[0] = (char) ((ch >> 12) | 0xE0);
return 3;
}
#if TCL_UTF_MAX > 3
if (ch <= 0x1FFFFF) {
str[3] = (char) ((ch | 0x80) & 0xBF);
str[2] = (char) (((ch >> 6) | 0x80) & 0xBF);
str[1] = (char) (((ch >> 12) | 0x80) & 0xBF);
str[0] = (char) ((ch >> 18) | 0xF0);
return 4;
}
if (ch <= 0x3FFFFFF) {
str[4] = (char) ((ch | 0x80) & 0xBF);
str[3] = (char) (((ch >> 6) | 0x80) & 0xBF);
str[2] = (char) (((ch >> 12) | 0x80) & 0xBF);
str[1] = (char) (((ch >> 18) | 0x80) & 0xBF);
str[0] = (char) ((ch >> 24) | 0xF8);
return 5;
}
if (ch <= 0x7FFFFFFF) {
str[5] = (char) ((ch | 0x80) & 0xBF);
str[4] = (char) (((ch >> 6) | 0x80) & 0xBF);
str[3] = (char) (((ch >> 12) | 0x80) & 0xBF);
str[2] = (char) (((ch >> 18) | 0x80) & 0xBF);
str[1] = (char) (((ch >> 24) | 0x80) & 0xBF);
str[0] = (char) ((ch >> 30) | 0xFC);
return 6;
}
#endif
}
ch = 0xFFFD;
goto three;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UniCharToUtfDString --
*
* Convert the given Unicode string to UTF-8.
*
* Results:
* The return value is a pointer to the UTF-8 representation of the
* Unicode string. Storage for the return value is appended to the
* end of dsPtr.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
char *
Tcl_UniCharToUtfDString(wString, numChars, dsPtr)
CONST Tcl_UniChar *wString; /* Unicode string to convert to UTF-8. */
int numChars; /* Length of Unicode string in Tcl_UniChars
* (must be >= 0). */
Tcl_DString *dsPtr; /* UTF-8 representation of string is
* appended to this previously initialized
* DString. */
{
CONST Tcl_UniChar *w, *wEnd;
char *p, *string;
int oldLength;
/*
* UTF-8 string length in bytes will be <= Unicode string length *
* TCL_UTF_MAX.
*/
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr, (oldLength + numChars + 1) * TCL_UTF_MAX);
string = Tcl_DStringValue(dsPtr) + oldLength;
p = string;
wEnd = wString + numChars;
for (w = wString; w < wEnd; ) {
p += Tcl_UniCharToUtf(*w, p);
w++;
}
Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
return string;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfToUniChar --
*
* Extract the Tcl_UniChar represented by the UTF-8 string. Bad
* UTF-8 sequences are converted to valid Tcl_UniChars and processing
* continues. Equivalent to Plan 9 chartorune().
*
* The caller must ensure that the source buffer is long enough that
* this routine does not run off the end and dereference non-existent
* memory looking for trail bytes. If the source buffer is known to
* be '\0' terminated, this cannot happen. Otherwise, the caller
* should call Tcl_UtfCharComplete() before calling this routine to
* ensure that enough bytes remain in the string.
*
* Results:
* *chPtr is filled with the Tcl_UniChar, and the return value is the
* number of bytes from the UTF-8 string that were consumed.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_UtfToUniChar(str, chPtr)
register CONST char *str; /* The UTF-8 string. */
register Tcl_UniChar *chPtr; /* Filled with the Tcl_UniChar represented
* by the UTF-8 string. */
{
register int byte;
/*
* Unroll 1 to 3 byte UTF-8 sequences, use loop to handle longer ones.
*/
byte = *((unsigned char *) str);
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
* Also treats \0 and naked trail bytes 0x80 to 0xBF as valid
* characters representing themselves.
*/
*chPtr = (Tcl_UniChar) byte;
return 1;
} else if (byte < 0xE0) {
if ((str[1] & 0xC0) == 0x80) {
/*
* Two-byte-character lead-byte followed by a trail-byte.
*/
*chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (str[1] & 0x3F));
return 2;
}
/*
* A two-byte-character lead-byte not followed by trail-byte
* represents itself.
*/
*chPtr = (Tcl_UniChar) byte;
return 1;
} else if (byte < 0xF0) {
if (((str[1] & 0xC0) == 0x80) && ((str[2] & 0xC0) == 0x80)) {
/*
* Three-byte-character lead byte followed by two trail bytes.
*/
*chPtr = (Tcl_UniChar) (((byte & 0x0F) << 12)
| ((str[1] & 0x3F) << 6) | (str[2] & 0x3F));
return 3;
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
*chPtr = (Tcl_UniChar) byte;
return 1;
}
#if TCL_UTF_MAX > 3
else {
int ch, total, trail;
total = totalBytes[byte];
trail = total - 1;
if (trail > 0) {
ch = byte & (0x3F >> trail);
do {
str++;
if ((*str & 0xC0) != 0x80) {
*chPtr = byte;
return 1;
}
ch <<= 6;
ch |= (*str & 0x3F);
trail--;
} while (trail > 0);
*chPtr = ch;
return total;
}
}
#endif
*chPtr = (Tcl_UniChar) byte;
return 1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfToUniCharDString --
*
* Convert the UTF-8 string to Unicode.
*
* Results:
* The return value is a pointer to the Unicode representation of the
* UTF-8 string. Storage for the return value is appended to the
* end of dsPtr. The Unicode string is terminated with a Unicode
* NULL character.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_UniChar *
Tcl_UtfToUniCharDString(string, length, dsPtr)
CONST char *string; /* UTF-8 string to convert to Unicode. */
int length; /* Length of UTF-8 string in bytes, or -1
* for strlen(). */
Tcl_DString *dsPtr; /* Unicode representation of string is
* appended to this previously initialized
* DString. */
{
Tcl_UniChar *w, *wString;
CONST char *p, *end;
int oldLength;
if (length < 0) {
length = strlen(string);
}
/*
* Unicode string length in Tcl_UniChars will be <= UTF-8 string length
* in bytes.
*/
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr,
(int) ((oldLength + length + 1) * sizeof(Tcl_UniChar)));
wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
end = string + length;
for (p = string; p < end; ) {
p += TclUtfToUniChar(p, w);
w++;
}
*w = '\0';
Tcl_DStringSetLength(dsPtr,
(oldLength + ((char *) w - (char *) wString)));
return wString;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfCharComplete --
*
* Determine if the UTF-8 string of the given length is long enough
* to be decoded by Tcl_UtfToUniChar(). This does not ensure that the
* UTF-8 string is properly formed. Equivalent to Plan 9 fullrune().
*
* Results:
* The return value is 0 if the string is not long enough, non-zero
* otherwise.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_UtfCharComplete(str, len)
CONST char *str; /* String to check if first few bytes
* contain a complete UTF-8 character. */
int len; /* Length of above string in bytes. */
{
int ch;
ch = *((unsigned char *) str);
return len >= totalBytes[ch];
}
/*
*---------------------------------------------------------------------------
*
* Tcl_NumUtfChars --
*
* Returns the number of characters (not bytes) in the UTF-8 string,
* not including the terminating NULL byte. This is equivalent to
* Plan 9 utflen() and utfnlen().
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_NumUtfChars(str, len)
register CONST char *str; /* The UTF-8 string to measure. */
int len; /* The length of the string in bytes, or -1
* for strlen(string). */
{
Tcl_UniChar ch;
register Tcl_UniChar *chPtr = &ch;
register int i;
/*
* The separate implementations are faster.
*
* Since this is a time-sensitive function, we also do the check for
* the single-byte char case specially.
*/
i = 0;
if (len < 0) {
while (*str != '\0') {
str += TclUtfToUniChar(str, chPtr);
i++;
}
} else {
register int n;
while (len > 0) {
if (UCHAR(*str) < 0xC0) {
len--;
str++;
} else {
n = Tcl_UtfToUniChar(str, chPtr);
len -= n;
str += n;
}
i++;
}
}
return i;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfFindFirst --
*
* Returns a pointer to the first occurance of the given Tcl_UniChar
* in the NULL-terminated UTF-8 string. The NULL terminator is
* considered part of the UTF-8 string. Equivalent to Plan 9
* utfrune().
*
* Results:
* As above. If the Tcl_UniChar does not exist in the given string,
* the return value is NULL.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
CONST char *
Tcl_UtfFindFirst(string, ch)
CONST char *string; /* The UTF-8 string to be searched. */
int ch; /* The Tcl_UniChar to search for. */
{
int len;
Tcl_UniChar find;
while (1) {
len = TclUtfToUniChar(string, &find);
if (find == ch) {
return string;
}
if (*string == '\0') {
return NULL;
}
string += len;
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfFindLast --
*
* Returns a pointer to the last occurance of the given Tcl_UniChar
* in the NULL-terminated UTF-8 string. The NULL terminator is
* considered part of the UTF-8 string. Equivalent to Plan 9
* utfrrune().
*
* Results:
* As above. If the Tcl_UniChar does not exist in the given string,
* the return value is NULL.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
CONST char *
Tcl_UtfFindLast(string, ch)
CONST char *string; /* The UTF-8 string to be searched. */
int ch; /* The Tcl_UniChar to search for. */
{
int len;
Tcl_UniChar find;
CONST char *last;
last = NULL;
while (1) {
len = TclUtfToUniChar(string, &find);
if (find == ch) {
last = string;
}
if (*string == '\0') {
break;
}
string += len;
}
return last;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfNext --
*
* Given a pointer to some current location in a UTF-8 string,
* move forward one character. The caller must ensure that they
* are not asking for the next character after the last character
* in the string.
*
* Results:
* The return value is the pointer to the next character in
* the UTF-8 string.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
CONST char *
Tcl_UtfNext(str)
CONST char *str; /* The current location in the string. */
{
Tcl_UniChar ch;
return str + TclUtfToUniChar(str, &ch);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfPrev --
*
* Given a pointer to some current location in a UTF-8 string,
* move backwards one character. This works correctly when the
* pointer is in the middle of a UTF-8 character.
*
* Results:
* The return value is a pointer to the previous character in the
* UTF-8 string. If the current location was already at the
* beginning of the string, the return value will also be a
* pointer to the beginning of the string.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
CONST char *
Tcl_UtfPrev(str, start)
CONST char *str; /* The current location in the string. */
CONST char *start; /* Pointer to the beginning of the
* string, to avoid going backwards too
* far. */
{
CONST char *look;
int i, byte;
str--;
look = str;
for (i = 0; i < TCL_UTF_MAX; i++) {
if (look < start) {
if (str < start) {
str = start;
}
break;
}
byte = *((unsigned char *) look);
if (byte < 0x80) {
break;
}
if (byte >= 0xC0) {
return look;
}
look--;
}
return str;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UniCharAtIndex --
*
* Returns the Unicode character represented at the specified
* character (not byte) position in the UTF-8 string.
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_UniChar
Tcl_UniCharAtIndex(src, index)
register CONST char *src; /* The UTF-8 string to dereference. */
register int index; /* The position of the desired character. */
{
Tcl_UniChar ch;
while (index >= 0) {
index--;
src += TclUtfToUniChar(src, &ch);
}
return ch;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfAtIndex --
*
* Returns a pointer to the specified character (not byte) position
* in the UTF-8 string.
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
CONST char *
Tcl_UtfAtIndex(src, index)
register CONST char *src; /* The UTF-8 string. */
register int index; /* The position of the desired character. */
{
Tcl_UniChar ch;
while (index > 0) {
index--;
src += TclUtfToUniChar(src, &ch);
}
return src;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfBackslash --
*
* Figure out how to handle a backslash sequence.
*
* Results:
* Stores the bytes represented by the backslash sequence in dst and
* returns the number of bytes written to dst. At most TCL_UTF_MAX
* bytes are written to dst; dst must have been large enough to accept
* those bytes. If readPtr isn't NULL then it is filled in with a
* count of the number of bytes in the backslash sequence.
*
* Side effects:
* The maximum number of bytes it takes to represent a Unicode
* character in UTF-8 is guaranteed to be less than the number of
* bytes used to express the backslash sequence that represents
* that Unicode character. If the target buffer into which the
* caller is going to store the bytes that represent the Unicode
* character is at least as large as the source buffer from which
* the backslashed sequence was extracted, no buffer overruns should
* occur.
*
*---------------------------------------------------------------------------
*/
int
Tcl_UtfBackslash(src, readPtr, dst)
CONST char *src; /* Points to the backslash character of
* a backslash sequence. */
int *readPtr; /* Fill in with number of characters read
* from src, unless NULL. */
char *dst; /* Filled with the bytes represented by the
* backslash sequence. */
{
#define LINE_LENGTH 128
int numRead;
int result;
result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst);
if (numRead == LINE_LENGTH) {
/* We ate a whole line. Pay the price of a strlen() */
result = TclParseBackslash(src, (int)strlen(src), &numRead, dst);
}
if (readPtr != NULL) {
*readPtr = numRead;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UtfToUpper --
*
* Convert lowercase characters to uppercase characters in a UTF
* string in place. The conversion may shrink the UTF string.
*
* Results:
* Returns the number of bytes in the resulting string
* excluding the trailing null.
*
* Side effects:
* Writes a terminating null after the last converted character.
*
*----------------------------------------------------------------------
*/
int
Tcl_UtfToUpper(str)
char *str; /* String to convert in place. */
{
Tcl_UniChar ch, upChar;
char *src, *dst;
int bytes;
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
bytes = TclUtfToUniChar(src, &ch);
upChar = Tcl_UniCharToUpper(ch);
/*
* To keep badly formed Utf strings from getting inflated by
* the conversion (thereby causing a segfault), only copy the
* upper case char to dst if its size is <= the original char.
*/
if (bytes < UtfCount(upChar)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
dst += Tcl_UniCharToUtf(upChar, dst);
}
src += bytes;
}
*dst = '\0';
return (dst - str);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UtfToLower --
*
* Convert uppercase characters to lowercase characters in a UTF
* string in place. The conversion may shrink the UTF string.
*
* Results:
* Returns the number of bytes in the resulting string
* excluding the trailing null.
*
* Side effects:
* Writes a terminating null after the last converted character.
*
*----------------------------------------------------------------------
*/
int
Tcl_UtfToLower(str)
char *str; /* String to convert in place. */
{
Tcl_UniChar ch, lowChar;
char *src, *dst;
int bytes;
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
bytes = TclUtfToUniChar(src, &ch);
lowChar = Tcl_UniCharToLower(ch);
/*
* To keep badly formed Utf strings from getting inflated by
* the conversion (thereby causing a segfault), only copy the
* lower case char to dst if its size is <= the original char.
*/
if (bytes < UtfCount(lowChar)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += bytes;
}
*dst = '\0';
return (dst - str);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UtfToTitle --
*
* Changes the first character of a UTF string to title case or
* uppercase and the rest of the string to lowercase. The
* conversion happens in place and may shrink the UTF string.
*
* Results:
* Returns the number of bytes in the resulting string
* excluding the trailing null.
*
* Side effects:
* Writes a terminating null after the last converted character.
*
*----------------------------------------------------------------------
*/
int
Tcl_UtfToTitle(str)
char *str; /* String to convert in place. */
{
Tcl_UniChar ch, titleChar, lowChar;
char *src, *dst;
int bytes;
/*
* Capitalize the first character and then lowercase the rest of the
* characters until we get to a null.
*/
src = dst = str;
if (*src) {
bytes = TclUtfToUniChar(src, &ch);
titleChar = Tcl_UniCharToTitle(ch);
if (bytes < UtfCount(titleChar)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
dst += Tcl_UniCharToUtf(titleChar, dst);
}
src += bytes;
}
while (*src) {
bytes = TclUtfToUniChar(src, &ch);
lowChar = Tcl_UniCharToLower(ch);
if (bytes < UtfCount(lowChar)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += bytes;
}
*dst = '\0';
return (dst - str);
}
/*
*----------------------------------------------------------------------
*
* TclpUtfNcmp2 --
*
* Compare at most n bytes of utf-8 strings cs and ct. Both cs
* and ct are assumed to be at least n bytes long.
*
* Results:
* Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclpUtfNcmp2(cs, ct, n)
CONST char *cs; /* UTF string to compare to ct. */
CONST char *ct; /* UTF string cs is compared to. */
unsigned long n; /* Number of *bytes* to compare. */
{
/*
* We can't simply call 'memcmp(cs, ct, n);' because we need to check
* for Tcl's \xC0\x80 non-utf-8 null encoding.
* Otherwise utf-8 lexes fine in the strcmp manner.
*/
register int result = 0;
for ( ; n != 0; n--, cs++, ct++) {
if (*cs != *ct) {
result = UCHAR(*cs) - UCHAR(*ct);
break;
}
}
if (n && ((UCHAR(*cs) == 0xC0) || (UCHAR(*ct) == 0xC0))) {
unsigned char c1, c2;
c1 = ((UCHAR(*cs) == 0xC0) && (UCHAR(cs[1]) == 0x80)) ? 0 : UCHAR(*cs);
c2 = ((UCHAR(*ct) == 0xC0) && (UCHAR(ct[1]) == 0x80)) ? 0 : UCHAR(*ct);
result = (c1 - c2);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UtfNcmp --
*
* Compare at most n UTF chars of string cs to string ct. Both cs
* and ct are assumed to be at least n UTF chars long.
*
* Results:
* Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UtfNcmp(cs, ct, n)
CONST char *cs; /* UTF string to compare to ct. */
CONST char *ct; /* UTF string cs is compared to. */
unsigned long n; /* Number of UTF chars to compare. */
{
Tcl_UniChar ch1, ch2;
/*
* Cannot use 'memcmp(cs, ct, n);' as byte representation of
* \u0000 (the pair of bytes 0xc0,0x80) is larger than byte
* representation of \u0001 (the byte 0x01.)
*/
while (n-- > 0) {
/*
* n must be interpreted as chars, not bytes.
* This should be called only when both strings are of
* at least n chars long (no need for \0 check)
*/
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
return (ch1 - ch2);
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UtfNcasecmp --
*
* Compare at most n UTF chars of string cs to string ct case
* insensitive. Both cs and ct are assumed to be at least n
* UTF chars long.
*
* Results:
* Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UtfNcasecmp(cs, ct, n)
CONST char *cs; /* UTF string to compare to ct. */
CONST char *ct; /* UTF string cs is compared to. */
unsigned long n; /* Number of UTF chars to compare. */
{
Tcl_UniChar ch1, ch2;
while (n-- > 0) {
/*
* n must be interpreted as chars, not bytes.
* This should be called only when both strings are of
* at least n chars long (no need for \0 check)
*/
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
ch1 = Tcl_UniCharToLower(ch1);
ch2 = Tcl_UniCharToLower(ch2);
if (ch1 != ch2) {
return (ch1 - ch2);
}
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToUpper --
*
* Compute the uppercase equivalent of the given Unicode character.
*
* Results:
* Returns the uppercase Unicode character.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_UniChar
Tcl_UniCharToUpper(ch)
int ch; /* Unicode character to convert. */
{
int info = GetUniCharInfo(ch);
if (GetCaseType(info) & 0x04) {
ch -= GetDelta(info);
}
return (Tcl_UniChar) ch;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToLower --
*
* Compute the lowercase equivalent of the given Unicode character.
*
* Results:
* Returns the lowercase Unicode character.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_UniChar
Tcl_UniCharToLower(ch)
int ch; /* Unicode character to convert. */
{
int info = GetUniCharInfo(ch);
if (GetCaseType(info) & 0x02) {
ch += GetDelta(info);
}
return (Tcl_UniChar) ch;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToTitle --
*
* Compute the titlecase equivalent of the given Unicode character.
*
* Results:
* Returns the titlecase Unicode character.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_UniChar
Tcl_UniCharToTitle(ch)
int ch; /* Unicode character to convert. */
{
int info = GetUniCharInfo(ch);
int mode = GetCaseType(info);
if (mode & 0x1) {
/*
* Subtract or add one depending on the original case.
*/
ch += ((mode & 0x4) ? -1 : 1);
} else if (mode == 0x4) {
ch -= GetDelta(info);
}
return (Tcl_UniChar) ch;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharLen --
*
* Find the length of a UniChar string. The str input must be null
* terminated.
*
* Results:
* Returns the length of str in UniChars (not bytes).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharLen(str)
CONST Tcl_UniChar *str; /* Unicode string to find length of. */
{
int len = 0;
while (*str != '\0') {
len++;
str++;
}
return len;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharNcmp --
*
* Compare at most n unichars of string cs to string ct. Both cs
* and ct are assumed to be at least n unichars long.
*
* Results:
* Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharNcmp(cs, ct, n)
CONST Tcl_UniChar *cs; /* Unicode string to compare to ct. */
CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */
unsigned long n; /* Number of unichars to compare. */
{
#ifdef WORDS_BIGENDIAN
/*
* We are definitely on a big-endian machine; memcmp() is safe
*/
return memcmp(cs, ct, n*sizeof(Tcl_UniChar));
#else /* !WORDS_BIGENDIAN */
/*
* We can't simply call memcmp() because that is not lexically correct.
*/
for ( ; n != 0; cs++, ct++, n--) {
if (*cs != *ct) {
return (*cs - *ct);
}
}
return 0;
#endif /* WORDS_BIGENDIAN */
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharNcasecmp --
*
* Compare at most n unichars of string cs to string ct case
* insensitive. Both cs and ct are assumed to be at least n
* unichars long.
*
* Results:
* Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharNcasecmp(cs, ct, n)
CONST Tcl_UniChar *cs; /* Unicode string to compare to ct. */
CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */
unsigned long n; /* Number of unichars to compare. */
{
for ( ; n != 0; n--, cs++, ct++) {
if (*cs != *ct) {
Tcl_UniChar lcs = Tcl_UniCharToLower(*cs);
Tcl_UniChar lct = Tcl_UniCharToLower(*ct);
if (lcs != lct) {
return (lcs - lct);
}
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsAlnum --
*
* Test if a character is an alphanumeric Unicode character.
*
* Results:
* Returns 1 if character is alphanumeric.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsAlnum(ch)
int ch; /* Unicode character to test. */
{
return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsAlpha --
*
* Test if a character is an alphabetic Unicode character.
*
* Results:
* Returns 1 if character is alphabetic.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsAlpha(ch)
int ch; /* Unicode character to test. */
{
return ((ALPHA_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsControl --
*
* Test if a character is a Unicode control character.
*
* Results:
* Returns non-zero if character is a control.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsControl(ch)
int ch; /* Unicode character to test. */
{
return ((CONTROL_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsDigit --
*
* Test if a character is a numeric Unicode character.
*
* Results:
* Returns non-zero if character is a digit.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsDigit(ch)
int ch; /* Unicode character to test. */
{
return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsGraph --
*
* Test if a character is any Unicode print character except space.
*
* Results:
* Returns non-zero if character is printable, but not space.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsGraph(ch)
int ch; /* Unicode character to test. */
{
return ((GRAPH_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsLower --
*
* Test if a character is a lowercase Unicode character.
*
* Results:
* Returns non-zero if character is lowercase.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsLower(ch)
int ch; /* Unicode character to test. */
{
return (GetCategory(ch) == LOWERCASE_LETTER);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsPrint --
*
* Test if a character is a Unicode print character.
*
* Results:
* Returns non-zero if character is printable.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsPrint(ch)
int ch; /* Unicode character to test. */
{
return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsPunct --
*
* Test if a character is a Unicode punctuation character.
*
* Results:
* Returns non-zero if character is punct.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsPunct(ch)
int ch; /* Unicode character to test. */
{
return ((PUNCT_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsSpace --
*
* Test if a character is a whitespace Unicode character.
*
* Results:
* Returns non-zero if character is a space.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsSpace(ch)
int ch; /* Unicode character to test. */
{
/*
* If the character is within the first 127 characters, just use the
* standard C function, otherwise consult the Unicode table.
*/
if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) {
return isspace(UCHAR(ch)); /* INTL: ISO space */
} else {
return ((SPACE_BITS >> GetCategory(ch)) & 1);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsUpper --
*
* Test if a character is a uppercase Unicode character.
*
* Results:
* Returns non-zero if character is uppercase.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsUpper(ch)
int ch; /* Unicode character to test. */
{
return (GetCategory(ch) == UPPERCASE_LETTER);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharIsWordChar --
*
* Test if a character is alphanumeric or a connector punctuation
* mark.
*
* Results:
* Returns 1 if character is a word character.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharIsWordChar(ch)
int ch; /* Unicode character to test. */
{
return ((WORD_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharCaseMatch --
*
* See if a particular Unicode string matches a particular pattern.
* Allows case insensitivity. This is the Unicode equivalent of
* the char* Tcl_StringCaseMatch. The UniChar strings must be
* NULL-terminated. This has no provision for counted UniChar
* strings, thus should not be used where NULLs are expected in the
* UniChar string. Use TclUniCharMatch where possible.
*
* Results:
* The return value is 1 if string matches pattern, and
* 0 otherwise. The matching operation permits the following
* special characters in the pattern: *?\[] (see the manual
* entry for details on what these mean).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharCaseMatch(string, pattern, nocase)
CONST Tcl_UniChar *string; /* Unicode String. */
CONST Tcl_UniChar *pattern; /* Pattern, which may contain special
* characters. */
int nocase; /* 0 for case sensitive, 1 for insensitive */
{
Tcl_UniChar ch1, p;
while (1) {
p = *pattern;
/*
* See if we're at the end of both the pattern and the string. If
* so, we succeeded. If we're at the end of the pattern but not at
* the end of the string, we failed.
*/
if (p == 0) {
return (*string == 0);
}
if ((*string == 0) && (p != '*')) {
return 0;
}
/*
* Check for a "*" as the next pattern character. It matches any
* substring. We handle this by skipping all the characters up to the
* next matching one in the pattern, and then calling ourselves
* recursively for each postfix of string, until either we match or we
* reach the end of the string.
*/
if (p == '*') {
/*
* Skip all successive *'s in the pattern
*/
while (*(++pattern) == '*') {}
p = *pattern;
if (p == 0) {
return 1;
}
if (nocase) {
p = Tcl_UniCharToLower(p);
}
while (1) {
/*
* Optimization for matching - cruise through the string
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*string && (p != *string)
&& (p != Tcl_UniCharToLower(*string))) {
string++;
}
} else {
while (*string && (p != *string)) { string++; }
}
}
if (Tcl_UniCharCaseMatch(string, pattern, nocase)) {
return 1;
}
if (*string == 0) {
return 0;
}
string++;
}
}
/*
* Check for a "?" as the next pattern character. It matches
* any single character.
*/
if (p == '?') {
pattern++;
string++;
continue;
}
/*
* Check for a "[" as the next pattern character. It is followed
* by a list of characters that are acceptable, or by a range
* (two characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar startChar, endChar;
pattern++;
ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string);
string++;
while (1) {
if ((*pattern == ']') || (*pattern == 0)) {
return 0;
}
startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern);
pattern++;
if (*pattern == '-') {
pattern++;
if (*pattern == 0) {
return 0;
}
endChar = (nocase ? Tcl_UniCharToLower(*pattern)
: *pattern);
pattern++;
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
break;
}
} else if (startChar == ch1) {
break;
}
}
while (*pattern != ']') {
if (*pattern == 0) {
pattern--;
break;
}
pattern++;
}
pattern++;
continue;
}
/*
* If the next pattern character is '\', just strip off the '\'
* so we do exact matching on the character that follows.
*/
if (p == '\\') {
if (*(++pattern) == '\0') {
return 0;
}
}
/*
* There's no special character. Just make sure that the next
* bytes of each string match.
*/
if (nocase) {
if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) {
return 0;
}
} else if (*string != *pattern) {
return 0;
}
string++;
pattern++;
}
}
/*
*----------------------------------------------------------------------
*
* TclUniCharMatch --
*
* See if a particular Unicode string matches a particular pattern.
* Allows case insensitivity. This is the Unicode equivalent of the
* char* Tcl_StringCaseMatch. This variant of Tcl_UniCharCaseMatch
* uses counted Strings, so embedded NULLs are allowed.
*
* Results:
* The return value is 1 if string matches pattern, and
* 0 otherwise. The matching operation permits the following
* special characters in the pattern: *?\[] (see the manual
* entry for details on what these mean).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclUniCharMatch(string, strLen, pattern, ptnLen, nocase)
CONST Tcl_UniChar *string; /* Unicode String. */
int strLen; /* length of String */
CONST Tcl_UniChar *pattern; /* Pattern, which may contain special
* characters. */
int ptnLen; /* length of Pattern */
int nocase; /* 0 for case sensitive, 1 for insensitive */
{
CONST Tcl_UniChar *stringEnd, *patternEnd;
Tcl_UniChar p;
stringEnd = string + strLen;
patternEnd = pattern + ptnLen;
while (1) {
/*
* See if we're at the end of both the pattern and the string. If
* so, we succeeded. If we're at the end of the pattern but not at
* the end of the string, we failed.
*/
if (pattern == patternEnd) {
return (string == stringEnd);
}
p = *pattern;
if ((string == stringEnd) && (p != '*')) {
return 0;
}
/*
* Check for a "*" as the next pattern character. It matches any
* substring. We handle this by skipping all the characters up to the
* next matching one in the pattern, and then calling ourselves
* recursively for each postfix of string, until either we match or we
* reach the end of the string.
*/
if (p == '*') {
/*
* Skip all successive *'s in the pattern
*/
while (*(++pattern) == '*') {}
if (pattern == patternEnd) {
return 1;
}
p = *pattern;
if (nocase) {
p = Tcl_UniCharToLower(p);
}
while (1) {
/*
* Optimization for matching - cruise through the string
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while ((string < stringEnd) && (p != *string)
&& (p != Tcl_UniCharToLower(*string))) {
string++;
}
} else {
while ((string < stringEnd) && (p != *string)) {
string++;
}
}
}
if (TclUniCharMatch(string, stringEnd - string,
pattern, patternEnd - pattern, nocase)) {
return 1;
}
if (string == stringEnd) {
return 0;
}
string++;
}
}
/*
* Check for a "?" as the next pattern character. It matches
* any single character.
*/
if (p == '?') {
pattern++;
string++;
continue;
}
/*
* Check for a "[" as the next pattern character. It is followed
* by a list of characters that are acceptable, or by a range
* (two characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar ch1, startChar, endChar;
pattern++;
ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string);
string++;
while (1) {
if ((*pattern == ']') || (pattern == patternEnd)) {
return 0;
}
startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern);
pattern++;
if (*pattern == '-') {
pattern++;
if (pattern == patternEnd) {
return 0;
}
endChar = (nocase ? Tcl_UniCharToLower(*pattern)
: *pattern);
pattern++;
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
break;
}
} else if (startChar == ch1) {
break;
}
}
while (*pattern != ']') {
if (pattern == patternEnd) {
pattern--;
break;
}
pattern++;
}
pattern++;
continue;
}
/*
* If the next pattern character is '\', just strip off the '\'
* so we do exact matching on the character that follows.
*/
if (p == '\\') {
if (++pattern == patternEnd) {
return 0;
}
}
/*
* There's no special character. Just make sure that the next
* bytes of each string match.
*/
if (nocase) {
if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) {
return 0;
}
} else if (*string != *pattern) {
return 0;
}
string++;
pattern++;
}
}
tcl8.4.20/generic/rege_dfa.c 0000644 0036047 0045461 00000042704 11737050674 014242 0 ustar dgp 771div /*
* DFA routines
* This file is #included by regexec.c.
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*/
/*
- longest - longest-preferred matching engine
^ static chr *longest(struct vars *, struct dfa *, chr *, chr *, int *);
*/
static chr * /* endpoint, or NULL */
longest(v, d, start, stop, hitstopp)
struct vars *v; /* used only for debug and exec flags */
struct dfa *d;
chr *start; /* where the match should start */
chr *stop; /* match must end at or before here */
int *hitstopp; /* record whether hit v->stop, if non-NULL */
{
chr *cp;
chr *realstop = (stop == v->stop) ? stop : stop + 1;
color co;
struct sset *css;
struct sset *ss;
chr *post;
int i;
struct colormap *cm = d->cm;
/* initialize */
css = initialize(v, d, start);
cp = start;
if (hitstopp != NULL)
*hitstopp = 0;
/* startup */
FDEBUG(("+++ startup +++\n"));
if (cp == v->start) {
co = d->cnfa->bos[(v->eflags®_NOTBOL) ? 0 : 1];
FDEBUG(("color %ld\n", (long)co));
} else {
co = GETCOLOR(cm, *(cp - 1));
FDEBUG(("char %c, color %ld\n", (char)*(cp-1), (long)co));
}
css = miss(v, d, css, co, cp, start);
if (css == NULL)
return NULL;
css->lastseen = cp;
/* main loop */
if (v->eflags®_FTRACE)
while (cp < realstop) {
FDEBUG(("+++ at c%d +++\n", css - d->ssets));
co = GETCOLOR(cm, *cp);
FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co));
ss = css->outs[co];
if (ss == NULL) {
ss = miss(v, d, css, co, cp+1, start);
if (ss == NULL)
break; /* NOTE BREAK OUT */
}
cp++;
ss->lastseen = cp;
css = ss;
}
else
while (cp < realstop) {
co = GETCOLOR(cm, *cp);
ss = css->outs[co];
if (ss == NULL) {
ss = miss(v, d, css, co, cp+1, start);
if (ss == NULL)
break; /* NOTE BREAK OUT */
}
cp++;
ss->lastseen = cp;
css = ss;
}
/* shutdown */
FDEBUG(("+++ shutdown at c%d +++\n", css - d->ssets));
if (cp == v->stop && stop == v->stop) {
if (hitstopp != NULL)
*hitstopp = 1;
co = d->cnfa->eos[(v->eflags®_NOTEOL) ? 0 : 1];
FDEBUG(("color %ld\n", (long)co));
ss = miss(v, d, css, co, cp, start);
/* special case: match ended at eol? */
if (ss != NULL && (ss->flags&POSTSTATE))
return cp;
else if (ss != NULL)
ss->lastseen = cp; /* to be tidy */
}
/* find last match, if any */
post = d->lastpost;
for (ss = d->ssets, i = d->nssused; i > 0; ss++, i--)
if ((ss->flags&POSTSTATE) && post != ss->lastseen &&
(post == NULL || post < ss->lastseen))
post = ss->lastseen;
if (post != NULL) /* found one */
return post - 1;
return NULL;
}
/*
- shortest - shortest-preferred matching engine
^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *,
^ chr **, int *);
*/
static chr * /* endpoint, or NULL */
shortest(v, d, start, min, max, coldp, hitstopp)
struct vars *v;
struct dfa *d;
chr *start; /* where the match should start */
chr *min; /* match must end at or after here */
chr *max; /* match must end at or before here */
chr **coldp; /* store coldstart pointer here, if nonNULL */
int *hitstopp; /* record whether hit v->stop, if non-NULL */
{
chr *cp;
chr *realmin = (min == v->stop) ? min : min + 1;
chr *realmax = (max == v->stop) ? max : max + 1;
color co;
struct sset *css;
struct sset *ss;
struct colormap *cm = d->cm;
/* initialize */
css = initialize(v, d, start);
cp = start;
if (hitstopp != NULL)
*hitstopp = 0;
/* startup */
FDEBUG(("--- startup ---\n"));
if (cp == v->start) {
co = d->cnfa->bos[(v->eflags®_NOTBOL) ? 0 : 1];
FDEBUG(("color %ld\n", (long)co));
} else {
co = GETCOLOR(cm, *(cp - 1));
FDEBUG(("char %c, color %ld\n", (char)*(cp-1), (long)co));
}
css = miss(v, d, css, co, cp, start);
if (css == NULL)
return NULL;
css->lastseen = cp;
ss = css;
/* main loop */
if (v->eflags®_FTRACE)
while (cp < realmax) {
FDEBUG(("--- at c%d ---\n", css - d->ssets));
co = GETCOLOR(cm, *cp);
FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co));
ss = css->outs[co];
if (ss == NULL) {
ss = miss(v, d, css, co, cp+1, start);
if (ss == NULL)
break; /* NOTE BREAK OUT */
}
cp++;
ss->lastseen = cp;
css = ss;
if ((ss->flags&POSTSTATE) && cp >= realmin)
break; /* NOTE BREAK OUT */
}
else
while (cp < realmax) {
co = GETCOLOR(cm, *cp);
ss = css->outs[co];
if (ss == NULL) {
ss = miss(v, d, css, co, cp+1, start);
if (ss == NULL)
break; /* NOTE BREAK OUT */
}
cp++;
ss->lastseen = cp;
css = ss;
if ((ss->flags&POSTSTATE) && cp >= realmin)
break; /* NOTE BREAK OUT */
}
if (ss == NULL)
return NULL;
if (coldp != NULL) /* report last no-progress state set, if any */
*coldp = lastcold(v, d);
if ((ss->flags&POSTSTATE) && cp > min) {
assert(cp >= realmin);
cp--;
} else if (cp == v->stop && max == v->stop) {
co = d->cnfa->eos[(v->eflags®_NOTEOL) ? 0 : 1];
FDEBUG(("color %ld\n", (long)co));
ss = miss(v, d, css, co, cp, start);
/* match might have ended at eol */
if ((ss == NULL || !(ss->flags&POSTSTATE)) && hitstopp != NULL)
*hitstopp = 1;
}
if (ss == NULL || !(ss->flags&POSTSTATE))
return NULL;
return cp;
}
/*
- lastcold - determine last point at which no progress had been made
^ static chr *lastcold(struct vars *, struct dfa *);
*/
static chr * /* endpoint, or NULL */
lastcold(v, d)
struct vars *v;
struct dfa *d;
{
struct sset *ss;
chr *nopr;
int i;
nopr = d->lastnopr;
if (nopr == NULL)
nopr = v->start;
for (ss = d->ssets, i = d->nssused; i > 0; ss++, i--)
if ((ss->flags&NOPROGRESS) && nopr < ss->lastseen)
nopr = ss->lastseen;
return nopr;
}
/*
- newdfa - set up a fresh DFA
^ static struct dfa *newdfa(struct vars *, struct cnfa *,
^ struct colormap *, struct smalldfa *);
*/
static struct dfa *
newdfa(v, cnfa, cm, small)
struct vars *v;
struct cnfa *cnfa;
struct colormap *cm;
struct smalldfa *small; /* preallocated space, may be NULL */
{
struct dfa *d;
size_t nss = cnfa->nstates * 2;
int wordsper = (cnfa->nstates + UBITS - 1) / UBITS;
struct smalldfa *smallwas = small;
assert(cnfa != NULL && cnfa->nstates != 0);
if (nss <= FEWSTATES && cnfa->ncolors <= FEWCOLORS) {
assert(wordsper == 1);
if (small == NULL) {
small = (struct smalldfa *)MALLOC(
sizeof(struct smalldfa));
if (small == NULL) {
ERR(REG_ESPACE);
return NULL;
}
}
d = &small->dfa;
d->ssets = small->ssets;
d->statesarea = small->statesarea;
d->work = &d->statesarea[nss];
d->outsarea = small->outsarea;
d->incarea = small->incarea;
d->cptsmalloced = 0;
d->mallocarea = (smallwas == NULL) ? (char *)small : NULL;
} else {
d = (struct dfa *)MALLOC(sizeof(struct dfa));
if (d == NULL) {
ERR(REG_ESPACE);
return NULL;
}
d->ssets = (struct sset *)MALLOC(nss * sizeof(struct sset));
d->statesarea = (unsigned *)MALLOC((nss+WORK) * wordsper *
sizeof(unsigned));
d->work = &d->statesarea[nss * wordsper];
d->outsarea = (struct sset **)MALLOC(nss * cnfa->ncolors *
sizeof(struct sset *));
d->incarea = (struct arcp *)MALLOC(nss * cnfa->ncolors *
sizeof(struct arcp));
d->cptsmalloced = 1;
d->mallocarea = (char *)d;
if (d->ssets == NULL || d->statesarea == NULL ||
d->outsarea == NULL || d->incarea == NULL) {
freedfa(d);
ERR(REG_ESPACE);
return NULL;
}
}
d->nssets = (v->eflags®_SMALL) ? 7 : nss;
d->nssused = 0;
d->nstates = cnfa->nstates;
d->ncolors = cnfa->ncolors;
d->wordsper = wordsper;
d->cnfa = cnfa;
d->cm = cm;
d->lastpost = NULL;
d->lastnopr = NULL;
d->search = d->ssets;
/* initialization of sset fields is done as needed */
return d;
}
/*
- freedfa - free a DFA
^ static VOID freedfa(struct dfa *);
*/
static VOID
freedfa(d)
struct dfa *d;
{
if (d->cptsmalloced) {
if (d->ssets != NULL)
FREE(d->ssets);
if (d->statesarea != NULL)
FREE(d->statesarea);
if (d->outsarea != NULL)
FREE(d->outsarea);
if (d->incarea != NULL)
FREE(d->incarea);
}
if (d->mallocarea != NULL)
FREE(d->mallocarea);
}
/*
- hash - construct a hash code for a bitvector
* There are probably better ways, but they're more expensive.
^ static unsigned hash(unsigned *, int);
*/
static unsigned
hash(uv, n)
unsigned *uv;
int n;
{
int i;
unsigned h;
h = 0;
for (i = 0; i < n; i++)
h ^= uv[i];
return h;
}
/*
- initialize - hand-craft a cache entry for startup, otherwise get ready
^ static struct sset *initialize(struct vars *, struct dfa *, chr *);
*/
static struct sset *
initialize(v, d, start)
struct vars *v; /* used only for debug flags */
struct dfa *d;
chr *start;
{
struct sset *ss;
int i;
/* is previous one still there? */
if (d->nssused > 0 && (d->ssets[0].flags&STARTER))
ss = &d->ssets[0];
else { /* no, must (re)build it */
ss = getvacant(v, d, start, start);
for (i = 0; i < d->wordsper; i++)
ss->states[i] = 0;
BSET(ss->states, d->cnfa->pre);
ss->hash = HASH(ss->states, d->wordsper);
assert(d->cnfa->pre != d->cnfa->post);
ss->flags = STARTER|LOCKED|NOPROGRESS;
/* lastseen dealt with below */
}
for (i = 0; i < d->nssused; i++)
d->ssets[i].lastseen = NULL;
ss->lastseen = start; /* maybe untrue, but harmless */
d->lastpost = NULL;
d->lastnopr = NULL;
return ss;
}
/*
- miss - handle a cache miss
^ static struct sset *miss(struct vars *, struct dfa *, struct sset *,
^ pcolor, chr *, chr *);
*/
static struct sset * /* NULL if goes to empty set */
miss(v, d, css, co, cp, start)
struct vars *v; /* used only for debug flags */
struct dfa *d;
struct sset *css;
pcolor co;
chr *cp; /* next chr */
chr *start; /* where the attempt got started */
{
struct cnfa *cnfa = d->cnfa;
int i;
unsigned h;
struct carc *ca;
struct sset *p;
int ispost;
int noprogress;
int gotstate;
int dolacons;
int sawlacons;
/* for convenience, we can be called even if it might not be a miss */
if (css->outs[co] != NULL) {
FDEBUG(("hit\n"));
return css->outs[co];
}
FDEBUG(("miss\n"));
/* first, what set of states would we end up in? */
for (i = 0; i < d->wordsper; i++)
d->work[i] = 0;
ispost = 0;
noprogress = 1;
gotstate = 0;
for (i = 0; i < d->nstates; i++)
if (ISBSET(css->states, i))
for (ca = cnfa->states[i]+1; ca->co != COLORLESS; ca++)
if (ca->co == co) {
BSET(d->work, ca->to);
gotstate = 1;
if (ca->to == cnfa->post)
ispost = 1;
if (!cnfa->states[ca->to]->co)
noprogress = 0;
FDEBUG(("%d -> %d\n", i, ca->to));
}
dolacons = (gotstate) ? (cnfa->flags&HASLACONS) : 0;
sawlacons = 0;
while (dolacons) { /* transitive closure */
dolacons = 0;
for (i = 0; i < d->nstates; i++)
if (ISBSET(d->work, i))
for (ca = cnfa->states[i]+1; ca->co != COLORLESS;
ca++) {
if (ca->co <= cnfa->ncolors)
continue; /* NOTE CONTINUE */
sawlacons = 1;
if (ISBSET(d->work, ca->to))
continue; /* NOTE CONTINUE */
if (!lacon(v, cnfa, cp, ca->co))
continue; /* NOTE CONTINUE */
BSET(d->work, ca->to);
dolacons = 1;
if (ca->to == cnfa->post)
ispost = 1;
if (!cnfa->states[ca->to]->co)
noprogress = 0;
FDEBUG(("%d :> %d\n", i, ca->to));
}
}
if (!gotstate)
return NULL;
h = HASH(d->work, d->wordsper);
/* next, is that in the cache? */
for (p = d->ssets, i = d->nssused; i > 0; p++, i--)
if (HIT(h, d->work, p, d->wordsper)) {
FDEBUG(("cached c%d\n", p - d->ssets));
break; /* NOTE BREAK OUT */
}
if (i == 0) { /* nope, need a new cache entry */
p = getvacant(v, d, cp, start);
assert(p != css);
for (i = 0; i < d->wordsper; i++)
p->states[i] = d->work[i];
p->hash = h;
p->flags = (ispost) ? POSTSTATE : 0;
if (noprogress)
p->flags |= NOPROGRESS;
/* lastseen to be dealt with by caller */
}
if (!sawlacons) { /* lookahead conds. always cache miss */
FDEBUG(("c%d[%d]->c%d\n", css - d->ssets, co, p - d->ssets));
css->outs[co] = p;
css->inchain[co] = p->ins;
p->ins.ss = css;
p->ins.co = (color)co;
}
return p;
}
/*
- lacon - lookahead-constraint checker for miss()
^ static int lacon(struct vars *, struct cnfa *, chr *, pcolor);
*/
static int /* predicate: constraint satisfied? */
lacon(v, pcnfa, cp, co)
struct vars *v;
struct cnfa *pcnfa; /* parent cnfa */
chr *cp;
pcolor co; /* "color" of the lookahead constraint */
{
int n;
struct subre *sub;
struct dfa *d;
struct smalldfa sd;
chr *end;
n = co - pcnfa->ncolors;
assert(n < v->g->nlacons && v->g->lacons != NULL);
FDEBUG(("=== testing lacon %d\n", n));
sub = &v->g->lacons[n];
d = newdfa(v, &sub->cnfa, &v->g->cmap, &sd);
if (d == NULL) {
ERR(REG_ESPACE);
return 0;
}
end = longest(v, d, cp, v->stop, (int *)NULL);
freedfa(d);
FDEBUG(("=== lacon %d match %d\n", n, (end != NULL)));
return (sub->subno) ? (end != NULL) : (end == NULL);
}
/*
- getvacant - get a vacant state set
* This routine clears out the inarcs and outarcs, but does not otherwise
* clear the innards of the state set -- that's up to the caller.
^ static struct sset *getvacant(struct vars *, struct dfa *, chr *, chr *);
*/
static struct sset *
getvacant(v, d, cp, start)
struct vars *v; /* used only for debug flags */
struct dfa *d;
chr *cp;
chr *start;
{
int i;
struct sset *ss;
struct sset *p;
struct arcp ap;
struct arcp lastap = {NULL, 0}; /* silence gcc 4 warning */
color co;
ss = pickss(v, d, cp, start);
assert(!(ss->flags&LOCKED));
/* clear out its inarcs, including self-referential ones */
ap = ss->ins;
while ((p = ap.ss) != NULL) {
co = ap.co;
FDEBUG(("zapping c%d's %ld outarc\n", p - d->ssets, (long)co));
p->outs[co] = NULL;
ap = p->inchain[co];
p->inchain[co].ss = NULL; /* paranoia */
}
ss->ins.ss = NULL;
/* take it off the inarc chains of the ssets reached by its outarcs */
for (i = 0; i < d->ncolors; i++) {
p = ss->outs[i];
assert(p != ss); /* not self-referential */
if (p == NULL)
continue; /* NOTE CONTINUE */
FDEBUG(("del outarc %d from c%d's in chn\n", i, p - d->ssets));
if (p->ins.ss == ss && p->ins.co == i)
p->ins = ss->inchain[i];
else {
assert(p->ins.ss != NULL);
for (ap = p->ins; ap.ss != NULL &&
!(ap.ss == ss && ap.co == i);
ap = ap.ss->inchain[ap.co])
lastap = ap;
assert(ap.ss != NULL);
lastap.ss->inchain[lastap.co] = ss->inchain[i];
}
ss->outs[i] = NULL;
ss->inchain[i].ss = NULL;
}
/* if ss was a success state, may need to remember location */
if ((ss->flags&POSTSTATE) && ss->lastseen != d->lastpost &&
(d->lastpost == NULL || d->lastpost < ss->lastseen))
d->lastpost = ss->lastseen;
/* likewise for a no-progress state */
if ((ss->flags&NOPROGRESS) && ss->lastseen != d->lastnopr &&
(d->lastnopr == NULL || d->lastnopr < ss->lastseen))
d->lastnopr = ss->lastseen;
return ss;
}
/*
- pickss - pick the next stateset to be used
^ static struct sset *pickss(struct vars *, struct dfa *, chr *, chr *);
*/
static struct sset *
pickss(v, d, cp, start)
struct vars *v; /* used only for debug flags */
struct dfa *d;
chr *cp;
chr *start;
{
int i;
struct sset *ss;
struct sset *end;
chr *ancient;
/* shortcut for cases where cache isn't full */
if (d->nssused < d->nssets) {
i = d->nssused;
d->nssused++;
ss = &d->ssets[i];
FDEBUG(("new c%d\n", i));
/* set up innards */
ss->states = &d->statesarea[i * d->wordsper];
ss->flags = 0;
ss->ins.ss = NULL;
ss->ins.co = WHITE; /* give it some value */
ss->outs = &d->outsarea[i * d->ncolors];
ss->inchain = &d->incarea[i * d->ncolors];
for (i = 0; i < d->ncolors; i++) {
ss->outs[i] = NULL;
ss->inchain[i].ss = NULL;
}
return ss;
}
/* look for oldest, or old enough anyway */
if (cp - start > d->nssets*2/3) /* oldest 33% are expendable */
ancient = cp - d->nssets*2/3;
else
ancient = start;
for (ss = d->search, end = &d->ssets[d->nssets]; ss < end; ss++)
if ((ss->lastseen == NULL || ss->lastseen < ancient) &&
!(ss->flags&LOCKED)) {
d->search = ss + 1;
FDEBUG(("replacing c%d\n", ss - d->ssets));
return ss;
}
for (ss = d->ssets, end = d->search; ss < end; ss++)
if ((ss->lastseen == NULL || ss->lastseen < ancient) &&
!(ss->flags&LOCKED)) {
d->search = ss + 1;
FDEBUG(("replacing c%d\n", ss - d->ssets));
return ss;
}
/* nobody's old enough?!? -- something's really wrong */
FDEBUG(("can't find victim to replace!\n"));
assert(NOTREACHED);
ERR(REG_ASSERT);
return d->ssets;
}
tcl8.4.20/generic/tclNotify.c 0000644 0036047 0045461 00000075506 12052456744 014466 0 ustar dgp 771div /*
* tclNotify.c --
*
* This file implements the generic portion of the Tcl notifier.
* The notifier is lowest-level part of the event system. It
* manages an event queue that holds Tcl_Event structures. The
* platform specific portion of the notifier is defined in the
* tcl*Notify.c files in each platform directory.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1998 by Scriptics Corporation.
* Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
extern TclStubs tclStubs;
/*
* For each event source (created with Tcl_CreateEventSource) there
* is a structure of the following type:
*/
typedef struct EventSource {
Tcl_EventSetupProc *setupProc;
Tcl_EventCheckProc *checkProc;
ClientData clientData;
struct EventSource *nextPtr;
} EventSource;
/*
* The following structure keeps track of the state of the notifier on a
* per-thread basis. The first three elements keep track of the event queue.
* In addition to the first (next to be serviced) and last events in the queue,
* we keep track of a "marker" event. This provides a simple priority
* mechanism whereby events can be inserted at the front of the queue but
* behind all other high-priority events already in the queue (this is used for
* things like a sequence of Enter and Leave events generated during a grab in
* Tk). These elements are protected by the queueMutex so that any thread
* can queue an event on any notifier. Note that all of the values in this
* structure will be initialized to 0.
*/
typedef struct ThreadSpecificData {
Tcl_Event *firstEventPtr; /* First pending event, or NULL if none. */
Tcl_Event *lastEventPtr; /* Last pending event, or NULL if none. */
Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or
* NULL if none. */
Tcl_Mutex queueMutex; /* Mutex to protect access to the previous
* three fields. */
int serviceMode; /* One of TCL_SERVICE_NONE or
* TCL_SERVICE_ALL. */
int blockTimeSet; /* 0 means there is no maximum block
* time: block forever. */
Tcl_Time blockTime; /* If blockTimeSet is 1, gives the
* maximum elapsed time for the next block. */
int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being
* called during an event source traversal. */
EventSource *firstEventSourcePtr;
/* Pointer to first event source in
* list of event sources for this thread. */
Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */
ClientData clientData; /* Opaque handle for platform specific
* notifier. */
int initialized; /* 1 if notifier has been initialized. */
struct ThreadSpecificData *nextPtr;
/* Next notifier in global list of notifiers.
* Access is controlled by the listLock global
* mutex. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Global list of notifiers. Access to this list is controlled by the
* listLock mutex. If this becomes a performance bottleneck, this could
* be replaced with a hashtable.
*/
static ThreadSpecificData *firstNotifierPtr;
TCL_DECLARE_MUTEX(listLock)
/*
* Declarations for routines used only in this file.
*/
static void QueueEvent _ANSI_ARGS_((ThreadSpecificData *tsdPtr,
Tcl_Event* evPtr, Tcl_QueuePosition position));
/*
*----------------------------------------------------------------------
*
* TclInitNotifier --
*
* Initialize the thread local data structures for the notifier
* subsystem.
*
* Results:
* None.
*
* Side effects:
* Adds the current thread to the global list of notifiers.
*
*----------------------------------------------------------------------
*/
void
TclInitNotifier()
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_MutexLock(&listLock);
tsdPtr->threadId = Tcl_GetCurrentThread();
tsdPtr->clientData = tclStubs.tcl_InitNotifier();
tsdPtr->initialized = 1;
tsdPtr->nextPtr = firstNotifierPtr;
firstNotifierPtr = tsdPtr;
Tcl_MutexUnlock(&listLock);
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeNotifier --
*
* Finalize the thread local data structures for the notifier
* subsystem.
*
* Results:
* None.
*
* Side effects:
* Removes the notifier associated with the current thread from
* the global notifier list. This is done only if the notifier
* was initialized for this thread by call to TclInitNotifier().
* This is always true for threads which have been seeded with
* an Tcl interpreter, since the call to Tcl_CreateInterp will,
* among other things, call TclInitializeSubsystems() and this
* one will, in turn, call the TclInitNotifier() for the thread.
* For threads created without the Tcl interpreter, though,
* nobody is explicitly nor implicitly calling the TclInitNotifier
* hence, TclFinalizeNotifier should not be performed at all.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeNotifier()
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadSpecificData **prevPtrPtr;
Tcl_Event *evPtr, *hold;
if (!tsdPtr->initialized) {
return; /* Notifier not initialized for the current thread */
}
Tcl_MutexLock(&(tsdPtr->queueMutex));
for (evPtr = tsdPtr->firstEventPtr; evPtr != (Tcl_Event *) NULL; ) {
hold = evPtr;
evPtr = evPtr->nextPtr;
ckfree((char *) hold);
}
tsdPtr->firstEventPtr = NULL;
tsdPtr->lastEventPtr = NULL;
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
Tcl_MutexLock(&listLock);
if (tclStubs.tcl_FinalizeNotifier) {
tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData);
}
Tcl_MutexFinalize(&(tsdPtr->queueMutex));
for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
if (*prevPtrPtr == tsdPtr) {
*prevPtrPtr = tsdPtr->nextPtr;
break;
}
}
tsdPtr->initialized = 0;
Tcl_MutexUnlock(&listLock);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetNotifier --
*
* Install a set of alternate functions for use with the notifier.
# In particular, this can be used to install the Xt-based
* notifier for use with the Browser plugin.
*
* Results:
* None.
*
* Side effects:
* Overstomps part of the stub vector. This relies on hooks
* added to the default procedures in case those are called
* directly (i.e., not through the stub table.)
*
*----------------------------------------------------------------------
*/
void
Tcl_SetNotifier(notifierProcPtr)
Tcl_NotifierProcs *notifierProcPtr;
{
#if !defined(__WIN32__) /* UNIX */
tclStubs.tcl_CreateFileHandler = notifierProcPtr->createFileHandlerProc;
tclStubs.tcl_DeleteFileHandler = notifierProcPtr->deleteFileHandlerProc;
#endif
tclStubs.tcl_SetTimer = notifierProcPtr->setTimerProc;
tclStubs.tcl_WaitForEvent = notifierProcPtr->waitForEventProc;
tclStubs.tcl_InitNotifier = notifierProcPtr->initNotifierProc;
tclStubs.tcl_FinalizeNotifier = notifierProcPtr->finalizeNotifierProc;
tclStubs.tcl_AlertNotifier = notifierProcPtr->alertNotifierProc;
tclStubs.tcl_ServiceModeHook = notifierProcPtr->serviceModeHookProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateEventSource --
*
* This procedure is invoked to create a new source of events.
* The source is identified by a procedure that gets invoked
* during Tcl_DoOneEvent to check for events on that source
* and queue them.
*
*
* Results:
* None.
*
* Side effects:
* SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent
* runs out of things to do. SetupProc will be invoked before
* Tcl_DoOneEvent calls select or whatever else it uses to wait
* for events. SetupProc typically calls functions like
* Tcl_SetMaxBlockTime to indicate what to wait for.
*
* CheckProc is called after select or whatever operation was actually
* used to wait. It figures out whether anything interesting actually
* happened (e.g. by calling Tcl_AsyncReady), and then calls
* Tcl_QueueEvent to queue any events that are ready.
*
* Each of these procedures is passed two arguments, e.g.
* (*checkProc)(ClientData clientData, int flags));
* ClientData is the same as the clientData argument here, and flags
* is a combination of things like TCL_FILE_EVENTS that indicates
* what events are of interest: setupProc and checkProc use flags
* to figure out whether their events are relevant or not.
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateEventSource(setupProc, checkProc, clientData)
Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out
* what to wait for. */
Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting
* to see what happened. */
ClientData clientData; /* One-word argument to pass to
* setupProc and checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource));
sourcePtr->setupProc = setupProc;
sourcePtr->checkProc = checkProc;
sourcePtr->clientData = clientData;
sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr;
tsdPtr->firstEventSourcePtr = sourcePtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteEventSource --
*
* This procedure is invoked to delete the source of events
* given by proc and clientData.
*
* Results:
* None.
*
* Side effects:
* The given event source is cancelled, so its procedure will
* never again be called. If no such source exists, nothing
* happens.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteEventSource(setupProc, checkProc, clientData)
Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out
* what to wait for. */
Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting
* to see what happened. */
ClientData clientData; /* One-word argument to pass to
* setupProc and checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
EventSource *sourcePtr, *prevPtr;
for (sourcePtr = tsdPtr->firstEventSourcePtr, prevPtr = NULL;
sourcePtr != NULL;
prevPtr = sourcePtr, sourcePtr = sourcePtr->nextPtr) {
if ((sourcePtr->setupProc != setupProc)
|| (sourcePtr->checkProc != checkProc)
|| (sourcePtr->clientData != clientData)) {
continue;
}
if (prevPtr == NULL) {
tsdPtr->firstEventSourcePtr = sourcePtr->nextPtr;
} else {
prevPtr->nextPtr = sourcePtr->nextPtr;
}
ckfree((char *) sourcePtr);
return;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_QueueEvent --
*
* Queue an event on the event queue associated with the
* current thread.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_QueueEvent(evPtr, position)
Tcl_Event* evPtr; /* Event to add to queue. The storage
* space must have been allocated the caller
* with malloc (ckalloc), and it becomes
* the property of the event queue. It
* will be freed after the event has been
* handled. */
Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
* TCL_QUEUE_MARK. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
QueueEvent(tsdPtr, evPtr, position);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ThreadQueueEvent --
*
* Queue an event on the specified thread's event queue.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_ThreadQueueEvent(threadId, evPtr, position)
Tcl_ThreadId threadId; /* Identifier for thread to use. */
Tcl_Event* evPtr; /* Event to add to queue. The storage
* space must have been allocated the caller
* with malloc (ckalloc), and it becomes
* the property of the event queue. It
* will be freed after the event has been
* handled. */
Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
* TCL_QUEUE_MARK. */
{
ThreadSpecificData *tsdPtr;
/*
* Find the notifier associated with the specified thread.
*/
Tcl_MutexLock(&listLock);
for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId;
tsdPtr = tsdPtr->nextPtr) {
/* Empty loop body. */
}
/*
* Queue the event if there was a notifier associated with the thread.
*/
if (tsdPtr) {
QueueEvent(tsdPtr, evPtr, position);
} else {
ckfree((char *) evPtr);
}
Tcl_MutexUnlock(&listLock);
}
/*
*----------------------------------------------------------------------
*
* QueueEvent --
*
* Insert an event into the specified thread's event queue at one
* of three positions: the head, the tail, or before a floating
* marker. Events inserted before the marker will be processed in
* first-in-first-out order, but before any events inserted at
* the tail of the queue. Events inserted at the head of the
* queue will be processed in last-in-first-out order.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
QueueEvent(tsdPtr, evPtr, position)
ThreadSpecificData *tsdPtr; /* Handle to thread local data that indicates
* which event queue to use. */
Tcl_Event* evPtr; /* Event to add to queue. The storage
* space must have been allocated the caller
* with malloc (ckalloc), and it becomes
* the property of the event queue. It
* will be freed after the event has been
* handled. */
Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
* TCL_QUEUE_MARK. */
{
Tcl_MutexLock(&(tsdPtr->queueMutex));
if (position == TCL_QUEUE_TAIL) {
/*
* Append the event on the end of the queue.
*/
evPtr->nextPtr = NULL;
if (tsdPtr->firstEventPtr == NULL) {
tsdPtr->firstEventPtr = evPtr;
} else {
tsdPtr->lastEventPtr->nextPtr = evPtr;
}
tsdPtr->lastEventPtr = evPtr;
} else if (position == TCL_QUEUE_HEAD) {
/*
* Push the event on the head of the queue.
*/
evPtr->nextPtr = tsdPtr->firstEventPtr;
if (tsdPtr->firstEventPtr == NULL) {
tsdPtr->lastEventPtr = evPtr;
}
tsdPtr->firstEventPtr = evPtr;
} else if (position == TCL_QUEUE_MARK) {
/*
* Insert the event after the current marker event and advance
* the marker to the new event.
*/
if (tsdPtr->markerEventPtr == NULL) {
evPtr->nextPtr = tsdPtr->firstEventPtr;
tsdPtr->firstEventPtr = evPtr;
} else {
evPtr->nextPtr = tsdPtr->markerEventPtr->nextPtr;
tsdPtr->markerEventPtr->nextPtr = evPtr;
}
tsdPtr->markerEventPtr = evPtr;
if (evPtr->nextPtr == NULL) {
tsdPtr->lastEventPtr = evPtr;
}
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteEvents --
*
* Calls a procedure for each event in the queue and deletes those
* for which the procedure returns 1. Events for which the
* procedure returns 0 are left in the queue. Operates on the
* queue associated with the current thread.
*
* Results:
* None.
*
* Side effects:
* Potentially removes one or more events from the event queue.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteEvents(proc, clientData)
Tcl_EventDeleteProc *proc; /* The procedure to call. */
ClientData clientData; /* type-specific data. */
{
Tcl_Event *evPtr, *prevPtr, *hold;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_MutexLock(&(tsdPtr->queueMutex));
for (prevPtr = (Tcl_Event *) NULL, evPtr = tsdPtr->firstEventPtr;
evPtr != (Tcl_Event *) NULL;
) {
if ((*proc) (evPtr, clientData) == 1) {
if (tsdPtr->firstEventPtr == evPtr) {
tsdPtr->firstEventPtr = evPtr->nextPtr;
} else {
prevPtr->nextPtr = evPtr->nextPtr;
}
if (evPtr->nextPtr == (Tcl_Event *) NULL) {
tsdPtr->lastEventPtr = prevPtr;
}
if (tsdPtr->markerEventPtr == evPtr) {
tsdPtr->markerEventPtr = prevPtr;
}
hold = evPtr;
evPtr = evPtr->nextPtr;
ckfree((char *) hold);
} else {
prevPtr = evPtr;
evPtr = evPtr->nextPtr;
}
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
}
/*
*----------------------------------------------------------------------
*
* Tcl_ServiceEvent --
*
* Process one event from the event queue, or invoke an
* asynchronous event handler. Operates on event queue for
* current thread.
*
* Results:
* The return value is 1 if the procedure actually found an event
* to process. If no processing occurred, then 0 is returned.
*
* Side effects:
* Invokes all of the event handlers for the highest priority
* event in the event queue. May collapse some events into a
* single event or discard stale events.
*
*----------------------------------------------------------------------
*/
int
Tcl_ServiceEvent(flags)
int flags; /* Indicates what events should be processed.
* May be any combination of TCL_WINDOW_EVENTS
* TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other
* flags defined elsewhere. Events not
* matching this will be skipped for processing
* later. */
{
Tcl_Event *evPtr, *prevPtr;
Tcl_EventProc *proc;
int result;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Asynchronous event handlers are considered to be the highest
* priority events, and so must be invoked before we process events
* on the event queue.
*/
if (Tcl_AsyncReady()) {
(void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
return 1;
}
/*
* No event flags is equivalent to TCL_ALL_EVENTS.
*/
if ((flags & TCL_ALL_EVENTS) == 0) {
flags |= TCL_ALL_EVENTS;
}
/*
* Loop through all the events in the queue until we find one
* that can actually be handled.
*/
Tcl_MutexLock(&(tsdPtr->queueMutex));
for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL;
evPtr = evPtr->nextPtr) {
/*
* Call the handler for the event. If it actually handles the
* event then free the storage for the event. There are two
* tricky things here, both stemming from the fact that the event
* code may be re-entered while servicing the event:
*
* 1. Set the "proc" field to NULL. This is a signal to ourselves
* that we shouldn't reexecute the handler if the event loop
* is re-entered.
* 2. When freeing the event, must search the queue again from the
* front to find it. This is because the event queue could
* change almost arbitrarily while handling the event, so we
* can't depend on pointers found now still being valid when
* the handler returns.
*/
proc = evPtr->proc;
if (proc == NULL) {
continue;
}
evPtr->proc = NULL;
/*
* Release the lock before calling the event procedure. This
* allows other threads to post events if we enter a recursive
* event loop in this thread. Note that we are making the assumption
* that if the proc returns 0, the event is still in the list.
*/
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
result = (*proc)(evPtr, flags);
Tcl_MutexLock(&(tsdPtr->queueMutex));
if (result) {
/*
* The event was processed, so remove it from the queue.
*/
if (tsdPtr->firstEventPtr == evPtr) {
tsdPtr->firstEventPtr = evPtr->nextPtr;
if (evPtr->nextPtr == NULL) {
tsdPtr->lastEventPtr = NULL;
}
if (tsdPtr->markerEventPtr == evPtr) {
tsdPtr->markerEventPtr = NULL;
}
} else {
for (prevPtr = tsdPtr->firstEventPtr;
prevPtr && prevPtr->nextPtr != evPtr;
prevPtr = prevPtr->nextPtr) {
/* Empty loop body. */
}
if (prevPtr) {
prevPtr->nextPtr = evPtr->nextPtr;
if (evPtr->nextPtr == NULL) {
tsdPtr->lastEventPtr = prevPtr;
}
if (tsdPtr->markerEventPtr == evPtr) {
tsdPtr->markerEventPtr = prevPtr;
}
} else {
evPtr = NULL;
}
}
if (evPtr) {
ckfree((char *) evPtr);
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return 1;
} else {
/*
* The event wasn't actually handled, so we have to restore
* the proc field to allow the event to be attempted again.
*/
evPtr->proc = proc;
}
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetServiceMode --
*
* This routine returns the current service mode of the notifier.
*
* Results:
* Returns either TCL_SERVICE_ALL or TCL_SERVICE_NONE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetServiceMode()
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
return tsdPtr->serviceMode;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetServiceMode --
*
* This routine sets the current service mode of the tsdPtr->
*
* Results:
* Returns the previous service mode.
*
* Side effects:
* Invokes the notifier service mode hook procedure.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetServiceMode(mode)
int mode; /* New service mode: TCL_SERVICE_ALL or
* TCL_SERVICE_NONE */
{
int oldMode;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
oldMode = tsdPtr->serviceMode;
tsdPtr->serviceMode = mode;
if (tclStubs.tcl_ServiceModeHook) {
tclStubs.tcl_ServiceModeHook(mode);
}
return oldMode;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetMaxBlockTime --
*
* This procedure is invoked by event sources to tell the notifier
* how long it may block the next time it blocks. The timePtr
* argument gives a maximum time; the actual time may be less if
* some other event source requested a smaller time.
*
* Results:
* None.
*
* Side effects:
* May reduce the length of the next sleep in the tsdPtr->
*
*----------------------------------------------------------------------
*/
void
Tcl_SetMaxBlockTime(timePtr)
Tcl_Time *timePtr; /* Specifies a maximum elapsed time for
* the next blocking operation in the
* event tsdPtr-> */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->blockTimeSet || (timePtr->sec < tsdPtr->blockTime.sec)
|| ((timePtr->sec == tsdPtr->blockTime.sec)
&& (timePtr->usec < tsdPtr->blockTime.usec))) {
tsdPtr->blockTime = *timePtr;
tsdPtr->blockTimeSet = 1;
}
/*
* If we are called outside an event source traversal, set the
* timeout immediately.
*/
if (!tsdPtr->inTraversal) {
if (tsdPtr->blockTimeSet) {
Tcl_SetTimer(&tsdPtr->blockTime);
} else {
Tcl_SetTimer(NULL);
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DoOneEvent --
*
* Process a single event of some sort. If there's no work to
* do, wait for an event to occur, then process it.
*
* Results:
* The return value is 1 if the procedure actually found an event
* to process. If no processing occurred, then 0 is returned (this
* can happen if the TCL_DONT_WAIT flag is set or if there are no
* event handlers to wait for in the set specified by flags).
*
* Side effects:
* May delay execution of process while waiting for an event,
* unless TCL_DONT_WAIT is set in the flags argument. Event
* sources are invoked to check for and queue events. Event
* handlers may produce arbitrary side effects.
*
*----------------------------------------------------------------------
*/
int
Tcl_DoOneEvent(flags)
int flags; /* Miscellaneous flag values: may be any
* combination of TCL_DONT_WAIT,
* TCL_WINDOW_EVENTS, TCL_FILE_EVENTS,
* TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, or
* others defined by event sources. */
{
int result = 0, oldMode;
EventSource *sourcePtr;
Tcl_Time *timePtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* The first thing we do is to service any asynchronous event
* handlers.
*/
if (Tcl_AsyncReady()) {
(void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
return 1;
}
/*
* No event flags is equivalent to TCL_ALL_EVENTS.
*/
if ((flags & TCL_ALL_EVENTS) == 0) {
flags |= TCL_ALL_EVENTS;
}
/*
* Set the service mode to none so notifier event routines won't
* try to service events recursively.
*/
oldMode = tsdPtr->serviceMode;
tsdPtr->serviceMode = TCL_SERVICE_NONE;
/*
* The core of this procedure is an infinite loop, even though
* we only service one event. The reason for this is that we
* may be processing events that don't do anything inside of Tcl.
*/
while (1) {
/*
* If idle events are the only things to service, skip the
* main part of the loop and go directly to handle idle
* events (i.e. don't wait even if TCL_DONT_WAIT isn't set).
*/
if ((flags & TCL_ALL_EVENTS) == TCL_IDLE_EVENTS) {
flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT;
goto idleEvents;
}
/*
* Ask Tcl to service a queued event, if there are any.
*/
if (Tcl_ServiceEvent(flags)) {
result = 1;
break;
}
/*
* If TCL_DONT_WAIT is set, be sure to poll rather than
* blocking, otherwise reset the block time to infinity.
*/
if (flags & TCL_DONT_WAIT) {
tsdPtr->blockTime.sec = 0;
tsdPtr->blockTime.usec = 0;
tsdPtr->blockTimeSet = 1;
} else {
tsdPtr->blockTimeSet = 0;
}
/*
* Set up all the event sources for new events. This will
* cause the block time to be updated if necessary.
*/
tsdPtr->inTraversal = 1;
for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->setupProc) {
(sourcePtr->setupProc)(sourcePtr->clientData, flags);
}
}
tsdPtr->inTraversal = 0;
if ((flags & TCL_DONT_WAIT) || tsdPtr->blockTimeSet) {
timePtr = &tsdPtr->blockTime;
} else {
timePtr = NULL;
}
/*
* Wait for a new event or a timeout. If Tcl_WaitForEvent
* returns -1, we should abort Tcl_DoOneEvent.
*/
result = Tcl_WaitForEvent(timePtr);
if (result < 0) {
result = 0;
break;
}
/*
* Check all the event sources for new events.
*/
for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->checkProc) {
(sourcePtr->checkProc)(sourcePtr->clientData, flags);
}
}
/*
* Check for events queued by the notifier or event sources.
*/
if (Tcl_ServiceEvent(flags)) {
result = 1;
break;
}
/*
* We've tried everything at this point, but nobody we know
* about had anything to do. Check for idle events. If none,
* either quit or go back to the top and try again.
*/
idleEvents:
if (flags & TCL_IDLE_EVENTS) {
if (TclServiceIdle()) {
result = 1;
break;
}
}
if (flags & TCL_DONT_WAIT) {
break;
}
/*
* If Tcl_WaitForEvent has returned 1,
* indicating that one system event has been dispatched
* (and thus that some Tcl code might have been indirectly executed),
* we break out of the loop.
* We do this to give VwaitCmd for instance a chance to check
* if that system event had the side effect of changing the
* variable (so the vwait can return and unwind properly).
*
* NB: We will process idle events if any first, because
* otherwise we might never do the idle events if the notifier
* always gets system events.
*/
if (result) {
break;
}
}
tsdPtr->serviceMode = oldMode;
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ServiceAll --
*
* This routine checks all of the event sources, processes
* events that are on the Tcl event queue, and then calls the
* any idle handlers. Platform specific notifier callbacks that
* generate events should call this routine before returning to
* the system in order to ensure that Tcl gets a chance to
* process the new events.
*
* Results:
* Returns 1 if an event or idle handler was invoked, else 0.
*
* Side effects:
* Anything that an event or idle handler may do.
*
*----------------------------------------------------------------------
*/
int
Tcl_ServiceAll()
{
int result = 0;
EventSource *sourcePtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->serviceMode == TCL_SERVICE_NONE) {
return result;
}
/*
* We need to turn off event servicing like we to in Tcl_DoOneEvent,
* to avoid recursive calls.
*/
tsdPtr->serviceMode = TCL_SERVICE_NONE;
/*
* Check async handlers first.
*/
if (Tcl_AsyncReady()) {
(void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
}
/*
* Make a single pass through all event sources, queued events,
* and idle handlers. Note that we wait to update the notifier
* timer until the end so we can avoid multiple changes.
*/
tsdPtr->inTraversal = 1;
tsdPtr->blockTimeSet = 0;
for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->setupProc) {
(sourcePtr->setupProc)(sourcePtr->clientData, TCL_ALL_EVENTS);
}
}
for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->checkProc) {
(sourcePtr->checkProc)(sourcePtr->clientData, TCL_ALL_EVENTS);
}
}
while (Tcl_ServiceEvent(0)) {
result = 1;
}
if (TclServiceIdle()) {
result = 1;
}
if (!tsdPtr->blockTimeSet) {
Tcl_SetTimer(NULL);
} else {
Tcl_SetTimer(&tsdPtr->blockTime);
}
tsdPtr->inTraversal = 0;
tsdPtr->serviceMode = TCL_SERVICE_ALL;
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ThreadAlert --
*
* This function wakes up the notifier associated with the
* specified thread (if there is one).
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_ThreadAlert(threadId)
Tcl_ThreadId threadId; /* Identifier for thread to use. */
{
ThreadSpecificData *tsdPtr;
/*
* Find the notifier associated with the specified thread.
* Note that we need to hold the listLock while calling
* Tcl_AlertNotifier to avoid a race condition where
* the specified thread might destroy its notifier.
*/
Tcl_MutexLock(&listLock);
for (tsdPtr = firstNotifierPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
if (tsdPtr->threadId == threadId) {
if (tclStubs.tcl_AlertNotifier) {
tclStubs.tcl_AlertNotifier(tsdPtr->clientData);
}
break;
}
}
Tcl_MutexUnlock(&listLock);
}
tcl8.4.20/generic/regcustom.h 0000644 0036047 0045461 00000010156 11737050674 014517 0 ustar dgp 771div /*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
/* headers if any */
#include "tclInt.h"
/* overrides for regguts.h definitions, if any */
#define FUNCPTR(name, args) (*name) _ANSI_ARGS_(args)
#define MALLOC(n) ckalloc(n)
#define FREE(p) ckfree(VS(p))
#define REALLOC(p,n) ckrealloc(VS(p),n)
/*
* Do not insert extras between the "begin" and "end" lines -- this
* chunk is automatically extracted to be fitted into regex.h.
*/
/* --- begin --- */
/* ensure certain things don't sneak in from system headers */
#ifdef __REG_WIDE_T
#undef __REG_WIDE_T
#endif
#ifdef __REG_WIDE_COMPILE
#undef __REG_WIDE_COMPILE
#endif
#ifdef __REG_WIDE_EXEC
#undef __REG_WIDE_EXEC
#endif
#ifdef __REG_REGOFF_T
#undef __REG_REGOFF_T
#endif
#ifdef __REG_VOID_T
#undef __REG_VOID_T
#endif
#ifdef __REG_CONST
#undef __REG_CONST
#endif
#ifdef __REG_NOFRONT
#undef __REG_NOFRONT
#endif
#ifdef __REG_NOCHAR
#undef __REG_NOCHAR
#endif
/* interface types */
#define __REG_WIDE_T Tcl_UniChar
#define __REG_REGOFF_T long /* not really right, but good enough... */
#define __REG_VOID_T VOID
#define __REG_CONST CONST
/* names and declarations */
#define __REG_WIDE_COMPILE TclReComp
#define __REG_WIDE_EXEC TclReExec
#define __REG_NOFRONT /* don't want regcomp() and regexec() */
#define __REG_NOCHAR /* or the char versions */
#define regfree TclReFree
#define regerror TclReError
/* --- end --- */
/* internal character type and related */
typedef Tcl_UniChar chr; /* the type itself */
typedef int pchr; /* what it promotes to */
typedef unsigned uchr; /* unsigned type that will hold a chr */
typedef int celt; /* type to hold chr, MCCE number, or NOCELT */
#define NOCELT (-1) /* celt value which is not valid chr or MCCE */
#define CHR(c) (UCHAR(c)) /* turn char literal into chr literal */
#define DIGITVAL(c) ((c)-'0') /* turn chr digit into its value */
#if TCL_UTF_MAX > 4
#define CHRBITS 32 /* bits in a chr; must not use sizeof */
#define CHR_MIN 0x00000000 /* smallest and largest chr; the value */
#define CHR_MAX 0xffffffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */
#else
#define CHRBITS 16 /* bits in a chr; must not use sizeof */
#define CHR_MIN 0x0000 /* smallest and largest chr; the value */
#define CHR_MAX 0xffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */
#endif
/* functions operating on chr */
#define iscalnum(x) Tcl_UniCharIsAlnum(x)
#define iscalpha(x) Tcl_UniCharIsAlpha(x)
#define iscdigit(x) Tcl_UniCharIsDigit(x)
#define iscspace(x) Tcl_UniCharIsSpace(x)
/* name the external functions */
#define compile TclReComp
#define exec TclReExec
/* enable/disable debugging code (by whether REG_DEBUG is defined or not) */
#if 0 /* no debug unless requested by makefile */
#define REG_DEBUG /* */
#endif
/* and pick up the standard header */
#include "regex.h"
tcl8.4.20/generic/tclCkalloc.c 0000644 0036047 0045461 00000101313 12133546537 014550 0 ustar dgp 771div /*
* tclCkalloc.c --
*
* Interface to malloc and free that provides support for debugging problems
* involving overwritten, double freeing memory and loss of memory.
*
* Copyright (c) 1991-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* This code contributed by Karl Lehenbauer and Mark Diekhans
*/
#include "tclInt.h"
#include "tclPort.h"
#define FALSE 0
#define TRUE 1
#ifdef TCL_MEM_DEBUG
/*
* One of the following structures is allocated each time the
* "memory tag" command is invoked, to hold the current tag.
*/
typedef struct MemTag {
int refCount; /* Number of mem_headers referencing
* this tag. */
char string[4]; /* Actual size of string will be as
* large as needed for actual tag. This
* must be the last field in the structure. */
} MemTag;
#define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3)
static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers
* (set by "memory tag" command). */
/*
* One of the following structures is allocated just before each
* dynamically allocated chunk of memory, both to record information
* about the chunk and to help detect chunk under-runs.
*/
#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)
struct mem_header {
struct mem_header *flink;
struct mem_header *blink;
MemTag *tagPtr; /* Tag from "memory tag" command; may be
* NULL. */
CONST char *file;
long length;
int line;
unsigned char low_guard[LOW_GUARD_SIZE];
/* Aligns body on 8-byte boundary, plus
* provides at least 8 additional guard bytes
* to detect underruns. */
char body[1]; /* First byte of client's space. Actual
* size of this field will be larger than
* one. */
};
static struct mem_header *allocHead = NULL; /* List of allocated structures */
#define GUARD_VALUE 0141
/*
* The following macro determines the amount of guard space *above* each
* chunk of memory.
*/
#define HIGH_GUARD_SIZE 8
/*
* The following macro computes the offset of the "body" field within
* mem_header. It is used to get back to the header pointer from the
* body pointer that's used by clients.
*/
#define BODY_OFFSET \
((size_t) (&((struct mem_header *) 0)->body))
static int total_mallocs = 0;
static int total_frees = 0;
static int current_bytes_malloced = 0;
static int maximum_bytes_malloced = 0;
static int current_malloc_packets = 0;
static int maximum_malloc_packets = 0;
static int break_on_malloc = 0;
static int trace_on_at_malloc = 0;
static int alloc_tracing = FALSE;
static int init_malloced_bodies = TRUE;
#ifdef MEM_VALIDATE
static int validate_memory = TRUE;
#else
static int validate_memory = FALSE;
#endif
/*
* The following variable indicates to TclFinalizeMemorySubsystem()
* that it should dump out the state of memory before exiting. If the
* value is non-NULL, it gives the name of the file in which to
* dump memory usage information.
*/
char *tclMemDumpFileName = NULL;
static char *onExitMemDumpFileName = NULL;
static char dumpFile[100]; /* Records where to dump memory allocation
* information. */
/*
* Mutex to serialize allocations. This is a low-level mutex that must
* be explicitly initialized. This is necessary because the self
* initializing mutexes use ckalloc...
*/
static Tcl_Mutex *ckallocMutexPtr;
static int ckallocInit = 0;
/*
* Prototypes for procedures defined in this file:
*/
static int CheckmemCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char *argv[]));
static int MemoryCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static void ValidateMemory _ANSI_ARGS_((
struct mem_header *memHeaderP, CONST char *file,
int line, int nukeGuards));
/*
*----------------------------------------------------------------------
*
* TclInitDbCkalloc --
* Initialize the locks used by the allocator.
* This is only appropriate to call in a single threaded environment,
* such as during TclInitSubsystems.
*
*----------------------------------------------------------------------
*/
void
TclInitDbCkalloc()
{
if (!ckallocInit) {
ckallocInit = 1;
ckallocMutexPtr = Tcl_GetAllocMutex();
#ifndef TCL_THREADS
/* Silence compiler warning */
(void)ckallocMutexPtr;
#endif
}
}
/*
*----------------------------------------------------------------------
*
* TclDumpMemoryInfo --
* Display the global memory management statistics.
*
*----------------------------------------------------------------------
*/
void
TclDumpMemoryInfo(outFile)
FILE *outFile;
{
fprintf(outFile,"total mallocs %10d\n",
total_mallocs);
fprintf(outFile,"total frees %10d\n",
total_frees);
fprintf(outFile,"current packets allocated %10d\n",
current_malloc_packets);
fprintf(outFile,"current bytes allocated %10d\n",
current_bytes_malloced);
fprintf(outFile,"maximum packets allocated %10d\n",
maximum_malloc_packets);
fprintf(outFile,"maximum bytes allocated %10d\n",
maximum_bytes_malloced);
}
/*
*----------------------------------------------------------------------
*
* ValidateMemory --
*
* Validate memory guard zones for a particular chunk of allocated
* memory.
*
* Results:
* None.
*
* Side effects:
* Prints validation information about the allocated memory to stderr.
*
*----------------------------------------------------------------------
*/
static void
ValidateMemory(memHeaderP, file, line, nukeGuards)
struct mem_header *memHeaderP; /* Memory chunk to validate */
CONST char *file; /* File containing the call to
* Tcl_ValidateAllMemory */
int line; /* Line number of call to
* Tcl_ValidateAllMemory */
int nukeGuards; /* If non-zero, indicates that the
* memory guards are to be reset to 0
* after they have been printed */
{
unsigned char *hiPtr;
int idx;
int guard_failed = FALSE;
int byte;
for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
byte = *(memHeaderP->low_guard + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush(stdout);
byte &= 0xff;
fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte,
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
if (guard_failed) {
TclDumpMemoryInfo (stderr);
fprintf(stderr, "low guard failed at %lx, %s %d\n",
(long unsigned int) memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
memHeaderP->file, memHeaderP->line);
panic ("Memory validation failure");
}
hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {
byte = *(hiPtr + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush (stdout);
byte &= 0xff;
fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte,
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
if (guard_failed) {
TclDumpMemoryInfo (stderr);
fprintf(stderr, "high guard failed at %lx, %s %d\n",
(long unsigned int) memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
fprintf(stderr, "%ld bytes allocated at (%s %d)\n",
memHeaderP->length, memHeaderP->file,
memHeaderP->line);
panic("Memory validation failure");
}
if (nukeGuards) {
memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE);
memset ((char *) hiPtr, 0, HIGH_GUARD_SIZE);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ValidateAllMemory --
*
* Validate memory guard regions for all allocated memory.
*
* Results:
* None.
*
* Side effects:
* Displays memory validation information to stderr.
*
*----------------------------------------------------------------------
*/
void
Tcl_ValidateAllMemory (file, line)
CONST char *file; /* File from which Tcl_ValidateAllMemory was called */
int line; /* Line number of call to Tcl_ValidateAllMemory */
{
struct mem_header *memScanP;
if (!ckallocInit) {
TclInitDbCkalloc();
}
Tcl_MutexLock(ckallocMutexPtr);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
ValidateMemory(memScanP, file, line, FALSE);
}
Tcl_MutexUnlock(ckallocMutexPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DumpActiveMemory --
*
* Displays all allocated memory to a file; if no filename is given,
* information will be written to stderr.
*
* Results:
* Return TCL_ERROR if an error accessing the file occurs, `errno'
* will have the file error number left in it.
*----------------------------------------------------------------------
*/
int
Tcl_DumpActiveMemory (fileName)
CONST char *fileName; /* Name of the file to write info to */
{
FILE *fileP;
struct mem_header *memScanP;
char *address;
if (fileName == NULL) {
fileP = stderr;
} else {
fileP = fopen(fileName, "w");
if (fileP == NULL) {
return TCL_ERROR;
}
}
Tcl_MutexLock(ckallocMutexPtr);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
address = &memScanP->body [0];
fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s",
(long unsigned int) address,
(long unsigned int) address + memScanP->length - 1,
memScanP->length, memScanP->file, memScanP->line,
(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
(void) fputc('\n', fileP);
}
Tcl_MutexUnlock(ckallocMutexPtr);
if (fileP != stderr) {
fclose (fileP);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbCkalloc - debugging ckalloc
*
* Allocate the requested amount of space plus some extra for
* guard bands at both ends of the request, plus a size, panicing
* if there isn't enough space, then write in the guard bands
* and return the address of the space in the middle that the
* user asked for.
*
* The second and third arguments are file and line, these contain
* the filename and line number corresponding to the caller.
* These are sent by the ckalloc macro; it uses the preprocessor
* autodefines __FILE__ and __LINE__.
*
*----------------------------------------------------------------------
*/
char *
Tcl_DbCkalloc(size, file, line)
unsigned int size;
CONST char *file;
int line;
{
struct mem_header *result = NULL;
if (validate_memory)
Tcl_ValidateAllMemory (file, line);
/* Don't let size argument to TclpAlloc overflow */
if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) {
result = (struct mem_header *) TclpAlloc((unsigned)size +
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
}
if (result == NULL) {
fflush(stdout);
TclDumpMemoryInfo(stderr);
panic("unable to alloc %u bytes, %s line %d", size, file, line);
}
/*
* Fill in guard zones and size. Also initialize the contents of
* the block with bogus bytes to detect uses of initialized data.
* Link into allocated list.
*/
if (init_malloced_bodies) {
memset ((VOID *) result, GUARD_VALUE,
size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
} else {
memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
}
if (!ckallocInit) {
TclInitDbCkalloc();
}
Tcl_MutexLock(ckallocMutexPtr);
result->length = size;
result->tagPtr = curTagPtr;
if (curTagPtr != NULL) {
curTagPtr->refCount++;
}
result->file = file;
result->line = line;
result->flink = allocHead;
result->blink = NULL;
if (allocHead != NULL)
allocHead->blink = result;
allocHead = result;
total_mallocs++;
if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
(void) fflush(stdout);
fprintf(stderr, "reached malloc trace enable point (%d)\n",
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing)
fprintf(stderr,"ckalloc %lx %u %s %d\n",
(long unsigned int) result->body, size, file, line);
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
fprintf(stderr,"reached malloc break limit (%d)\n",
total_mallocs);
fprintf(stderr, "program will now enter C debugger\n");
(void) fflush(stderr);
abort();
}
current_malloc_packets++;
if (current_malloc_packets > maximum_malloc_packets)
maximum_malloc_packets = current_malloc_packets;
current_bytes_malloced += size;
if (current_bytes_malloced > maximum_bytes_malloced)
maximum_bytes_malloced = current_bytes_malloced;
Tcl_MutexUnlock(ckallocMutexPtr);
return result->body;
}
char *
Tcl_AttemptDbCkalloc(size, file, line)
unsigned int size;
CONST char *file;
int line;
{
struct mem_header *result = NULL;
if (validate_memory)
Tcl_ValidateAllMemory (file, line);
/* Don't let size argument to TclpAlloc overflow */
if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) {
result = (struct mem_header *) TclpAlloc((unsigned)size +
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
}
if (result == NULL) {
fflush(stdout);
TclDumpMemoryInfo(stderr);
return NULL;
}
/*
* Fill in guard zones and size. Also initialize the contents of
* the block with bogus bytes to detect uses of initialized data.
* Link into allocated list.
*/
if (init_malloced_bodies) {
memset ((VOID *) result, GUARD_VALUE,
size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
} else {
memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
}
if (!ckallocInit) {
TclInitDbCkalloc();
}
Tcl_MutexLock(ckallocMutexPtr);
result->length = size;
result->tagPtr = curTagPtr;
if (curTagPtr != NULL) {
curTagPtr->refCount++;
}
result->file = file;
result->line = line;
result->flink = allocHead;
result->blink = NULL;
if (allocHead != NULL)
allocHead->blink = result;
allocHead = result;
total_mallocs++;
if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
(void) fflush(stdout);
fprintf(stderr, "reached malloc trace enable point (%d)\n",
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing)
fprintf(stderr,"ckalloc %lx %u %s %d\n",
(long unsigned int) result->body, size, file, line);
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
fprintf(stderr,"reached malloc break limit (%d)\n",
total_mallocs);
fprintf(stderr, "program will now enter C debugger\n");
(void) fflush(stderr);
abort();
}
current_malloc_packets++;
if (current_malloc_packets > maximum_malloc_packets)
maximum_malloc_packets = current_malloc_packets;
current_bytes_malloced += size;
if (current_bytes_malloced > maximum_bytes_malloced)
maximum_bytes_malloced = current_bytes_malloced;
Tcl_MutexUnlock(ckallocMutexPtr);
return result->body;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbCkfree - debugging ckfree
*
* Verify that the low and high guards are intact, and if so
* then free the buffer else panic.
*
* The guards are erased after being checked to catch duplicate
* frees.
*
* The second and third arguments are file and line, these contain
* the filename and line number corresponding to the caller.
* These are sent by the ckfree macro; it uses the preprocessor
* autodefines __FILE__ and __LINE__.
*
*----------------------------------------------------------------------
*/
void
Tcl_DbCkfree(ptr, file, line)
char *ptr;
CONST char *file;
int line;
{
struct mem_header *memp;
if (ptr == NULL) {
return;
}
/*
* The following cast is *very* tricky. Must convert the pointer
* to an integer before doing arithmetic on it, because otherwise
* the arithmetic will be done differently (and incorrectly) on
* word-addressed machines such as Crays (will subtract only bytes,
* even though BODY_OFFSET is in words on these machines).
*/
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
if (alloc_tracing) {
fprintf(stderr, "ckfree %lx %ld %s %d\n",
(long unsigned int) memp->body, memp->length, file, line);
}
if (validate_memory) {
Tcl_ValidateAllMemory(file, line);
}
Tcl_MutexLock(ckallocMutexPtr);
ValidateMemory(memp, file, line, TRUE);
if (init_malloced_bodies) {
memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);
}
total_frees++;
current_malloc_packets--;
current_bytes_malloced -= memp->length;
if (memp->tagPtr != NULL) {
memp->tagPtr->refCount--;
if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {
TclpFree((char *) memp->tagPtr);
}
}
/*
* Delink from allocated list
*/
if (memp->flink != NULL)
memp->flink->blink = memp->blink;
if (memp->blink != NULL)
memp->blink->flink = memp->flink;
if (allocHead == memp)
allocHead = memp->flink;
TclpFree((char *) memp);
Tcl_MutexUnlock(ckallocMutexPtr);
}
/*
*--------------------------------------------------------------------
*
* Tcl_DbCkrealloc - debugging ckrealloc
*
* Reallocate a chunk of memory by allocating a new one of the
* right size, copying the old data to the new location, and then
* freeing the old memory space, using all the memory checking
* features of this package.
*
*--------------------------------------------------------------------
*/
char *
Tcl_DbCkrealloc(ptr, size, file, line)
char *ptr;
unsigned int size;
CONST char *file;
int line;
{
char *new;
unsigned int copySize;
struct mem_header *memp;
if (ptr == NULL) {
return Tcl_DbCkalloc(size, file, line);
}
/*
* See comment from Tcl_DbCkfree before you change the following
* line.
*/
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
if (copySize > (unsigned int) memp->length) {
copySize = memp->length;
}
new = Tcl_DbCkalloc(size, file, line);
memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);
Tcl_DbCkfree(ptr, file, line);
return new;
}
char *
Tcl_AttemptDbCkrealloc(ptr, size, file, line)
char *ptr;
unsigned int size;
CONST char *file;
int line;
{
char *new;
unsigned int copySize;
struct mem_header *memp;
if (ptr == NULL) {
return Tcl_AttemptDbCkalloc(size, file, line);
}
/*
* See comment from Tcl_DbCkfree before you change the following
* line.
*/
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
if (copySize > (unsigned int) memp->length) {
copySize = memp->length;
}
new = Tcl_AttemptDbCkalloc(size, file, line);
if (new == NULL) {
return NULL;
}
memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);
Tcl_DbCkfree(ptr, file, line);
return new;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Alloc, et al. --
*
* These functions are defined in terms of the debugging versions
* when TCL_MEM_DEBUG is set.
*
* Results:
* Same as the debug versions.
*
* Side effects:
* Same as the debug versions.
*
*----------------------------------------------------------------------
*/
#undef Tcl_Alloc
#undef Tcl_Free
#undef Tcl_Realloc
#undef Tcl_AttemptAlloc
#undef Tcl_AttemptRealloc
char *
Tcl_Alloc(size)
unsigned int size;
{
return Tcl_DbCkalloc(size, "unknown", 0);
}
char *
Tcl_AttemptAlloc(size)
unsigned int size;
{
return Tcl_AttemptDbCkalloc(size, "unknown", 0);
}
void
Tcl_Free(ptr)
char *ptr;
{
Tcl_DbCkfree(ptr, "unknown", 0);
}
char *
Tcl_Realloc(ptr, size)
char *ptr;
unsigned int size;
{
return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
}
char *
Tcl_AttemptRealloc(ptr, size)
char *ptr;
unsigned int size;
{
return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0);
}
/*
*----------------------------------------------------------------------
*
* MemoryCmd --
* Implements the Tcl "memory" command, which provides Tcl-level
* control of Tcl memory debugging information.
* memory active $file
* memory break_on_malloc $count
* memory info
* memory init on|off
* memory onexit $file
* memory tag $string
* memory trace on|off
* memory trace_on_at_malloc $count
* memory validate on|off
*
* Results:
* Standard TCL results.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
MemoryCmd (clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
CONST char **argv;
{
CONST char *fileName;
Tcl_DString buffer;
int result;
size_t len;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " option [args..]\"", (char *) NULL);
return TCL_ERROR;
}
if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1], " file\"", (char *) NULL);
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
result = Tcl_DumpActiveMemory (fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_AppendResult(interp, "error accessing ", argv[2],
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"break_on_malloc") == 0) {
if (argc != 3) {
goto argError;
}
if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"info") == 0) {
char buf[400];
sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
"current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
"maximum bytes allocated", maximum_bytes_malloced);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
return TCL_OK;
}
if (strcmp(argv[1],"init") == 0) {
if (argc != 3) {
goto bad_suboption;
}
init_malloced_bodies = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
if (strcmp(argv[1],"onexit") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " onexit file\"", (char *) NULL);
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
onExitMemDumpFileName = dumpFile;
strcpy(onExitMemDumpFileName,fileName);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(argv[1],"tag") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" tag string\"", (char *) NULL);
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
TclpFree((char *) curTagPtr);
}
len = strlen(argv[2]);
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
curTagPtr->refCount = 0;
memcpy(curTagPtr->string, argv[2], len + 1);
return TCL_OK;
}
if (strcmp(argv[1],"trace") == 0) {
if (argc != 3) {
goto bad_suboption;
}
alloc_tracing = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
if (argc != 3) {
goto argError;
}
if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"validate") == 0) {
if (argc != 3) {
goto bad_suboption;
}
validate_memory = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": should be active, break_on_malloc, info, init, onexit, ",
"tag, trace, trace_on_at_malloc, or validate", (char *) NULL);
return TCL_ERROR;
argError:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " count\"", (char *) NULL);
return TCL_ERROR;
bad_suboption:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " on|off\"", (char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* CheckmemCmd --
*
* This is the command procedure for the "checkmem" command, which
* causes the application to exit after printing information about
* memory usage to the file passed to this command as its first
* argument.
*
* Results:
* Returns a standard Tcl completion code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CheckmemCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter for evaluation. */
int argc; /* Number of arguments. */
CONST char *argv[]; /* String values of arguments. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" fileName\"", (char *) NULL);
return TCL_ERROR;
}
tclMemDumpFileName = dumpFile;
strcpy(tclMemDumpFileName, argv[1]);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitMemory --
*
* Create the "memory" and "checkmem" commands in the given
* interpreter.
*
* Results:
* None.
*
* Side effects:
* New commands are added to the interpreter.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitMemory(interp)
Tcl_Interp *interp; /* Interpreter in which commands should be added */
{
TclInitDbCkalloc();
Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
}
#else /* TCL_MEM_DEBUG */
/* This is the !TCL_MEM_DEBUG case */
#undef Tcl_InitMemory
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
/*
*----------------------------------------------------------------------
*
* Tcl_Alloc --
* Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Alloc (size)
unsigned int size;
{
char *result;
result = TclpAlloc(size);
/*
* Most systems will not alloc(0), instead bumping it to one so
* that NULL isn't returned. Some systems (AIX, Tru64) will alloc(0)
* by returning NULL, so we have to check that the NULL we get is
* not in response to alloc(0).
*
* The ANSI spec actually says that systems either return NULL *or*
* a special pointer on failure, but we only check for NULL
*/
if ((result == NULL) && size) {
panic("unable to alloc %u bytes", size);
}
return result;
}
char *
Tcl_DbCkalloc(size, file, line)
unsigned int size;
CONST char *file;
int line;
{
char *result;
result = (char *) TclpAlloc(size);
if ((result == NULL) && size) {
fflush(stdout);
panic("unable to alloc %u bytes, %s line %d", size, file, line);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AttemptAlloc --
* Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not
* check that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
char *
Tcl_AttemptAlloc (size)
unsigned int size;
{
char *result;
result = TclpAlloc(size);
return result;
}
char *
Tcl_AttemptDbCkalloc(size, file, line)
unsigned int size;
CONST char *file;
int line;
{
char *result;
result = (char *) TclpAlloc(size);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Realloc --
* Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does
* check that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Realloc(ptr, size)
char *ptr;
unsigned int size;
{
char *result;
result = TclpRealloc(ptr, size);
if ((result == NULL) && size) {
panic("unable to realloc %u bytes", size);
}
return result;
}
char *
Tcl_DbCkrealloc(ptr, size, file, line)
char *ptr;
unsigned int size;
CONST char *file;
int line;
{
char *result;
result = (char *) TclpRealloc(ptr, size);
if ((result == NULL) && size) {
fflush(stdout);
panic("unable to realloc %u bytes, %s line %d", size, file, line);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AttemptRealloc --
* Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does
* not check that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
char *
Tcl_AttemptRealloc(ptr, size)
char *ptr;
unsigned int size;
{
char *result;
result = TclpRealloc(ptr, size);
return result;
}
char *
Tcl_AttemptDbCkrealloc(ptr, size, file, line)
char *ptr;
unsigned int size;
CONST char *file;
int line;
{
char *result;
result = (char *) TclpRealloc(ptr, size);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Free --
* Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here
* rather in the macro to keep some modules from being compiled with
* TCL_MEM_DEBUG enabled and some with it disabled.
*
*----------------------------------------------------------------------
*/
void
Tcl_Free (ptr)
char *ptr;
{
TclpFree(ptr);
}
void
Tcl_DbCkfree(ptr, file, line)
char *ptr;
CONST char *file;
int line;
{
TclpFree(ptr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitMemory --
* Dummy initialization for memory command, which is only available
* if TCL_MEM_DEBUG is on.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
void
Tcl_InitMemory(interp)
Tcl_Interp *interp;
{
}
int
Tcl_DumpActiveMemory(fileName)
CONST char *fileName;
{
return TCL_OK;
}
void
Tcl_ValidateAllMemory(file, line)
CONST char *file;
int line;
{
}
void
TclDumpMemoryInfo(outFile)
FILE *outFile;
{
}
#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
*
* TclFinalizeMemorySubsystem --
*
* This procedure is called to finalize all the structures that
* are used by the memory allocator on a per-process basis.
*
* Results:
* None.
*
* Side effects:
* This subsystem is self-initializing, since memory can be
* allocated before Tcl is formally initialized. After this call,
* this subsystem has been reset to its initial state and is
* usable again.
*
*---------------------------------------------------------------------------
*/
void
TclFinalizeMemorySubsystem()
{
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(tclMemDumpFileName);
} else if (onExitMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(onExitMemDumpFileName);
}
Tcl_MutexLock(ckallocMutexPtr);
if (curTagPtr != NULL) {
TclpFree((char *) curTagPtr);
curTagPtr = NULL;
}
allocHead = NULL;
Tcl_MutexUnlock(ckallocMutexPtr);
#endif
#if USE_TCLALLOC
TclFinalizeAllocSubsystem();
#endif
}
tcl8.4.20/generic/tclListObj.c 0000644 0036047 0045461 00000141403 12133546540 014544 0 ustar dgp 771div /*
* tclListObj.c --
*
* This file contains procedures that implement the Tcl list object
* type.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1998 by Scriptics Corporation.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* Prototypes for procedures defined later in this file:
*/
static void DupListInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static void FreeListInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr));
static int SetListFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void UpdateStringOfList _ANSI_ARGS_((Tcl_Obj *listPtr));
/*
* The structure below defines the list Tcl object type by means of
* procedures that can be invoked by generic object code.
*
* The internal representation of a list object is a two-pointer
* representation. The first pointer designates a List structure that
* contains an array of pointers to the element objects, together with
* integers that represent the current element count and the allocated
* size of the array. The second pointer is normally NULL; during
* execution of functions in this file that operate on nested sublists,
* it is occasionally used as working storage to avoid an auxiliary
* stack.
*/
Tcl_ObjType tclListType = {
"list", /* name */
FreeListInternalRep, /* freeIntRepProc */
DupListInternalRep, /* dupIntRepProc */
UpdateStringOfList, /* updateStringProc */
SetListFromAny /* setFromAnyProc */
};
/*
*----------------------------------------------------------------------
*
* Tcl_NewListObj --
*
* This procedure is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new list object from an
* (objc,objv) array: that is, each of the objc elements of the array
* referenced by objv is inserted as an element into a new Tcl object.
*
* When TCL_MEM_DEBUG is defined, this procedure just returns the
* result of calling the debugging version Tcl_DbNewListObj.
*
* Results:
* A new list object is returned that is initialized from the object
* pointers in objv. If objc is less than or equal to zero, an empty
* object is returned. The new object's string representation
* is left NULL. The resulting new list object has ref count 0.
*
* Side effects:
* The ref counts of the elements in objv are incremented since the
* resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewListObj
Tcl_Obj *
Tcl_NewListObj(objc, objv)
int objc; /* Count of objects referenced by objv. */
Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
{
return Tcl_DbNewListObj(objc, objv, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewListObj(objc, objv)
int objc; /* Count of objects referenced by objv. */
Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
{
register Tcl_Obj *listPtr;
register Tcl_Obj **elemPtrs;
register List *listRepPtr;
int i;
TclNewObj(listPtr);
if (objc > 0) {
Tcl_InvalidateStringRep(listPtr);
elemPtrs = (Tcl_Obj **)
ckalloc((unsigned) (objc * sizeof(Tcl_Obj *)));
for (i = 0; i < objc; i++) {
elemPtrs[i] = objv[i];
Tcl_IncrRefCount(elemPtrs[i]);
}
listRepPtr = (List *) ckalloc(sizeof(List));
listRepPtr->maxElemCount = objc;
listRepPtr->elemCount = objc;
listRepPtr->elements = elemPtrs;
listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
listPtr->internalRep.twoPtrValue.ptr2 = NULL;
listPtr->typePtr = &tclListType;
}
return listPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewListObj --
*
* This procedure is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new list objects. It is the
* same as the Tcl_NewListObj procedure above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
* caller. This simplifies debugging since then the [memory active]
* command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
* result of calling Tcl_NewListObj.
*
* Results:
* A new list object is returned that is initialized from the object
* pointers in objv. If objc is less than or equal to zero, an empty
* object is returned. The new object's string representation
* is left NULL. The new list object has ref count 0.
*
* Side effects:
* The ref counts of the elements in objv are incremented since the
* resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewListObj(objc, objv, file, line)
int objc; /* Count of objects referenced by objv. */
Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
register Tcl_Obj *listPtr;
register Tcl_Obj **elemPtrs;
register List *listRepPtr;
int i;
TclDbNewObj(listPtr, file, line);
if (objc > 0) {
Tcl_InvalidateStringRep(listPtr);
elemPtrs = (Tcl_Obj **)
ckalloc((unsigned) (objc * sizeof(Tcl_Obj *)));
for (i = 0; i < objc; i++) {
elemPtrs[i] = objv[i];
Tcl_IncrRefCount(elemPtrs[i]);
}
listRepPtr = (List *) ckalloc(sizeof(List));
listRepPtr->maxElemCount = objc;
listRepPtr->elemCount = objc;
listRepPtr->elements = elemPtrs;
listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
listPtr->internalRep.twoPtrValue.ptr2 = NULL;
listPtr->typePtr = &tclListType;
}
return listPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewListObj(objc, objv, file, line)
int objc; /* Count of objects referenced by objv. */
Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
return Tcl_NewListObj(objc, objv);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetListObj --
*
* Modify an object to be a list containing each of the objc elements
* of the object array referenced by objv.
*
* Results:
* None.
*
* Side effects:
* The object is made a list object and is initialized from the object
* pointers in objv. If objc is less than or equal to zero, an empty
* object is returned. The new object's string representation
* is left NULL. The ref counts of the elements in objv are incremented
* since the list now refers to them. The object's old string and
* internal representations are freed and its type is set NULL.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetListObj(objPtr, objc, objv)
Tcl_Obj *objPtr; /* Object whose internal rep to init. */
int objc; /* Count of objects referenced by objv. */
Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
{
register Tcl_Obj **elemPtrs;
register List *listRepPtr;
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
int i;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_SetListObj called with shared object");
}
/*
* Free any old string rep and any internal rep for the old type.
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->typePtr = NULL;
Tcl_InvalidateStringRep(objPtr);
/*
* Set the object's type to "list" and initialize the internal rep.
* However, if there are no elements to put in the list, just give
* the object an empty string rep and a NULL type.
*/
if (objc > 0) {
elemPtrs = (Tcl_Obj **)
ckalloc((unsigned) (objc * sizeof(Tcl_Obj *)));
for (i = 0; i < objc; i++) {
elemPtrs[i] = objv[i];
Tcl_IncrRefCount(elemPtrs[i]);
}
listRepPtr = (List *) ckalloc(sizeof(List));
listRepPtr->maxElemCount = objc;
listRepPtr->elemCount = objc;
listRepPtr->elements = elemPtrs;
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclListType;
} else {
objPtr->bytes = tclEmptyStringRep;
objPtr->length = 0;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjGetElements --
*
* This procedure returns an (objc,objv) array of the elements in a
* list object.
*
* Results:
* The return value is normally TCL_OK; in this case *objcPtr is set to
* the count of list elements and *objvPtr is set to a pointer to an
* array of (*objcPtr) pointers to each list element. If listPtr does
* not refer to a list object and the object can not be converted to
* one, TCL_ERROR is returned and an error message will be left in
* the interpreter's result if interp is not NULL.
*
* The objects referenced by the returned array should be treated as
* readonly and their ref counts are _not_ incremented; the caller must
* do that if it holds on to a reference. Furthermore, the pointer
* and length returned by this procedure may change as soon as any
* procedure is called on the list object; be careful about retaining
* the pointer in a local data structure.
*
* Side effects:
* The possible conversion of the object referenced by listPtr
* to a list object.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr)
Tcl_Interp *interp; /* Used to report errors if not NULL. */
register Tcl_Obj *listPtr; /* List object for which an element array
* is to be returned. */
int *objcPtr; /* Where to store the count of objects
* referenced by objv. */
Tcl_Obj ***objvPtr; /* Where to store the pointer to an array
* of pointers to the list's objects. */
{
register List *listRepPtr;
if (listPtr->typePtr != &tclListType) {
int result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
}
listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
*objcPtr = listRepPtr->elemCount;
*objvPtr = listRepPtr->elements;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjAppendList --
*
* This procedure appends the objects in the list referenced by
* elemListPtr to the list object referenced by listPtr. If listPtr is
* not already a list object, an attempt will be made to convert it to
* one.
*
* Results:
* The return value is normally TCL_OK. If listPtr or elemListPtr do
* not refer to list objects and they can not be converted to one,
* TCL_ERROR is returned and an error message is left in
* the interpreter's result if interp is not NULL.
*
* Side effects:
* The reference counts of the elements in elemListPtr are incremented
* since the list now refers to them. listPtr and elemListPtr are
* converted, if necessary, to list objects. Also, appending the
* new elements may cause listObj's array of element pointers to grow.
* listPtr's old string representation, if any, is invalidated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjAppendList(interp, listPtr, elemListPtr)
Tcl_Interp *interp; /* Used to report errors if not NULL. */
register Tcl_Obj *listPtr; /* List object to append elements to. */
Tcl_Obj *elemListPtr; /* List obj with elements to append. */
{
register List *listRepPtr;
int listLen, objc, result;
Tcl_Obj **objv;
if (Tcl_IsShared(listPtr)) {
panic("Tcl_ListObjAppendList called with shared object");
}
if (listPtr->typePtr != &tclListType) {
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
}
listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
listLen = listRepPtr->elemCount;
result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv);
if (result != TCL_OK) {
return result;
}
/*
* Insert objc new elements starting after the lists's last element.
* Delete zero existing elements.
*/
return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjAppendElement --
*
* This procedure is a special purpose version of
* Tcl_ListObjAppendList: it appends a single object referenced by
* objPtr to the list object referenced by listPtr. If listPtr is not
* already a list object, an attempt will be made to convert it to one.
*
* Results:
* The return value is normally TCL_OK; in this case objPtr is added
* to the end of listPtr's list. If listPtr does not refer to a list
* object and the object can not be converted to one, TCL_ERROR is
* returned and an error message will be left in the interpreter's
* result if interp is not NULL.
*
* Side effects:
* The ref count of objPtr is incremented since the list now refers
* to it. listPtr will be converted, if necessary, to a list object.
* Also, appending the new element may cause listObj's array of element
* pointers to grow. listPtr's old string representation, if any,
* is invalidated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjAppendElement(interp, listPtr, objPtr)
Tcl_Interp *interp; /* Used to report errors if not NULL. */
Tcl_Obj *listPtr; /* List object to append objPtr to. */
Tcl_Obj *objPtr; /* Object to append to listPtr's list. */
{
register List *listRepPtr;
register Tcl_Obj **elemPtrs;
int numElems, numRequired;
if (Tcl_IsShared(listPtr)) {
panic("Tcl_ListObjAppendElement called with shared object");
}
if (listPtr->typePtr != &tclListType) {
int result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
}
listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
elemPtrs = listRepPtr->elements;
numElems = listRepPtr->elemCount;
numRequired = numElems + 1 ;
/*
* If there is no room in the current array of element pointers,
* allocate a new, larger array and copy the pointers to it.
*/
if (numRequired > listRepPtr->maxElemCount) {
int newMax = (2 * numRequired);
Tcl_Obj **newElemPtrs = (Tcl_Obj **)
ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *)));
memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs,
(size_t) (numElems * sizeof(Tcl_Obj *)));
listRepPtr->maxElemCount = newMax;
listRepPtr->elements = newElemPtrs;
ckfree((char *) elemPtrs);
elemPtrs = newElemPtrs;
}
/*
* Add objPtr to the end of listPtr's array of element
* pointers. Increment the ref count for the (now shared) objPtr.
*/
elemPtrs[numElems] = objPtr;
Tcl_IncrRefCount(objPtr);
listRepPtr->elemCount++;
/*
* Invalidate any old string representation since the list's internal
* representation has changed.
*/
Tcl_InvalidateStringRep(listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjIndex --
*
* This procedure returns a pointer to the index'th object from the
* list referenced by listPtr. The first element has index 0. If index
* is negative or greater than or equal to the number of elements in
* the list, a NULL is returned. If listPtr is not a list object, an
* attempt will be made to convert it to a list.
*
* Results:
* The return value is normally TCL_OK; in this case objPtrPtr is set
* to the Tcl_Obj pointer for the index'th list element or NULL if
* index is out of range. This object should be treated as readonly and
* its ref count is _not_ incremented; the caller must do that if it
* holds on to the reference. If listPtr does not refer to a list and
* can't be converted to one, TCL_ERROR is returned and an error
* message is left in the interpreter's result if interp is not NULL.
*
* Side effects:
* listPtr will be converted, if necessary, to a list object.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr)
Tcl_Interp *interp; /* Used to report errors if not NULL. */
register Tcl_Obj *listPtr; /* List object to index into. */
register int index; /* Index of element to return. */
Tcl_Obj **objPtrPtr; /* The resulting Tcl_Obj* is stored here. */
{
register List *listRepPtr;
if (listPtr->typePtr != &tclListType) {
int result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
}
listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
if ((index < 0) || (index >= listRepPtr->elemCount)) {
*objPtrPtr = NULL;
} else {
*objPtrPtr = listRepPtr->elements[index];
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjLength --
*
* This procedure returns the number of elements in a list object. If
* the object is not already a list object, an attempt will be made to
* convert it to one.
*
* Results:
* The return value is normally TCL_OK; in this case *intPtr will be
* set to the integer count of list elements. If listPtr does not refer
* to a list object and the object can not be converted to one,
* TCL_ERROR is returned and an error message will be left in
* the interpreter's result if interp is not NULL.
*
* Side effects:
* The possible conversion of the argument object to a list object.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjLength(interp, listPtr, intPtr)
Tcl_Interp *interp; /* Used to report errors if not NULL. */
register Tcl_Obj *listPtr; /* List object whose #elements to return. */
register int *intPtr; /* The resulting int is stored here. */
{
register List *listRepPtr;
if (listPtr->typePtr != &tclListType) {
int result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
}
listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
*intPtr = listRepPtr->elemCount;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjReplace --
*
* This procedure replaces zero or more elements of the list referenced
* by listPtr with the objects from an (objc,objv) array.
* The objc elements of the array referenced by objv replace the
* count elements in listPtr starting at first.
*
* If the argument first is zero or negative, it refers to the first
* element. If first is greater than or equal to the number of elements
* in the list, then no elements are deleted; the new elements are
* appended to the list. Count gives the number of elements to
* replace. If count is zero or negative then no elements are deleted;
* the new elements are simply inserted before first.
*
* The argument objv refers to an array of objc pointers to the new
* elements to be added to listPtr in place of those that were
* deleted. If objv is NULL, no new elements are added. If listPtr is
* not a list object, an attempt will be made to convert it to one.
*
* Results:
* The return value is normally TCL_OK. If listPtr does
* not refer to a list object and can not be converted to one,
* TCL_ERROR is returned and an error message will be left in
* the interpreter's result if interp is not NULL.
*
* Side effects:
* The ref counts of the objc elements in objv are incremented since
* the resulting list now refers to them. Similarly, the ref counts for
* replaced objects are decremented. listPtr is converted, if
* necessary, to a list object. listPtr's old string representation, if
* any, is freed.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *listPtr; /* List object whose elements to replace. */
int first; /* Index of first element to replace. */
int count; /* Number of elements to replace. */
int objc; /* Number of objects to insert. */
Tcl_Obj *CONST objv[]; /* An array of objc pointers to Tcl objects
* to insert. */
{
List *listRepPtr;
register Tcl_Obj **elemPtrs, **newPtrs;
Tcl_Obj *victimPtr;
int numElems, numRequired, numAfterLast;
int start, shift, newMax, i, j, result;
if (Tcl_IsShared(listPtr)) {
panic("Tcl_ListObjReplace called with shared object");
}
if (listPtr->typePtr != &tclListType) {
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
}
listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
elemPtrs = listRepPtr->elements;
numElems = listRepPtr->elemCount;
if (first < 0) {
first = 0;
}
if (first >= numElems) {
first = numElems; /* so we'll insert after last element */
}
if (count < 0) {
count = 0;
}
for (i = 0; i < objc; i++) {
Tcl_IncrRefCount(objv[i]);
}
numRequired = (numElems - count + objc);
if (numRequired <= listRepPtr->maxElemCount) {
/*
* Enough room in the current array. First "delete" count
* elements starting at first.
*/
for (i = 0, j = first; i < count; i++, j++) {
victimPtr = elemPtrs[j];
TclDecrRefCount(victimPtr);
}
/*
* Shift the elements after the last one removed to their
* new locations.
*/
start = (first + count);
numAfterLast = (numElems - start);
shift = (objc - count); /* numNewElems - numDeleted */
if ((numAfterLast > 0) && (shift != 0)) {
Tcl_Obj **src, **dst;
src = elemPtrs + start; dst = src + shift;
memmove((VOID*) dst, (VOID*) src,
(size_t) (numAfterLast * sizeof(Tcl_Obj*)));
}
/*
* Insert the new elements into elemPtrs before "first".
*/
for (i = 0, j = first; i < objc; i++, j++) {
elemPtrs[j] = objv[i];
}
/*
* Update the count of elements.
*/
listRepPtr->elemCount = numRequired;
} else {
/*
* Not enough room in the current array. Allocate a larger array and
* insert elements into it.
*/
newMax = (2 * numRequired);
newPtrs = (Tcl_Obj **)
ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *)));
/*
* Copy over the elements before "first".
*/
if (first > 0) {
memcpy((VOID *) newPtrs, (VOID *) elemPtrs,
(size_t) (first * sizeof(Tcl_Obj *)));
}
/*
* "Delete" count elements starting at first.
*/
for (i = 0, j = first; i < count; i++, j++) {
victimPtr = elemPtrs[j];
TclDecrRefCount(victimPtr);
}
/*
* Copy the elements after the last one removed, shifted to
* their new locations.
*/
start = (first + count);
numAfterLast = (numElems - start);
if (numAfterLast > 0) {
memcpy((VOID *) &(newPtrs[first + objc]),
(VOID *) &(elemPtrs[start]),
(size_t) (numAfterLast * sizeof(Tcl_Obj *)));
}
/*
* Insert the new elements before "first" and update the
* count of elements.
*/
for (i = 0, j = first; i < objc; i++, j++) {
newPtrs[j] = objv[i];
}
listRepPtr->elemCount = numRequired;
listRepPtr->maxElemCount = newMax;
listRepPtr->elements = newPtrs;
ckfree((char *) elemPtrs);
}
/*
* Invalidate and free any old string representation since it no longer
* reflects the list's internal representation.
*/
Tcl_InvalidateStringRep(listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclLsetList --
*
* Core of the 'lset' command when objc == 4. Objv[2] may be
* either a scalar index or a list of indices.
*
* Results:
* Returns the new value of the list variable, or NULL if an
* error occurs.
*
* Side effects:
* Surgery is performed on the list value to produce the
* result.
*
* On entry, the reference count of the variable value does not reflect
* any references held on the stack. The first action of this function
* is to determine whether the object is shared, and to duplicate it if
* it is. The reference count of the duplicate is incremented.
* At this point, the reference count will be 1 for either case, so that
* the object will appear to be unshared.
*
* If an error occurs, and the object has been duplicated, the reference
* count on the duplicate is decremented so that it is now 0: this dismisses
* any memory that was allocated by this procedure.
*
* If no error occurs, the reference count of the original object is
* incremented if the object has not been duplicated, and nothing is
* done to a reference count of the duplicate. Now the reference count
* of an unduplicated object is 2 (the returned pointer, plus the one
* stored in the variable). The reference count of a duplicate object
* is 1, reflecting that the returned pointer is the only active
* reference. The caller is expected to store the returned value back
* in the variable and decrement its reference count. (INST_STORE_*
* does exactly this.)
*
* Tcl_LsetFlat and related functions maintain a linked list of
* Tcl_Obj's whose string representations must be spoilt by threading
* via 'ptr2' of the two-pointer internal representation. On entry
* to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit,
* the 'ptr2' field of any Tcl_Obj that has been modified is set to
* NULL.
*
*----------------------------------------------------------------------
*/
Tcl_Obj*
TclLsetList( interp, listPtr, indexArgPtr, valuePtr )
Tcl_Interp* interp; /* Tcl interpreter */
Tcl_Obj* listPtr; /* Pointer to the list being modified */
Tcl_Obj* indexArgPtr; /* Index or index-list arg to 'lset' */
Tcl_Obj* valuePtr; /* Value arg to 'lset' */
{
int indexCount; /* Number of indices in the index list */
Tcl_Obj** indices; /* Vector of indices in the index list*/
int duplicated; /* Flag == 1 if the obj has been
* duplicated, 0 otherwise */
Tcl_Obj* retValuePtr; /* Pointer to the list to be returned */
int index; /* Current index in the list - discarded */
int result; /* Status return from library calls */
Tcl_Obj* subListPtr; /* Pointer to the current sublist */
int elemCount; /* Count of elements in the current sublist */
Tcl_Obj** elemPtrs; /* Pointers to elements of current sublist */
Tcl_Obj* chainPtr; /* Pointer to the enclosing sublist
* of the current sublist */
int i;
/*
* Determine whether the index arg designates a list or a single
* index. We have to be careful about the order of the checks to
* avoid repeated shimmering; see TIP #22 and #23 for details.
*/
if ( indexArgPtr->typePtr != &tclListType
&& TclGetIntForIndex( NULL, indexArgPtr, 0, &index ) == TCL_OK ) {
/*
* indexArgPtr designates a single index.
*/
return TclLsetFlat( interp, listPtr, 1, &indexArgPtr, valuePtr );
} else if ( Tcl_ListObjGetElements( NULL, indexArgPtr,
&indexCount, &indices ) != TCL_OK ) {
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
return TclLsetFlat( interp, listPtr, 1, &indexArgPtr, valuePtr );
}
/*
* At this point, we know that argPtr designates a well formed list,
* and the 'else if' above has parsed it into indexCount and indices.
* If there are no indices, simply return 'valuePtr', counting the
* returned pointer as a reference.
*/
if ( indexCount == 0 ) {
Tcl_IncrRefCount( valuePtr );
return valuePtr;
}
/*
* Duplicate the list arg if necessary.
*/
if ( Tcl_IsShared( listPtr ) ) {
duplicated = 1;
listPtr = Tcl_DuplicateObj( listPtr );
Tcl_IncrRefCount( listPtr );
} else {
duplicated = 0;
}
/*
* It would be tempting simply to go off to TclLsetFlat to finish the
* processing. Alas, it is also incorrect! The problem is that
* 'indexArgPtr' may designate a sublist of 'listPtr' whose value
* is to be manipulated. The fact that 'listPtr' is itself unshared
* does not guarantee that no sublist is. Therefore, it's necessary
* to replicate all the work here, expanding the index list on each
* trip through the loop.
*/
/*
* Anchor the linked list of Tcl_Obj's whose string reps must be
* invalidated if the operation succeeds.
*/
retValuePtr = listPtr;
chainPtr = NULL;
/*
* Handle each index arg by diving into the appropriate sublist
*/
for ( i = 0; ; ++i ) {
/*
* Take the sublist apart.
*/
result = Tcl_ListObjGetElements( interp, listPtr,
&elemCount, &elemPtrs );
if ( result != TCL_OK ) {
break;
}
listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;
/*
* Reconstitute the index array
*/
result = Tcl_ListObjGetElements( interp, indexArgPtr,
&indexCount, &indices );
if ( result != TCL_OK ) {
/*
* Shouldn't be able to get here, because we already
* parsed the thing successfully once.
*/
break;
}
/*
* Determine the index of the requested element.
*/
result = TclGetIntForIndex( interp, indices[ i ],
(elemCount - 1), &index );
if ( result != TCL_OK ) {
break;
}
/*
* Check that the index is in range.
*/
if ( ( index < 0 ) || ( index >= elemCount ) ) {
Tcl_SetObjResult( interp,
Tcl_NewStringObj( "list index out of range",
-1 ) );
result = TCL_ERROR;
break;
}
/*
* Break the loop after extracting the innermost sublist
*/
if ( i >= indexCount-1 ) {
result = TCL_OK;
break;
}
/*
* Extract the appropriate sublist, and make sure that it is unshared.
*/
subListPtr = elemPtrs[ index ];
if ( Tcl_IsShared( subListPtr ) ) {
subListPtr = Tcl_DuplicateObj( subListPtr );
result = TclListObjSetElement( interp, listPtr, index,
subListPtr );
if ( result != TCL_OK ) {
/*
* We actually shouldn't be able to get here, because
* we've already checked everything that TclListObjSetElement
* checks. If we were to get here, it would result in leaking
* subListPtr.
*/
break;
}
}
/*
* Chain the current sublist onto the linked list of Tcl_Obj's
* whose string reps must be spoilt.
*/
chainPtr = listPtr;
listPtr = subListPtr;
}
/*
* Store the new element into the correct slot in the innermost sublist.
*/
if ( result == TCL_OK ) {
result = TclListObjSetElement( interp, listPtr, index, valuePtr );
}
if ( result == TCL_OK ) {
listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;
/* Spoil all the string reps */
while ( listPtr != NULL ) {
subListPtr = (Tcl_Obj *) listPtr->internalRep.twoPtrValue.ptr2;
Tcl_InvalidateStringRep( listPtr );
listPtr->internalRep.twoPtrValue.ptr2 = NULL;
listPtr = subListPtr;
}
/* Return the new list if everything worked. */
if ( !duplicated ) {
Tcl_IncrRefCount( retValuePtr );
}
return retValuePtr;
}
/* Clean up the one dangling reference otherwise */
if ( duplicated ) {
Tcl_DecrRefCount( retValuePtr );
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclLsetFlat --
*
* Core of the 'lset' command when objc>=5. Objv[2], ... ,
* objv[objc-2] contain scalar indices.
*
* Results:
* Returns the new value of the list variable, or NULL if an
* error occurs.
*
* Side effects:
* Surgery is performed on the list value to produce the
* result.
*
* On entry, the reference count of the variable value does not reflect
* any references held on the stack. The first action of this function
* is to determine whether the object is shared, and to duplicate it if
* it is. The reference count of the duplicate is incremented.
* At this point, the reference count will be 1 for either case, so that
* the object will appear to be unshared.
*
* If an error occurs, and the object has been duplicated, the reference
* count on the duplicate is decremented so that it is now 0: this dismisses
* any memory that was allocated by this procedure.
*
* If no error occurs, the reference count of the original object is
* incremented if the object has not been duplicated, and nothing is
* done to a reference count of the duplicate. Now the reference count
* of an unduplicated object is 2 (the returned pointer, plus the one
* stored in the variable). The reference count of a duplicate object
* is 1, reflecting that the returned pointer is the only active
* reference. The caller is expected to store the returned value back
* in the variable and decrement its reference count. (INST_STORE_*
* does exactly this.)
*
* Tcl_LsetList and related functions maintain a linked list of
* Tcl_Obj's whose string representations must be spoilt by threading
* via 'ptr2' of the two-pointer internal representation. On entry
* to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit,
* the 'ptr2' field of any Tcl_Obj that has been modified is set to
* NULL.
*
*----------------------------------------------------------------------
*/
Tcl_Obj*
TclLsetFlat( interp, listPtr, indexCount, indexArray, valuePtr )
Tcl_Interp* interp; /* Tcl interpreter */
Tcl_Obj* listPtr; /* Pointer to the list being modified */
int indexCount; /* Number of index args */
Tcl_Obj *CONST indexArray[];
/* Index args */
Tcl_Obj* valuePtr; /* Value arg to 'lset' */
{
int duplicated; /* Flag == 1 if the obj has been
* duplicated, 0 otherwise */
Tcl_Obj* retValuePtr; /* Pointer to the list to be returned */
int elemCount; /* Length of one sublist being changed */
Tcl_Obj** elemPtrs; /* Pointers to the elements of a sublist */
Tcl_Obj* subListPtr; /* Pointer to the current sublist */
int index; /* Index of the element to replace in the
* current sublist */
Tcl_Obj* chainPtr; /* Pointer to the enclosing list of
* the current sublist. */
int result; /* Status return from library calls */
int i;
/*
* If there are no indices, then simply return the new value,
* counting the returned pointer as a reference
*/
if ( indexCount == 0 ) {
Tcl_IncrRefCount( valuePtr );
return valuePtr;
}
/*
* If the list is shared, make a private copy.
*/
if ( Tcl_IsShared( listPtr ) ) {
duplicated = 1;
listPtr = Tcl_DuplicateObj( listPtr );
Tcl_IncrRefCount( listPtr );
} else {
duplicated = 0;
}
/*
* Anchor the linked list of Tcl_Obj's whose string reps must be
* invalidated if the operation succeeds.
*/
retValuePtr = listPtr;
chainPtr = NULL;
/*
* Handle each index arg by diving into the appropriate sublist
*/
for ( i = 0; ; ++i ) {
/*
* Take the sublist apart.
*/
result = Tcl_ListObjGetElements( interp, listPtr,
&elemCount, &elemPtrs );
if ( result != TCL_OK ) {
break;
}
listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;
/*
* Determine the index of the requested element.
*/
result = TclGetIntForIndex( interp, indexArray[ i ],
(elemCount - 1), &index );
if ( result != TCL_OK ) {
break;
}
/*
* Check that the index is in range.
*/
if ( ( index < 0 ) || ( index >= elemCount ) ) {
Tcl_SetObjResult( interp,
Tcl_NewStringObj( "list index out of range",
-1 ) );
result = TCL_ERROR;
break;
}
/*
* Break the loop after extracting the innermost sublist
*/
if ( i >= indexCount-1 ) {
result = TCL_OK;
break;
}
/*
* Extract the appropriate sublist, and make sure that it is unshared.
*/
subListPtr = elemPtrs[ index ];
if ( Tcl_IsShared( subListPtr ) ) {
subListPtr = Tcl_DuplicateObj( subListPtr );
result = TclListObjSetElement( interp, listPtr, index,
subListPtr );
if ( result != TCL_OK ) {
/*
* We actually shouldn't be able to get here.
* If we do, it would result in leaking subListPtr,
* but everything's been validated already; the error
* exit from TclListObjSetElement should never happen.
*/
break;
}
}
/*
* Chain the current sublist onto the linked list of Tcl_Obj's
* whose string reps must be spoilt.
*/
chainPtr = listPtr;
listPtr = subListPtr;
}
/* Store the result in the list element */
if ( result == TCL_OK ) {
result = TclListObjSetElement( interp, listPtr, index, valuePtr );
}
if ( result == TCL_OK ) {
listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;
/* Spoil all the string reps */
while ( listPtr != NULL ) {
subListPtr = (Tcl_Obj *) listPtr->internalRep.twoPtrValue.ptr2;
Tcl_InvalidateStringRep( listPtr );
listPtr->internalRep.twoPtrValue.ptr2 = NULL;
listPtr = subListPtr;
}
/* Return the new list if everything worked. */
if ( !duplicated ) {
Tcl_IncrRefCount( retValuePtr );
}
return retValuePtr;
}
/* Clean up the one dangling reference otherwise */
if ( duplicated ) {
Tcl_DecrRefCount( retValuePtr );
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclListObjSetElement --
*
* Set a single element of a list to a specified value
*
* Results:
*
* The return value is normally TCL_OK. If listPtr does not
* refer to a list object and cannot be converted to one, TCL_ERROR
* is returned and an error message will be left in the interpreter
* result if interp is not NULL. Similarly, if index designates
* an element outside the range [0..listLength-1], where
* listLength is the count of elements in the list object designated
* by listPtr, TCL_ERROR is returned and an error message is left
* in the interpreter result.
*
* Side effects:
*
* Panics if listPtr designates a shared object. Otherwise, attempts
* to convert it to a list. Decrements the ref count of the object
* at the specified index within the list, replaces with the
* object designated by valuePtr, and increments the ref count
* of the replacement object.
*
* It is the caller's responsibility to invalidate the string
* representation of the object.
*
*----------------------------------------------------------------------
*/
int
TclListObjSetElement( interp, listPtr, index, valuePtr )
Tcl_Interp* interp; /* Tcl interpreter; used for error reporting
* if not NULL */
Tcl_Obj* listPtr; /* List object in which element should be
* stored */
int index; /* Index of element to store */
Tcl_Obj* valuePtr; /* Tcl object to store in the designated
* list element */
{
int result; /* Return value from this function */
List* listRepPtr; /* Internal representation of the list
* being modified */
Tcl_Obj** elemPtrs; /* Pointers to elements of the list */
int elemCount; /* Number of elements in the list */
/* Ensure that the listPtr parameter designates an unshared list */
if ( Tcl_IsShared( listPtr ) ) {
panic( "Tcl_ListObjSetElement called with shared object" );
}
if ( listPtr->typePtr != &tclListType ) {
result = SetListFromAny( interp, listPtr );
if ( result != TCL_OK ) {
return result;
}
}
listRepPtr = (List*) listPtr->internalRep.twoPtrValue.ptr1;
elemPtrs = listRepPtr->elements;
elemCount = listRepPtr->elemCount;
/* Ensure that the index is in bounds */
if ( index < 0 || index >= elemCount ) {
if ( interp != NULL ) {
Tcl_SetObjResult( interp,
Tcl_NewStringObj( "list index out of range",
-1 ) );
return TCL_ERROR;
}
}
/* Add a reference to the new list element */
Tcl_IncrRefCount( valuePtr );
/* Remove a reference from the old list element */
Tcl_DecrRefCount( elemPtrs[ index ] );
/* Stash the new object in the list */
elemPtrs[ index ] = valuePtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeListInternalRep --
*
* Deallocate the storage associated with a list object's internal
* representation.
*
* Results:
* None.
*
* Side effects:
* Frees listPtr's List* internal representation and sets listPtr's
* internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts
* of all element objects, which may free them.
*
*----------------------------------------------------------------------
*/
static void
FreeListInternalRep(listPtr)
Tcl_Obj *listPtr; /* List object with internal rep to free. */
{
register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
register Tcl_Obj **elemPtrs = listRepPtr->elements;
register Tcl_Obj *objPtr;
int numElems = listRepPtr->elemCount;
int i;
for (i = 0; i < numElems; i++) {
objPtr = elemPtrs[i];
Tcl_DecrRefCount(objPtr);
}
ckfree((char *) elemPtrs);
ckfree((char *) listRepPtr);
listPtr->internalRep.twoPtrValue.ptr1 = NULL;
listPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
/*
*----------------------------------------------------------------------
*
* DupListInternalRep --
*
* Initialize the internal representation of a list Tcl_Obj to a
* copy of the internal representation of an existing list object.
*
* Results:
* None.
*
* Side effects:
* "srcPtr"s list internal rep pointer should not be NULL and we assume
* it is not NULL. We set "copyPtr"s internal rep to a pointer to a
* newly allocated List structure that, in turn, points to "srcPtr"s
* element objects. Those element objects are not actually copied but
* are shared between "srcPtr" and "copyPtr". The ref count of each
* element object is incremented.
*
*----------------------------------------------------------------------
*/
static void
DupListInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
List *srcListRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1;
int numElems = srcListRepPtr->elemCount;
int maxElems = srcListRepPtr->maxElemCount;
register Tcl_Obj **srcElemPtrs = srcListRepPtr->elements;
register Tcl_Obj **copyElemPtrs;
register List *copyListRepPtr;
int i;
/*
* Allocate a new List structure that points to "srcPtr"s element
* objects. Increment the ref counts for those (now shared) element
* objects.
*/
copyElemPtrs = (Tcl_Obj **)
ckalloc((unsigned) maxElems * sizeof(Tcl_Obj *));
for (i = 0; i < numElems; i++) {
copyElemPtrs[i] = srcElemPtrs[i];
Tcl_IncrRefCount(copyElemPtrs[i]);
}
copyListRepPtr = (List *) ckalloc(sizeof(List));
copyListRepPtr->maxElemCount = maxElems;
copyListRepPtr->elemCount = numElems;
copyListRepPtr->elements = copyElemPtrs;
copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) copyListRepPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
copyPtr->typePtr = &tclListType;
}
/*
*----------------------------------------------------------------------
*
* SetListFromAny --
*
* Attempt to generate a list internal form for the Tcl object
* "objPtr".
*
* Results:
* The return value is TCL_OK or TCL_ERROR. If an error occurs during
* conversion, an error message is left in the interpreter's result
* unless "interp" is NULL.
*
* Side effects:
* If no error occurs, a list is stored as "objPtr"s internal
* representation.
*
*----------------------------------------------------------------------
*/
static int
SetListFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object to convert. */
{
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
char *string, *s;
CONST char *elemStart, *nextElem;
int lenRemain, length, estCount, elemSize, hasBrace, i, j, result;
char *limit; /* Points just after string's last byte. */
register CONST char *p;
register Tcl_Obj **elemPtrs;
register Tcl_Obj *elemPtr;
List *listRepPtr;
/*
* Get the string representation. Make it up-to-date if necessary.
*/
string = Tcl_GetStringFromObj(objPtr, &length);
/*
* Parse the string into separate string objects, and create a List
* structure that points to the element string objects. We use a
* modified version of Tcl_SplitList's implementation to avoid one
* malloc and a string copy for each list element. First, estimate the
* number of elements by counting the number of space characters in the
* list.
*/
limit = (string + length);
estCount = 1;
for (p = string; p < limit; p++) {
if (isspace(UCHAR(*p))) { /* INTL: ISO space. */
estCount++;
}
}
/*
* Allocate a new List structure with enough room for "estCount"
* elements. Each element is a pointer to a Tcl_Obj with the appropriate
* string rep. The initial "estCount" elements are set using the
* corresponding "argv" strings.
*/
elemPtrs = (Tcl_Obj **)
ckalloc((unsigned) (estCount * sizeof(Tcl_Obj *)));
for (p = string, lenRemain = length, i = 0;
lenRemain > 0;
p = nextElem, lenRemain = (limit - nextElem), i++) {
result = TclFindElement(interp, p, lenRemain, &elemStart, &nextElem,
&elemSize, &hasBrace);
if (result != TCL_OK) {
for (j = 0; j < i; j++) {
elemPtr = elemPtrs[j];
Tcl_DecrRefCount(elemPtr);
}
ckfree((char *) elemPtrs);
return result;
}
if (elemStart >= limit) {
break;
}
if (i > estCount) {
panic("SetListFromAny: bad size estimate for list");
}
/*
* Allocate a Tcl object for the element and initialize it from the
* "elemSize" bytes starting at "elemStart".
*/
s = ckalloc((unsigned) elemSize + 1);
if (hasBrace) {
memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize);
s[elemSize] = 0;
} else {
elemSize = TclCopyAndCollapse(elemSize, elemStart, s);
}
TclNewObj(elemPtr);
elemPtr->bytes = s;
elemPtr->length = elemSize;
elemPtrs[i] = elemPtr;
Tcl_IncrRefCount(elemPtr); /* since list now holds ref to it */
}
listRepPtr = (List *) ckalloc(sizeof(List));
listRepPtr->maxElemCount = estCount;
listRepPtr->elemCount = i;
listRepPtr->elements = elemPtrs;
/*
* Free the old internalRep before setting the new one. We do this as
* late as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclListType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfList --
*
* Update the string representation for a list object.
* Note: This procedure does not invalidate an existing old string rep
* so storage will be lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from
* the list-to-string conversion. This string will be empty if the
* list has no elements. The list internal representation
* should not be NULL and we assume it is not NULL.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfList(listPtr)
Tcl_Obj *listPtr; /* List object with string rep to update. */
{
# define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr;
List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
int numElems = listRepPtr->elemCount;
register int i;
char *elem, *dst;
int length;
/*
* Convert each element of the list to string form and then convert it
* to proper list element form, adding it to the result buffer.
*/
/*
* Pass 1: estimate space, gather flags.
*/
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int));
}
listPtr->length = 1;
for (i = 0; i < numElems; i++) {
elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length);
listPtr->length += Tcl_ScanCountedElement(elem, length,
&flagPtr[i]) + 1;
/*
* Check for continued sanity. [Bug 1267380]
*/
if (listPtr->length < 1) {
Tcl_Panic("string representation size exceeds sane bounds");
}
}
/*
* Pass 2: copy into string rep buffer.
*/
listPtr->bytes = ckalloc((unsigned) listPtr->length);
dst = listPtr->bytes;
for (i = 0; i < numElems; i++) {
elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length);
dst += Tcl_ConvertCountedElement(elem, length, dst, flagPtr[i]);
*dst = ' ';
dst++;
}
if (flagPtr != localFlags) {
ckfree((char *) flagPtr);
}
if (dst == listPtr->bytes) {
*dst = 0;
} else {
dst--;
*dst = 0;
}
listPtr->length = dst - listPtr->bytes;
}
tcl8.4.20/generic/tclParseExpr.c 0000644 0036047 0045461 00000156554 12052456744 015132 0 ustar dgp 771div /*
* tclParseExpr.c --
*
* This file contains procedures that parse Tcl expressions. They
* do so in a general-purpose fashion that can be used for many
* different purposes, including compilation, direct execution,
* code analysis, etc.
*
* Copyright (c) 1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
* Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* The stuff below is a bit of a hack so that this file can be used in
* environments that include no UNIX, i.e. no errno: just arrange to use
* the errno from tclExecute.c here.
*/
#ifndef TCL_GENERIC_ONLY
#include "tclPort.h"
#else
#define NO_ERRNO_H
#endif
#ifdef NO_ERRNO_H
extern int errno; /* Use errno from tclExecute.c. */
#define ERANGE 34
#endif
/*
* Boolean variable that controls whether expression parse tracing
* is enabled.
*/
#ifdef TCL_COMPILE_DEBUG
static int traceParseExpr = 0;
#endif /* TCL_COMPILE_DEBUG */
/*
* The ParseInfo structure holds state while parsing an expression.
* A pointer to an ParseInfo record is passed among the routines in
* this module.
*/
typedef struct ParseInfo {
Tcl_Parse *parsePtr; /* Points to structure to fill in with
* information about the expression. */
int lexeme; /* Type of last lexeme scanned in expr.
* See below for definitions. Corresponds to
* size characters beginning at start. */
CONST char *start; /* First character in lexeme. */
int size; /* Number of bytes in lexeme. */
CONST char *next; /* Position of the next character to be
* scanned in the expression string. */
CONST char *prevEnd; /* Points to the character just after the
* last one in the previous lexeme. Used to
* compute size of subexpression tokens. */
CONST char *originalExpr; /* Points to the start of the expression
* originally passed to Tcl_ParseExpr. */
CONST char *lastChar; /* Points just after last byte of expr. */
} ParseInfo;
/*
* Definitions of the different lexemes that appear in expressions. The
* order of these must match the corresponding entries in the
* operatorStrings array below.
*
* Basic lexemes:
*/
#define LITERAL 0
#define FUNC_NAME 1
#define OPEN_BRACKET 2
#define OPEN_BRACE 3
#define OPEN_PAREN 4
#define CLOSE_PAREN 5
#define DOLLAR 6
#define QUOTE 7
#define COMMA 8
#define END 9
#define UNKNOWN 10
#define UNKNOWN_CHAR 11
/*
* Binary numeric operators:
*/
#define MULT 12
#define DIVIDE 13
#define MOD 14
#define PLUS 15
#define MINUS 16
#define LEFT_SHIFT 17
#define RIGHT_SHIFT 18
#define LESS 19
#define GREATER 20
#define LEQ 21
#define GEQ 22
#define EQUAL 23
#define NEQ 24
#define BIT_AND 25
#define BIT_XOR 26
#define BIT_OR 27
#define AND 28
#define OR 29
#define QUESTY 30
#define COLON 31
/*
* Unary operators. Unary minus and plus are represented by the (binary)
* lexemes MINUS and PLUS.
*/
#define NOT 32
#define BIT_NOT 33
/*
* Binary string operators:
*/
#define STREQ 34
#define STRNEQ 35
/*
* Mapping from lexemes to strings; used for debugging messages. These
* entries must match the order and number of the lexeme definitions above.
*/
static CONST char *CONST lexemeStrings[] = {
"LITERAL", "FUNCNAME",
"[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN", "UNKNOWN_CHAR",
"*", "/", "%", "+", "-",
"<<", ">>", "<", ">", "<=", ">=", "==", "!=",
"&", "^", "|", "&&", "||", "?", ":",
"!", "~", "eq", "ne",
};
/*
* Declarations for local procedures to this file:
*/
static int GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr));
static void LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr,
CONST char *extraInfo));
static int ParseAddExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseBitAndExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseBitOrExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseBitXorExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseCondExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseMaxDoubleLength _ANSI_ARGS_((CONST char *string,
CONST char *end));
static int ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static void PrependSubExprTokens _ANSI_ARGS_((CONST char *op,
int opBytes, CONST char *src, int srcBytes,
int firstIndex, ParseInfo *infoPtr));
/*
* Macro used to debug the execution of the recursive descent parser used
* to parse expressions.
*/
#ifdef TCL_COMPILE_DEBUG
#define HERE(production, level) \
if (traceParseExpr) { \
fprintf(stderr, "%*s%s: lexeme=%s, next=\"%.20s\"\n", \
(level), " ", (production), \
lexemeStrings[infoPtr->lexeme], infoPtr->next); \
}
#else
#define HERE(production, level)
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_ParseExpr --
*
* Given a string, this procedure parses the first Tcl expression
* in the string and returns information about the structure of
* the expression. This procedure is the top-level interface to the
* the expression parsing module. No more that numBytes bytes will
* be scanned.
*
* Results:
* The return value is TCL_OK if the command was parsed successfully
* and TCL_ERROR otherwise. If an error occurs and interp isn't NULL
* then an error message is left in its result. On a successful return,
* parsePtr is filled in with information about the expression that
* was parsed.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the expression, then additional space is
* malloc-ed. If the procedure returns TCL_OK then the caller must
* eventually invoke Tcl_FreeParse to release any additional space
* that was allocated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ParseExpr(interp, string, numBytes, parsePtr)
Tcl_Interp *interp; /* Used for error reporting. */
CONST char *string; /* The source string to parse. */
int numBytes; /* Number of bytes in string. If < 0, the
* string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr; /* Structure to fill with information about
* the parsed expression; any previous
* information in the structure is
* ignored. */
{
ParseInfo info;
int code;
if (numBytes < 0) {
numBytes = (string? strlen(string) : 0);
}
#ifdef TCL_COMPILE_DEBUG
if (traceParseExpr) {
fprintf(stderr, "Tcl_ParseExpr: string=\"%.*s\"\n",
numBytes, string);
}
#endif /* TCL_COMPILE_DEBUG */
parsePtr->commentStart = NULL;
parsePtr->commentSize = 0;
parsePtr->commandStart = NULL;
parsePtr->commandSize = 0;
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->term = string;
parsePtr->incomplete = 0;
/*
* Initialize the ParseInfo structure that holds state while parsing
* the expression.
*/
info.parsePtr = parsePtr;
info.lexeme = UNKNOWN;
info.start = NULL;
info.size = 0;
info.next = string;
info.prevEnd = string;
info.originalExpr = string;
info.lastChar = (string + numBytes); /* just after last char of expr */
/*
* Get the first lexeme then parse the expression.
*/
code = GetLexeme(&info);
if (code != TCL_OK) {
goto error;
}
code = ParseCondExpr(&info);
if (code != TCL_OK) {
goto error;
}
if (info.lexeme != END) {
LogSyntaxError(&info, "extra tokens at end of expression");
goto error;
}
return TCL_OK;
error:
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
ckfree((char *) parsePtr->tokenPtr);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ParseCondExpr --
*
* This procedure parses a Tcl conditional expression:
* condExpr ::= lorExpr ['?' condExpr ':' condExpr]
*
* Note that this is the topmost recursive-descent parsing routine used
* by Tcl_ParseExpr to parse expressions. This avoids an extra procedure
* call since such a procedure would only return the result of calling
* ParseCondExpr. Other recursive-descent procedures that need to parse
* complete expressions also call ParseCondExpr.
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseCondExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr;
int firstIndex, numToMove, code;
CONST char *srcStart;
HERE("condExpr", 1);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseLorExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
if (infoPtr->lexeme == QUESTY) {
/*
* Emit two tokens: one TCL_TOKEN_SUB_EXPR token for the entire
* conditional expression, and a TCL_TOKEN_OPERATOR token for
* the "?" operator. Note that these two tokens must be inserted
* before the LOR operand tokens generated above.
*/
if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
firstTokenPtr = &parsePtr->tokenPtr[firstIndex];
tokenPtr = (firstTokenPtr + 2);
numToMove = (parsePtr->numTokens - firstIndex);
memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr,
(size_t) (numToMove * sizeof(Tcl_Token)));
parsePtr->numTokens += 2;
tokenPtr = firstTokenPtr;
tokenPtr->type = TCL_TOKEN_SUB_EXPR;
tokenPtr->start = srcStart;
tokenPtr++;
tokenPtr->type = TCL_TOKEN_OPERATOR;
tokenPtr->start = infoPtr->start;
tokenPtr->size = 1;
tokenPtr->numComponents = 0;
/*
* Skip over the '?'.
*/
code = GetLexeme(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Parse the "then" expression.
*/
code = ParseCondExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
if (infoPtr->lexeme != COLON) {
LogSyntaxError(infoPtr, "missing colon from ternary conditional");
return TCL_ERROR;
}
code = GetLexeme(infoPtr); /* skip over the ':' */
if (code != TCL_OK) {
return code;
}
/*
* Parse the "else" expression.
*/
code = ParseCondExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Now set the size-related fields in the '?' subexpression token.
*/
condTokenPtr = &parsePtr->tokenPtr[firstIndex];
condTokenPtr->size = (infoPtr->prevEnd - srcStart);
condTokenPtr->numComponents = parsePtr->numTokens - (firstIndex+1);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseLorExpr --
*
* This procedure parses a Tcl logical or expression:
* lorExpr ::= landExpr {'||' landExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseLorExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
CONST char *srcStart, *operator;
HERE("lorExpr", 2);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseLandExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
while (infoPtr->lexeme == OR) {
operator = infoPtr->start;
code = GetLexeme(infoPtr); /* skip over the '||' */
if (code != TCL_OK) {
return code;
}
code = ParseLandExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Generate tokens for the LOR subexpression and the '||' operator.
*/
PrependSubExprTokens(operator, 2, srcStart,
(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseLandExpr --
*
* This procedure parses a Tcl logical and expression:
* landExpr ::= bitOrExpr {'&&' bitOrExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseLandExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
CONST char *srcStart, *operator;
HERE("landExpr", 3);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseBitOrExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
while (infoPtr->lexeme == AND) {
operator = infoPtr->start;
code = GetLexeme(infoPtr); /* skip over the '&&' */
if (code != TCL_OK) {
return code;
}
code = ParseBitOrExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Generate tokens for the LAND subexpression and the '&&' operator.
*/
PrependSubExprTokens(operator, 2, srcStart,
(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseBitOrExpr --
*
* This procedure parses a Tcl bitwise or expression:
* bitOrExpr ::= bitXorExpr {'|' bitXorExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseBitOrExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
CONST char *srcStart, *operator;
HERE("bitOrExpr", 4);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseBitXorExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
while (infoPtr->lexeme == BIT_OR) {
operator = infoPtr->start;
code = GetLexeme(infoPtr); /* skip over the '|' */
if (code != TCL_OK) {
return code;
}
code = ParseBitXorExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Generate tokens for the BITOR subexpression and the '|' operator.
*/
PrependSubExprTokens(operator, 1, srcStart,
(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseBitXorExpr --
*
* This procedure parses a Tcl bitwise exclusive or expression:
* bitXorExpr ::= bitAndExpr {'^' bitAndExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseBitXorExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
CONST char *srcStart, *operator;
HERE("bitXorExpr", 5);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseBitAndExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
while (infoPtr->lexeme == BIT_XOR) {
operator = infoPtr->start;
code = GetLexeme(infoPtr); /* skip over the '^' */
if (code != TCL_OK) {
return code;
}
code = ParseBitAndExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Generate tokens for the XOR subexpression and the '^' operator.
*/
PrependSubExprTokens(operator, 1, srcStart,
(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseBitAndExpr --
*
* This procedure parses a Tcl bitwise and expression:
* bitAndExpr ::= equalityExpr {'&' equalityExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseBitAndExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
CONST char *srcStart, *operator;
HERE("bitAndExpr", 6);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseEqualityExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
while (infoPtr->lexeme == BIT_AND) {
operator = infoPtr->start;
code = GetLexeme(infoPtr); /* skip over the '&' */
if (code != TCL_OK) {
return code;
}
code = ParseEqualityExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Generate tokens for the BITAND subexpression and '&' operator.
*/
PrependSubExprTokens(operator, 1, srcStart,
(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseEqualityExpr --
*
* This procedure parses a Tcl equality (inequality) expression:
* equalityExpr ::= relationalExpr
* {('==' | '!=' | 'ne' | 'eq') relationalExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseEqualityExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
CONST char *srcStart, *operator;
HERE("equalityExpr", 7);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseRelationalExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
lexeme = infoPtr->lexeme;
while ((lexeme == EQUAL) || (lexeme == NEQ)
|| (lexeme == STREQ) || (lexeme == STRNEQ)) {
operator = infoPtr->start;
code = GetLexeme(infoPtr); /* skip over ==, !=, 'eq' or 'ne' */
if (code != TCL_OK) {
return code;
}
code = ParseRelationalExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Generate tokens for the subexpression and '==', '!=', 'eq' or 'ne'
* operator.
*/
PrependSubExprTokens(operator, 2, srcStart,
(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
lexeme = infoPtr->lexeme;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseRelationalExpr --
*
* This procedure parses a Tcl relational expression:
* relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseRelationalExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, operatorSize, code;
CONST char *srcStart, *operator;
HERE("relationalExpr", 8);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseShiftExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
lexeme = infoPtr->lexeme;
while ((lexeme == LESS) || (lexeme == GREATER) || (lexeme == LEQ)
|| (lexeme == GEQ)) {
operator = infoPtr->start;
if ((lexeme == LEQ) || (lexeme == GEQ)) {
operatorSize = 2;
} else {
operatorSize = 1;
}
code = GetLexeme(infoPtr); /* skip over the operator */
if (code != TCL_OK) {
return code;
}
code = ParseShiftExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Generate tokens for the subexpression and the operator.
*/
PrependSubExprTokens(operator, operatorSize, srcStart,
(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
lexeme = infoPtr->lexeme;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseShiftExpr --
*
* This procedure parses a Tcl shift expression:
* shiftExpr ::= addExpr {('<<' | '>>') addExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseShiftExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
CONST char *srcStart, *operator;
HERE("shiftExpr", 9);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseAddExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
lexeme = infoPtr->lexeme;
while ((lexeme == LEFT_SHIFT) || (lexeme == RIGHT_SHIFT)) {
operator = infoPtr->start;
code = GetLexeme(infoPtr); /* skip over << or >> */
if (code != TCL_OK) {
return code;
}
code = ParseAddExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Generate tokens for the subexpression and '<<' or '>>' operator.
*/
PrependSubExprTokens(operator, 2, srcStart,
(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
lexeme = infoPtr->lexeme;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseAddExpr --
*
* This procedure parses a Tcl addition expression:
* addExpr ::= multiplyExpr {('+' | '-') multiplyExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseAddExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
CONST char *srcStart, *operator;
HERE("addExpr", 10);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseMultiplyExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
lexeme = infoPtr->lexeme;
while ((lexeme == PLUS) || (lexeme == MINUS)) {
operator = infoPtr->start;
code = GetLexeme(infoPtr); /* skip over + or - */
if (code != TCL_OK) {
return code;
}
code = ParseMultiplyExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Generate tokens for the subexpression and '+' or '-' operator.
*/
PrependSubExprTokens(operator, 1, srcStart,
(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
lexeme = infoPtr->lexeme;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseMultiplyExpr --
*
* This procedure parses a Tcl multiply expression:
* multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseMultiplyExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
CONST char *srcStart, *operator;
HERE("multiplyExpr", 11);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseUnaryExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
lexeme = infoPtr->lexeme;
while ((lexeme == MULT) || (lexeme == DIVIDE) || (lexeme == MOD)) {
operator = infoPtr->start;
code = GetLexeme(infoPtr); /* skip over * or / or % */
if (code != TCL_OK) {
return code;
}
code = ParseUnaryExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Generate tokens for the subexpression and * or / or % operator.
*/
PrependSubExprTokens(operator, 1, srcStart,
(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
lexeme = infoPtr->lexeme;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseUnaryExpr --
*
* This procedure parses a Tcl unary expression:
* unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParseUnaryExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
CONST char *srcStart, *operator;
HERE("unaryExpr", 12);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
lexeme = infoPtr->lexeme;
if ((lexeme == PLUS) || (lexeme == MINUS) || (lexeme == BIT_NOT)
|| (lexeme == NOT)) {
operator = infoPtr->start;
code = GetLexeme(infoPtr); /* skip over the unary operator */
if (code != TCL_OK) {
return code;
}
code = ParseUnaryExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
/*
* Generate tokens for the subexpression and the operator.
*/
PrependSubExprTokens(operator, 1, srcStart,
(infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
} else { /* must be a primaryExpr */
code = ParsePrimaryExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParsePrimaryExpr --
*
* This procedure parses a Tcl primary expression:
* primaryExpr ::= literal | varReference | quotedString |
* '[' command ']' | mathFuncCall | '(' condExpr ')'
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed.
*
*----------------------------------------------------------------------
*/
static int
ParsePrimaryExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
Tcl_Interp *interp = parsePtr->interp;
Tcl_Token *tokenPtr, *exprTokenPtr;
Tcl_Parse nested;
CONST char *dollarPtr, *stringStart, *termPtr, *src;
int lexeme, exprIndex, firstIndex, numToMove, code;
/*
* We simply recurse on parenthesized subexpressions.
*/
HERE("primaryExpr", 13);
lexeme = infoPtr->lexeme;
if (lexeme == OPEN_PAREN) {
code = GetLexeme(infoPtr); /* skip over the '(' */
if (code != TCL_OK) {
return code;
}
code = ParseCondExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
if (infoPtr->lexeme != CLOSE_PAREN) {
LogSyntaxError(infoPtr, "looking for close parenthesis");
return TCL_ERROR;
}
code = GetLexeme(infoPtr); /* skip over the ')' */
if (code != TCL_OK) {
return code;
}
return TCL_OK;
}
/*
* Start a TCL_TOKEN_SUB_EXPR token for the primary.
*/
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
exprIndex = parsePtr->numTokens;
exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
exprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
exprTokenPtr->start = infoPtr->start;
parsePtr->numTokens++;
/*
* Process the primary then finish setting the fields of the
* TCL_TOKEN_SUB_EXPR token. Note that we can't use the pointer now
* stored in "exprTokenPtr" in the code below since the token array
* might be reallocated.
*/
firstIndex = parsePtr->numTokens;
switch (lexeme) {
case LITERAL:
/*
* Int or double number.
*/
tokenizeLiteral:
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = infoPtr->start;
tokenPtr->size = infoPtr->size;
tokenPtr->numComponents = 0;
parsePtr->numTokens++;
exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
exprTokenPtr->size = infoPtr->size;
exprTokenPtr->numComponents = 1;
break;
case DOLLAR:
/*
* $var variable reference.
*/
dollarPtr = (infoPtr->next - 1);
code = Tcl_ParseVarName(interp, dollarPtr,
(infoPtr->lastChar - dollarPtr), parsePtr, 1);
if (code != TCL_OK) {
return code;
}
infoPtr->next = dollarPtr + parsePtr->tokenPtr[firstIndex].size;
exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
exprTokenPtr->size = parsePtr->tokenPtr[firstIndex].size;
exprTokenPtr->numComponents =
(parsePtr->tokenPtr[firstIndex].numComponents + 1);
break;
case QUOTE:
/*
* '"' string '"'
*/
stringStart = infoPtr->next;
code = Tcl_ParseQuotedString(interp, infoPtr->start,
(infoPtr->lastChar - stringStart), parsePtr, 1, &termPtr);
if (code != TCL_OK) {
return code;
}
infoPtr->next = termPtr;
exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
exprTokenPtr->size = (termPtr - exprTokenPtr->start);
exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
/*
* If parsing the quoted string resulted in more than one token,
* insert a TCL_TOKEN_WORD token before them. This indicates that
* the quoted string represents a concatenation of multiple tokens.
*/
if (exprTokenPtr->numComponents > 1) {
if (parsePtr->numTokens >= parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[firstIndex];
numToMove = (parsePtr->numTokens - firstIndex);
memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr,
(size_t) (numToMove * sizeof(Tcl_Token)));
parsePtr->numTokens++;
exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
exprTokenPtr->numComponents++;
tokenPtr->type = TCL_TOKEN_WORD;
tokenPtr->start = exprTokenPtr->start;
tokenPtr->size = exprTokenPtr->size;
tokenPtr->numComponents = (exprTokenPtr->numComponents - 1);
}
break;
case OPEN_BRACKET:
/*
* '[' command {command} ']'
*/
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->type = TCL_TOKEN_COMMAND;
tokenPtr->start = infoPtr->start;
tokenPtr->numComponents = 0;
parsePtr->numTokens++;
/*
* Call Tcl_ParseCommand repeatedly to parse the nested command(s)
* to find their end, then throw away that parse information.
*/
src = infoPtr->next;
while (1) {
if (Tcl_ParseCommand(interp, src, (parsePtr->end - src), 1,
&nested) != TCL_OK) {
parsePtr->term = nested.term;
parsePtr->errorType = nested.errorType;
parsePtr->incomplete = nested.incomplete;
return TCL_ERROR;
}
src = (nested.commandStart + nested.commandSize);
/*
* This is equivalent to Tcl_FreeParse(&nested), but
* presumably inlined here for sake of runtime optimization
*/
if (nested.tokenPtr != nested.staticTokens) {
ckfree((char *) nested.tokenPtr);
}
/*
* Check for the closing ']' that ends the command substitution.
* It must have been the last character of the parsed command.
*/
if ((nested.term < parsePtr->end) && (*nested.term == ']')
&& !nested.incomplete) {
break;
}
if (src == parsePtr->end) {
if (parsePtr->interp != NULL) {
Tcl_SetResult(interp, "missing close-bracket",
TCL_STATIC);
}
parsePtr->term = tokenPtr->start;
parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
parsePtr->incomplete = 1;
return TCL_ERROR;
}
}
tokenPtr->size = (src - tokenPtr->start);
infoPtr->next = src;
exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
exprTokenPtr->size = (src - tokenPtr->start);
exprTokenPtr->numComponents = 1;
break;
case OPEN_BRACE:
/*
* '{' string '}'
*/
code = Tcl_ParseBraces(interp, infoPtr->start,
(infoPtr->lastChar - infoPtr->start), parsePtr, 1,
&termPtr);
if (code != TCL_OK) {
return code;
}
infoPtr->next = termPtr;
exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
exprTokenPtr->size = (termPtr - infoPtr->start);
exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
/*
* If parsing the braced string resulted in more than one token,
* insert a TCL_TOKEN_WORD token before them. This indicates that
* the braced string represents a concatenation of multiple tokens.
*/
if (exprTokenPtr->numComponents > 1) {
if (parsePtr->numTokens >= parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[firstIndex];
numToMove = (parsePtr->numTokens - firstIndex);
memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr,
(size_t) (numToMove * sizeof(Tcl_Token)));
parsePtr->numTokens++;
exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
exprTokenPtr->numComponents++;
tokenPtr->type = TCL_TOKEN_WORD;
tokenPtr->start = exprTokenPtr->start;
tokenPtr->size = exprTokenPtr->size;
tokenPtr->numComponents = exprTokenPtr->numComponents-1;
}
break;
/*
* Disable attempt to support functions named "eq" or "ne". This
* is unworkable in the Tcl 8.4.* releases. See Tcl Bugs 1971879
* and 1201589.
*
case STREQ:
case STRNEQ:
*/
case FUNC_NAME: {
/*
* math_func '(' expr {',' expr} ')'
*/
ParseInfo savedInfo = *infoPtr;
code = GetLexeme(infoPtr); /* skip over function name */
if (code != TCL_OK) {
return code;
}
if (infoPtr->lexeme != OPEN_PAREN) {
int code;
Tcl_DString functionName;
Tcl_HashEntry *hPtr;
Interp *iPtr = (Interp *) infoPtr->parsePtr->interp;
Tcl_Obj *objPtr = Tcl_NewStringObj(savedInfo.start, savedInfo.size);
/* Check for boolean literals (true, false, yes, no, on, off) */
Tcl_IncrRefCount(objPtr);
code = Tcl_ConvertToType(NULL, objPtr, &tclBooleanType);
Tcl_DecrRefCount(objPtr);
if (code == TCL_OK) {
*infoPtr = savedInfo;
goto tokenizeLiteral;
}
/*
* Guess what kind of error we have by trying to tell
* whether we have a function or variable name here.
* Alas, this makes the parser more tightly bound with the
* rest of the interpreter, but that is the only way to
* give a sensible message here. Still, it is not too
* serious as this is only done when generating an error.
*/
/*
* Look up the name as a function name. We need a writable
* copy (DString) so we can terminate it with a NULL for
* the benefit of Tcl_FindHashEntry which operates on
* NULL-terminated string keys.
*/
Tcl_DStringInit(&functionName);
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
Tcl_DStringAppend(&functionName,
savedInfo.start, savedInfo.size));
Tcl_DStringFree(&functionName);
/*
* Assume that we have an attempted variable reference
* unless we've got a function name, as the set of
* potential function names is typically much smaller.
*/
if (hPtr != NULL) {
LogSyntaxError(infoPtr,
"expected parenthesis enclosing function arguments");
} else {
LogSyntaxError(infoPtr,
"variable references require preceding $");
}
return TCL_ERROR;
}
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->type = TCL_TOKEN_OPERATOR;
tokenPtr->start = savedInfo.start;
tokenPtr->size = savedInfo.size;
tokenPtr->numComponents = 0;
parsePtr->numTokens++;
code = GetLexeme(infoPtr); /* skip over '(' */
if (code != TCL_OK) {
return code;
}
while (infoPtr->lexeme != CLOSE_PAREN) {
code = ParseCondExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
if (infoPtr->lexeme == COMMA) {
code = GetLexeme(infoPtr); /* skip over , */
if (code != TCL_OK) {
return code;
}
} else if (infoPtr->lexeme != CLOSE_PAREN) {
LogSyntaxError(infoPtr,
"missing close parenthesis at end of function call");
return TCL_ERROR;
}
}
exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start);
exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
break;
}
case COMMA:
LogSyntaxError(infoPtr,
"commas can only separate function arguments");
return TCL_ERROR;
case END:
LogSyntaxError(infoPtr, "premature end of expression");
return TCL_ERROR;
case UNKNOWN:
LogSyntaxError(infoPtr, "single equality character not legal in expressions");
return TCL_ERROR;
case UNKNOWN_CHAR:
LogSyntaxError(infoPtr, "character not legal in expressions");
return TCL_ERROR;
case QUESTY:
LogSyntaxError(infoPtr, "unexpected ternary 'then' separator");
return TCL_ERROR;
case COLON:
LogSyntaxError(infoPtr, "unexpected ternary 'else' separator");
return TCL_ERROR;
case CLOSE_PAREN:
LogSyntaxError(infoPtr, "unexpected close parenthesis");
return TCL_ERROR;
default: {
char buf[64];
sprintf(buf, "unexpected operator %s", lexemeStrings[lexeme]);
LogSyntaxError(infoPtr, buf);
return TCL_ERROR;
}
}
/*
* Advance to the next lexeme before returning.
*/
code = GetLexeme(infoPtr);
if (code != TCL_OK) {
return code;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetLexeme --
*
* Lexical scanner for Tcl expressions: scans a single operator or
* other syntactic element from an expression string.
*
* Results:
* TCL_OK is returned unless an error occurred. In that case a standard
* Tcl error code is returned and, if infoPtr->parsePtr->interp is
* non-NULL, the interpreter's result is set to hold an error
* message. TCL_ERROR is returned if an integer overflow, or a
* floating-point overflow or underflow occurred while reading in a
* number. If the lexical analysis is successful, infoPtr->lexeme
* refers to the next symbol in the expression string, and
* infoPtr->next is advanced past the lexeme. Also, if the lexeme is a
* LITERAL or FUNC_NAME, then infoPtr->start is set to the first
* character of the lexeme; otherwise it is set NULL.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the subexpression, then additional space is
* malloc-ed..
*
*----------------------------------------------------------------------
*/
static int
GetLexeme(infoPtr)
ParseInfo *infoPtr; /* Holds state needed to parse the expr,
* including the resulting lexeme. */
{
register CONST char *src; /* Points to current source char. */
char c;
int offset, length, numBytes;
Tcl_Parse *parsePtr = infoPtr->parsePtr;
Tcl_Interp *interp = parsePtr->interp;
Tcl_UniChar ch;
/*
* Record where the previous lexeme ended. Since we always read one
* lexeme ahead during parsing, this helps us know the source length of
* subexpression tokens.
*/
infoPtr->prevEnd = infoPtr->next;
/*
* Scan over leading white space at the start of a lexeme.
*/
src = infoPtr->next;
numBytes = parsePtr->end - src;
do {
char type;
int scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
src += scanned; numBytes -= scanned;
} while (numBytes && (*src == '\n') && (src++,numBytes--));
parsePtr->term = src;
if (numBytes == 0) {
infoPtr->lexeme = END;
infoPtr->next = src;
return TCL_OK;
}
/*
* Try to parse the lexeme first as an integer or floating-point
* number. Don't check for a number if the first character c is
* "+" or "-". If we did, we might treat a binary operator as unary
* by mistake, which would eventually cause a syntax error.
*/
c = *src;
if ((c != '+') && (c != '-')) {
CONST char *end = infoPtr->lastChar;
if ((length = TclParseInteger(src, (end - src)))) {
/*
* First length bytes look like an integer. Verify by
* attempting the conversion to the largest integer we have.
*/
int code;
Tcl_WideInt wide;
Tcl_Obj *value = Tcl_NewStringObj(src, length);
Tcl_IncrRefCount(value);
code = Tcl_GetWideIntFromObj(interp, value, &wide);
Tcl_DecrRefCount(value);
if (code == TCL_ERROR) {
parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
return TCL_ERROR;
}
infoPtr->lexeme = LITERAL;
infoPtr->start = src;
infoPtr->size = length;
infoPtr->next = (src + length);
parsePtr->term = infoPtr->next;
return TCL_OK;
} else if ((length = ParseMaxDoubleLength(src, end))) {
/*
* There are length characters that could be a double.
* Let strtod() tells us for sure. Need a writable copy
* so we can set an terminating NULL to keep strtod from
* scanning too far.
*/
char *startPtr, *termPtr;
double doubleValue;
Tcl_DString toParse;
errno = 0;
Tcl_DStringInit(&toParse);
startPtr = Tcl_DStringAppend(&toParse, src, length);
doubleValue = strtod(startPtr, &termPtr);
Tcl_DStringFree(&toParse);
if (termPtr != startPtr) {
if (errno != 0) {
if (interp != NULL) {
TclExprFloatError(interp, doubleValue);
}
parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
return TCL_ERROR;
}
/*
* startPtr was the start of a valid double, copied
* from src.
*/
infoPtr->lexeme = LITERAL;
infoPtr->start = src;
if ((termPtr - startPtr) > length) {
infoPtr->size = length;
} else {
infoPtr->size = (termPtr - startPtr);
}
infoPtr->next = src + infoPtr->size;
parsePtr->term = infoPtr->next;
return TCL_OK;
}
}
}
/*
* Not an integer or double literal. Initialize the lexeme's fields
* assuming the common case of a single character lexeme.
*/
infoPtr->start = src;
infoPtr->size = 1;
infoPtr->next = src+1;
parsePtr->term = infoPtr->next;
switch (*src) {
case '[':
infoPtr->lexeme = OPEN_BRACKET;
return TCL_OK;
case '{':
infoPtr->lexeme = OPEN_BRACE;
return TCL_OK;
case '(':
infoPtr->lexeme = OPEN_PAREN;
return TCL_OK;
case ')':
infoPtr->lexeme = CLOSE_PAREN;
return TCL_OK;
case '$':
infoPtr->lexeme = DOLLAR;
return TCL_OK;
case '\"':
infoPtr->lexeme = QUOTE;
return TCL_OK;
case ',':
infoPtr->lexeme = COMMA;
return TCL_OK;
case '*':
infoPtr->lexeme = MULT;
return TCL_OK;
case '/':
infoPtr->lexeme = DIVIDE;
return TCL_OK;
case '%':
infoPtr->lexeme = MOD;
return TCL_OK;
case '+':
infoPtr->lexeme = PLUS;
return TCL_OK;
case '-':
infoPtr->lexeme = MINUS;
return TCL_OK;
case '?':
infoPtr->lexeme = QUESTY;
return TCL_OK;
case ':':
infoPtr->lexeme = COLON;
return TCL_OK;
case '<':
infoPtr->lexeme = LESS;
if ((infoPtr->lastChar - src) > 1) {
switch (src[1]) {
case '<':
infoPtr->lexeme = LEFT_SHIFT;
infoPtr->size = 2;
infoPtr->next = src+2;
break;
case '=':
infoPtr->lexeme = LEQ;
infoPtr->size = 2;
infoPtr->next = src+2;
break;
}
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '>':
infoPtr->lexeme = GREATER;
if ((infoPtr->lastChar - src) > 1) {
switch (src[1]) {
case '>':
infoPtr->lexeme = RIGHT_SHIFT;
infoPtr->size = 2;
infoPtr->next = src+2;
break;
case '=':
infoPtr->lexeme = GEQ;
infoPtr->size = 2;
infoPtr->next = src+2;
break;
}
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '=':
infoPtr->lexeme = UNKNOWN;
if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = EQUAL;
infoPtr->size = 2;
infoPtr->next = src+2;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '!':
infoPtr->lexeme = NOT;
if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = NEQ;
infoPtr->size = 2;
infoPtr->next = src+2;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '&':
infoPtr->lexeme = BIT_AND;
if ((src[1] == '&') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = AND;
infoPtr->size = 2;
infoPtr->next = src+2;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '^':
infoPtr->lexeme = BIT_XOR;
return TCL_OK;
case '|':
infoPtr->lexeme = BIT_OR;
if ((src[1] == '|') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = OR;
infoPtr->size = 2;
infoPtr->next = src+2;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '~':
infoPtr->lexeme = BIT_NOT;
return TCL_OK;
case 'e':
if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = STREQ;
infoPtr->size = 2;
infoPtr->next = src+2;
parsePtr->term = infoPtr->next;
return TCL_OK;
} else {
goto checkFuncName;
}
case 'n':
if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = STRNEQ;
infoPtr->size = 2;
infoPtr->next = src+2;
parsePtr->term = infoPtr->next;
return TCL_OK;
} else {
goto checkFuncName;
}
default:
checkFuncName:
length = (infoPtr->lastChar - src);
if (Tcl_UtfCharComplete(src, length)) {
offset = Tcl_UtfToUniChar(src, &ch);
} else {
char utfBytes[TCL_UTF_MAX];
memcpy(utfBytes, src, (size_t) length);
utfBytes[length] = '\0';
offset = Tcl_UtfToUniChar(utfBytes, &ch);
}
c = UCHAR(ch);
if (isalpha(UCHAR(c))) { /* INTL: ISO only. */
infoPtr->lexeme = FUNC_NAME;
while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */
src += offset; length -= offset;
if (Tcl_UtfCharComplete(src, length)) {
offset = Tcl_UtfToUniChar(src, &ch);
} else {
char utfBytes[TCL_UTF_MAX];
memcpy(utfBytes, src, (size_t) length);
utfBytes[length] = '\0';
offset = Tcl_UtfToUniChar(utfBytes, &ch);
}
c = UCHAR(ch);
}
infoPtr->size = (src - infoPtr->start);
infoPtr->next = src;
parsePtr->term = infoPtr->next;
return TCL_OK;
}
infoPtr->lexeme = UNKNOWN_CHAR;
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
* TclParseInteger --
*
* Scans up to numBytes bytes starting at src, and checks whether
* the leading bytes look like an integer's string representation.
*
* Results:
* Returns 0 if the leading bytes do not look like an integer.
* Otherwise, returns the number of bytes examined that look
* like an integer. This may be less than numBytes if the integer
* is only the leading part of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclParseInteger(string, numBytes)
register CONST char *string;/* The string to examine. */
register int numBytes; /* Max number of bytes to scan. */
{
register CONST char *p = string;
/* Take care of introductory "0x" */
if ((numBytes > 1) && (p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) {
int scanned;
Tcl_UniChar ch;
p+=2; numBytes -= 2;
scanned = TclParseHex(p, numBytes, &ch);
if (scanned) {
return scanned + 2;
}
/* Recognize the 0 as valid integer, but x is left behind */
return 1;
}
while (numBytes && isdigit(UCHAR(*p))) { /* INTL: digit */
numBytes--; p++;
}
if (numBytes == 0) {
return (p - string);
}
if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
return (p - string);
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* ParseMaxDoubleLength --
*
* Scans a sequence of bytes checking that the characters could
* be in a string rep of a double.
*
* Results:
* Returns the number of bytes starting with string, runing to, but
* not including end, all of which could be part of a string rep.
* of a double. Only character identity is used, no actual
* parsing is done.
*
* The legal bytes are '0' - '9', 'A' - 'F', 'a' - 'f',
* '.', '+', '-', 'i', 'I', 'n', 'N', 'p', 'P', 'x', and 'X'.
* This covers the values "Inf" and "Nan" as well as the
* decimal and hexadecimal representations recognized by a
* C99-compliant strtod().
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ParseMaxDoubleLength(string, end)
register CONST char *string;/* The string to examine. */
CONST char *end; /* Point to the first character past the end
* of the string we are examining. */
{
CONST char *p = string;
while (p < end) {
switch (*p) {
case '0': case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9': case 'A': case 'B':
case 'C': case 'D': case 'E': case 'F': case 'I': case 'N':
case 'P': case 'X': case 'a': case 'b': case 'c': case 'd':
case 'e': case 'f': case 'i': case 'n': case 'p': case 'x':
case '.': case '+': case '-':
p++;
break;
default:
goto done;
}
}
done:
return (p - string);
}
/*
*----------------------------------------------------------------------
*
* PrependSubExprTokens --
*
* This procedure is called after the operands of an subexpression have
* been parsed. It generates two tokens: a TCL_TOKEN_SUB_EXPR token for
* the subexpression, and a TCL_TOKEN_OPERATOR token for its operator.
* These two tokens are inserted before the operand tokens.
*
* Results:
* None.
*
* Side effects:
* If there is insufficient space in parsePtr to hold the new tokens,
* additional space is malloc-ed.
*
*----------------------------------------------------------------------
*/
static void
PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr)
CONST char *op; /* Points to first byte of the operator
* in the source script. */
int opBytes; /* Number of bytes in the operator. */
CONST char *src; /* Points to first byte of the subexpression
* in the source script. */
int srcBytes; /* Number of bytes in subexpression's
* source. */
int firstIndex; /* Index of first token already emitted for
* operator's first (or only) operand. */
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
Tcl_Token *tokenPtr, *firstTokenPtr;
int numToMove;
if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
firstTokenPtr = &parsePtr->tokenPtr[firstIndex];
tokenPtr = (firstTokenPtr + 2);
numToMove = (parsePtr->numTokens - firstIndex);
memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr,
(size_t) (numToMove * sizeof(Tcl_Token)));
parsePtr->numTokens += 2;
tokenPtr = firstTokenPtr;
tokenPtr->type = TCL_TOKEN_SUB_EXPR;
tokenPtr->start = src;
tokenPtr->size = srcBytes;
tokenPtr->numComponents = parsePtr->numTokens - (firstIndex + 1);
tokenPtr++;
tokenPtr->type = TCL_TOKEN_OPERATOR;
tokenPtr->start = op;
tokenPtr->size = opBytes;
tokenPtr->numComponents = 0;
}
/*
*----------------------------------------------------------------------
*
* LogSyntaxError --
*
* This procedure is invoked after an error occurs when parsing an
* expression. It sets the interpreter result to an error message
* describing the error.
*
* Results:
* None.
*
* Side effects:
* Sets the interpreter result to an error message describing the
* expression that was being parsed when the error occurred, and why
* the parser considers that to be a syntax error at all.
*
*----------------------------------------------------------------------
*/
static void
LogSyntaxError(infoPtr, extraInfo)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
CONST char *extraInfo; /* String to provide extra information
* about the syntax error. */
{
int numBytes = (infoPtr->lastChar - infoPtr->originalExpr);
char buffer[100];
if (numBytes > 60) {
sprintf(buffer, "syntax error in expression \"%.60s...\"",
infoPtr->originalExpr);
} else {
sprintf(buffer, "syntax error in expression \"%.*s\"",
numBytes, infoPtr->originalExpr);
}
Tcl_ResetResult(infoPtr->parsePtr->interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->parsePtr->interp),
buffer, ": ", extraInfo, (char *) NULL);
infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX;
infoPtr->parsePtr->term = infoPtr->start;
}
tcl8.4.20/generic/regerror.c 0000644 0036047 0045461 00000006662 12052456743 014336 0 ustar dgp 771div /*
* regerror - error-code expansion
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*/
#include "regguts.h"
/* unknown-error explanation */
static CONST char unk[] = "*** unknown regex error code 0x%x ***";
/* struct to map among codes, code names, and explanations */
static struct rerr {
int code;
char *name;
char *explain;
} rerrs[] = {
/* the actual table is built from regex.h */
# include "regerrs.h"
{ -1, "", "oops" }, /* explanation special-cased in code */
};
/*
- regerror - the interface to error numbers
*/
/* ARGSUSED */
size_t /* actual space needed (including NUL) */
regerror(code, preg, errbuf, errbuf_size)
int code; /* error code, or REG_ATOI or REG_ITOA */
CONST regex_t *preg; /* associated regex_t (unused at present) */
char *errbuf; /* result buffer (unless errbuf_size==0) */
size_t errbuf_size; /* available space in errbuf, can be 0 */
{
struct rerr *r;
char *msg;
char convbuf[sizeof(unk)+50]; /* 50 = plenty for int */
size_t len;
int icode;
switch (code) {
case REG_ATOI: /* convert name to number */
for (r = rerrs; r->code >= 0; r++)
if (strcmp(r->name, errbuf) == 0)
break;
sprintf(convbuf, "%d", r->code); /* -1 for unknown */
msg = convbuf;
break;
case REG_ITOA: /* convert number to name */
icode = atoi(errbuf); /* not our problem if this fails */
for (r = rerrs; r->code >= 0; r++)
if (r->code == icode)
break;
if (r->code >= 0)
msg = r->name;
else { /* unknown; tell him the number */
sprintf(convbuf, "REG_%u", (unsigned)icode);
msg = convbuf;
}
break;
default: /* a real, normal error code */
for (r = rerrs; r->code >= 0; r++)
if (r->code == code)
break;
if (r->code >= 0)
msg = r->explain;
else { /* unknown; say so */
sprintf(convbuf, unk, code);
msg = convbuf;
}
break;
}
len = strlen(msg) + 1; /* space needed, including NUL */
if (errbuf_size > 0) {
if (errbuf_size > len)
strcpy(errbuf, msg);
else { /* truncate to fit */
strncpy(errbuf, msg, errbuf_size-1);
errbuf[errbuf_size-1] = '\0';
}
}
return len;
}
tcl8.4.20/generic/regc_cvec.c 0000644 0036047 0045461 00000011277 11737050674 014427 0 ustar dgp 771div /*
* Utility functions for handling cvecs
* This file is #included by regcomp.c.
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*/
/*
- newcvec - allocate a new cvec
^ static struct cvec *newcvec(int, int, int);
*/
static struct cvec *
newcvec(nchrs, nranges, nmcces)
int nchrs; /* to hold this many chrs... */
int nranges; /* ... and this many ranges... */
int nmcces; /* ... and this many MCCEs */
{
size_t n;
size_t nc;
struct cvec *cv;
nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2;
n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *)
+ nc*sizeof(chr);
cv = (struct cvec *)MALLOC(n);
if (cv == NULL) {
return NULL;
}
cv->chrspace = nchrs;
cv->chrs = (chr *)&cv->mcces[nmcces]; /* chrs just after MCCE ptrs */
cv->mccespace = nmcces;
cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1);
cv->rangespace = nranges;
return clearcvec(cv);
}
/*
- clearcvec - clear a possibly-new cvec
* Returns pointer as convenience.
^ static struct cvec *clearcvec(struct cvec *);
*/
static struct cvec *
clearcvec(cv)
struct cvec *cv; /* character vector */
{
int i;
assert(cv != NULL);
cv->nchrs = 0;
assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]);
cv->nmcces = 0;
cv->nmccechrs = 0;
cv->nranges = 0;
for (i = 0; i < cv->mccespace; i++) {
cv->mcces[i] = NULL;
}
return cv;
}
/*
- addchr - add a chr to a cvec
^ static VOID addchr(struct cvec *, pchr);
*/
static VOID
addchr(cv, c)
struct cvec *cv; /* character vector */
pchr c; /* character to add */
{
assert(cv->nchrs < cv->chrspace - cv->nmccechrs);
cv->chrs[cv->nchrs++] = (chr)c;
}
/*
- addrange - add a range to a cvec
^ static VOID addrange(struct cvec *, pchr, pchr);
*/
static VOID
addrange(cv, from, to)
struct cvec *cv; /* character vector */
pchr from; /* first character of range */
pchr to; /* last character of range */
{
assert(cv->nranges < cv->rangespace);
cv->ranges[cv->nranges*2] = (chr)from;
cv->ranges[cv->nranges*2 + 1] = (chr)to;
cv->nranges++;
}
/*
- haschr - does a cvec contain this chr?
^ static int haschr(struct cvec *, pchr);
*/
static int /* predicate */
haschr(cv, c)
struct cvec *cv; /* character vector */
pchr c; /* character to test for */
{
int i;
chr *p;
for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) {
if (*p == c) {
return 1;
}
}
for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) {
if ((*p <= c) && (c <= *(p+1))) {
return 1;
}
}
return 0;
}
/*
- getcvec - get a cvec, remembering it as v->cv
^ static struct cvec *getcvec(struct vars *, int, int);
*/
static struct cvec *
getcvec(v, nchrs, nranges)
struct vars *v; /* context */
int nchrs; /* to hold this many chrs... */
int nranges; /* ... and this many ranges... */
{
if (v->cv != NULL && nchrs <= v->cv->chrspace &&
nranges <= v->cv->rangespace) {
return clearcvec(v->cv);
}
if (v->cv != NULL) {
freecvec(v->cv);
}
v->cv = newcvec(nchrs, nranges, 0);
if (v->cv == NULL) {
ERR(REG_ESPACE);
}
return v->cv;
}
/*
- freecvec - free a cvec
^ static VOID freecvec(struct cvec *);
*/
static VOID
freecvec(cv)
struct cvec *cv; /* character vector */
{
FREE(cv);
}
tcl8.4.20/generic/tclFCmd.c 0000644 0036047 0045461 00000070572 12133546540 014017 0 ustar dgp 771div /*
* tclFCmd.c
*
* This file implements the generic portion of file manipulation
* subcommands of the "file" command.
*
* Copyright (c) 1996-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.
*/
#ifndef _WIN64
/* See [Bug 3354324]: file mtime sets wrong time */
# define _USE_32BIT_TIME_T
#endif
#include
#include "tclInt.h"
#include "tclPort.h"
/*
* Declarations for local procedures defined in this file:
*/
static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
int copyFlag, int force));
static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr));
static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[], int copyFlag));
static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[], int *forcePtr));
/*
*---------------------------------------------------------------------------
*
* TclFileRenameCmd
*
* This procedure implements the "rename" subcommand of the "file"
* command. Filename arguments need to be translated to native
* format before being passed to platform-specific code that
* implements rename functionality.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*---------------------------------------------------------------------------
*/
int
TclFileRenameCmd(interp, objc, objv)
Tcl_Interp *interp; /* Interp for error reporting. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 0);
}
/*
*---------------------------------------------------------------------------
*
* TclFileCopyCmd
*
* This procedure implements the "copy" subcommand of the "file"
* command. Filename arguments need to be translated to native
* format before being passed to platform-specific code that
* implements copy functionality.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*---------------------------------------------------------------------------
*/
int
TclFileCopyCmd(interp, objc, objv)
Tcl_Interp *interp; /* Used for error reporting */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 1);
}
/*
*---------------------------------------------------------------------------
*
* FileCopyRename --
*
* Performs the work of TclFileRenameCmd and TclFileCopyCmd.
* See comments for those procedures.
*
* Results:
* See above.
*
* Side effects:
* See above.
*
*---------------------------------------------------------------------------
*/
static int
FileCopyRename(interp, objc, objv, copyFlag)
Tcl_Interp *interp; /* Used for error reporting. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
int copyFlag; /* If non-zero, copy source(s). Otherwise,
* rename them. */
{
int i, result, force;
Tcl_StatBuf statBuf;
Tcl_Obj *target;
i = FileForceOption(interp, objc - 2, objv + 2, &force);
if (i < 0) {
return TCL_ERROR;
}
i += 2;
if ((objc - i) < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
" ?options? source ?source ...? target\"",
(char *) NULL);
return TCL_ERROR;
}
/*
* If target doesn't exist or isn't a directory, try the copy/rename.
* More than 2 arguments is only valid if the target is an existing
* directory.
*/
target = objv[objc - 1];
if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
return TCL_ERROR;
}
result = TCL_OK;
/*
* Call Tcl_FSStat() so that if target is a symlink that points to a
* directory we will put the sources in that directory instead of
* overwriting the symlink.
*/
if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
if ((objc - i) > 2) {
errno = ENOTDIR;
Tcl_PosixError(interp);
Tcl_AppendResult(interp, "error ",
((copyFlag) ? "copying" : "renaming"), ": target \"",
Tcl_GetString(target), "\" is not a directory",
(char *) NULL);
result = TCL_ERROR;
} else {
/*
* Even though already have target == translated(objv[i+1]),
* pass the original argument down, so if there's an error, the
* error message will reflect the original arguments.
*/
result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag,
force);
}
return result;
}
/*
* Move each source file into target directory. Extract the basename
* from each source, and append it to the end of the target path.
*/
for ( ; i < objc - 1; i++) {
Tcl_Obj *jargv[2];
Tcl_Obj *source, *newFileName;
Tcl_Obj *temp;
source = FileBasename(interp, objv[i]);
if (source == NULL) {
result = TCL_ERROR;
break;
}
jargv[0] = objv[objc - 1];
jargv[1] = source;
temp = Tcl_NewListObj(2, jargv);
newFileName = Tcl_FSJoinPath(temp, -1);
Tcl_IncrRefCount(newFileName);
result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
force);
Tcl_DecrRefCount(newFileName);
Tcl_DecrRefCount(temp);
Tcl_DecrRefCount(source);
if (result == TCL_ERROR) {
break;
}
}
return result;
}
/*
*---------------------------------------------------------------------------
*
* TclFileMakeDirsCmd
*
* This procedure implements the "mkdir" subcommand of the "file"
* command. Filename arguments need to be translated to native
* format before being passed to platform-specific code that
* implements mkdir functionality.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
TclFileMakeDirsCmd(interp, objc, objv)
Tcl_Interp *interp; /* Used for error reporting. */
int objc; /* Number of arguments */
Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
Tcl_Obj *errfile;
int result, i, j, pobjc;
Tcl_Obj *split = NULL;
Tcl_Obj *target = NULL;
Tcl_StatBuf statBuf;
errfile = NULL;
result = TCL_OK;
for (i = 2; i < objc; i++) {
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
result = TCL_ERROR;
break;
}
split = Tcl_FSSplitPath(objv[i],&pobjc);
if (pobjc == 0) {
errno = ENOENT;
errfile = objv[i];
break;
}
for (j = 0; j < pobjc; j++) {
target = Tcl_FSJoinPath(split, j + 1);
Tcl_IncrRefCount(target);
/*
* Call Tcl_FSStat() so that if target is a symlink that
* points to a directory we will create subdirectories in
* that directory.
*/
if (Tcl_FSStat(target, &statBuf) == 0) {
if (!S_ISDIR(statBuf.st_mode)) {
errno = EEXIST;
errfile = target;
goto done;
}
} else if (errno != ENOENT) {
/*
* If Tcl_FSStat() failed and the error is anything
* other than non-existence of the target, throw the
* error.
*/
errfile = target;
goto done;
} else if (Tcl_FSCreateDirectory(target) != TCL_OK) {
/*
* Create might have failed because of being in a race
* condition with another process trying to create the
* same subdirectory.
*/
if (errno == EEXIST) {
if ((Tcl_FSStat(target, &statBuf) == 0)
&& S_ISDIR(statBuf.st_mode)) {
/*
* It is a directory that wasn't there before,
* so keep going without error.
*/
Tcl_ResetResult(interp);
} else {
errfile = target;
goto done;
}
} else {
errfile = target;
goto done;
}
}
/* Forget about this sub-path */
Tcl_DecrRefCount(target);
target = NULL;
}
Tcl_DecrRefCount(split);
split = NULL;
}
done:
if (errfile != NULL) {
Tcl_AppendResult(interp, "can't create directory \"",
Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp),
(char *) NULL);
result = TCL_ERROR;
}
if (split != NULL) {
Tcl_DecrRefCount(split);
}
if (target != NULL) {
Tcl_DecrRefCount(target);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclFileDeleteCmd
*
* This procedure implements the "delete" subcommand of the "file"
* command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
TclFileDeleteCmd(interp, objc, objv)
Tcl_Interp *interp; /* Used for error reporting */
int objc; /* Number of arguments */
Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
int i, force, result;
Tcl_Obj *errfile;
Tcl_Obj *errorBuffer = NULL;
i = FileForceOption(interp, objc - 2, objv + 2, &force);
if (i < 0) {
return TCL_ERROR;
}
i += 2;
if ((objc - i) < 1) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
" ?options? file ?file ...?\"", (char *) NULL);
return TCL_ERROR;
}
errfile = NULL;
result = TCL_OK;
for ( ; i < objc; i++) {
Tcl_StatBuf statBuf;
errfile = objv[i];
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
/*
* Call lstat() to get info so can delete symbolic link itself.
*/
if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
/*
* Trying to delete a file that does not exist is not
* considered an error, just a no-op
*/
if (errno != ENOENT) {
result = TCL_ERROR;
}
} else if (S_ISDIR(statBuf.st_mode)) {
/*
* We own a reference count on errorBuffer, if it was set
* as a result of this call.
*/
result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
if (result != TCL_OK) {
if ((force == 0) && (errno == EEXIST)) {
Tcl_AppendResult(interp, "error deleting \"",
Tcl_GetString(objv[i]),
"\": directory not empty", (char *) NULL);
Tcl_PosixError(interp);
goto done;
}
/*
* If possible, use the untranslated name for the file.
*/
errfile = errorBuffer;
/* FS supposed to check between translated objv and errfile */
if (Tcl_FSEqualPaths(objv[i], errfile)) {
errfile = objv[i];
}
}
} else {
result = Tcl_FSDeleteFile(objv[i]);
}
if (result != TCL_OK) {
result = TCL_ERROR;
/*
* It is important that we break on error, otherwise we
* might end up owning reference counts on numerous
* errorBuffers.
*/
break;
}
}
if (result != TCL_OK) {
if (errfile == NULL) {
/*
* We try to accomodate poor error results from our
* Tcl_FS calls
*/
Tcl_AppendResult(interp, "error deleting unknown file: ",
Tcl_PosixError(interp), (char *) NULL);
} else {
Tcl_AppendResult(interp, "error deleting \"",
Tcl_GetString(errfile), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
}
done:
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
}
return result;
}
/*
*---------------------------------------------------------------------------
*
* CopyRenameOneFile
*
* Copies or renames specified source file or directory hierarchy
* to the specified target.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Target is overwritten if the force flag is set. Attempting to
* copy/rename a file onto a directory or a directory onto a file
* will always result in an error.
*
*----------------------------------------------------------------------
*/
static int
CopyRenameOneFile(interp, source, target, copyFlag, force)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *source; /* Pathname of file to copy. May need to
* be translated. */
Tcl_Obj *target; /* Pathname of file to create/overwrite.
* May need to be translated. */
int copyFlag; /* If non-zero, copy files. Otherwise,
* rename them. */
int force; /* If non-zero, overwrite target file if it
* exists. Otherwise, error if target already
* exists. */
{
int result;
Tcl_Obj *errfile, *errorBuffer;
/* If source is a link, then this is the real file/directory */
Tcl_Obj *actualSource = NULL;
Tcl_StatBuf sourceStatBuf, targetStatBuf;
if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
return TCL_ERROR;
}
errfile = NULL;
errorBuffer = NULL;
result = TCL_ERROR;
/*
* We want to copy/rename links and not the files they point to, so we
* use lstat(). If target is a link, we also want to replace the
* link and not the file it points to, so we also use lstat() on the
* target.
*/
if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
errfile = source;
goto done;
}
if (Tcl_FSLstat(target, &targetStatBuf) != 0) {
if (errno != ENOENT) {
errfile = target;
goto done;
}
} else {
if (force == 0) {
errno = EEXIST;
errfile = target;
goto done;
}
/*
* Prevent copying or renaming a file onto itself. On Windows since
* 8.5 we do get an inode number, however the unsigned short field is
* insufficient to accept the Win32 API file id so it is truncated to
* 16 bits and we get collisions. See bug #2015723.
*/
#if !defined(WIN32) && !defined(__CYGWIN__)
if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
(sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
result = TCL_OK;
goto done;
}
}
#endif
/*
* Prevent copying/renaming a file onto a directory and
* vice-versa. This is a policy decision based on the fact that
* existing implementations of copy and rename on all platforms
* also prevent this.
*/
if (S_ISDIR(sourceStatBuf.st_mode)
&& !S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
Tcl_AppendResult(interp, "can't overwrite file \"",
Tcl_GetString(target), "\" with directory \"",
Tcl_GetString(source), "\"", (char *) NULL);
goto done;
}
if (!S_ISDIR(sourceStatBuf.st_mode)
&& S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
Tcl_AppendResult(interp, "can't overwrite directory \"",
Tcl_GetString(target), "\" with file \"",
Tcl_GetString(source), "\"", (char *) NULL);
goto done;
}
}
if (copyFlag == 0) {
result = Tcl_FSRenameFile(source, target);
if (result == TCL_OK) {
goto done;
}
if (errno == EINVAL) {
Tcl_AppendResult(interp, "error renaming \"",
Tcl_GetString(source), "\" to \"",
Tcl_GetString(target), "\": trying to rename a volume or ",
"move a directory into itself", (char *) NULL);
goto done;
} else if (errno != EXDEV) {
errfile = target;
goto done;
}
/*
* The rename failed because the move was across file systems.
* Fall through to copy file and then remove original. Note that
* the low-level Tcl_FSRenameFileProc in the filesystem is allowed
* to implement cross-filesystem moves itself, if it desires.
*/
}
actualSource = source;
Tcl_IncrRefCount(actualSource);
#if 0
#ifdef S_ISLNK
/*
* To add a flag to make 'copy' copy links instead of files, we could
* add a condition to ignore this 'if' here.
*/
if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
/*
* We want to copy files not links. Therefore we must follow the
* link. There are two purposes to this 'stat' call here. First
* we want to know if the linked-file/dir actually exists, and
* second, in the block of code which follows, some 20 lines
* down, we want to check if the thing is a file or directory.
*/
if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
/* Actual file doesn't exist */
Tcl_AppendResult(interp,
"error copying \"", Tcl_GetString(source),
"\": the target of this link doesn't exist",
(char *) NULL);
goto done;
} else {
int counter = 0;
while (1) {
Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
if (path == NULL) {
break;
}
Tcl_DecrRefCount(actualSource);
actualSource = path;
counter++;
/* Arbitrary limit of 20 links to follow */
if (counter > 20) {
/* Too many links */
Tcl_SetErrno(EMLINK);
errfile = source;
goto done;
}
}
/* Now 'actualSource' is the correct file */
}
}
#endif
#endif
if (S_ISDIR(sourceStatBuf.st_mode)) {
result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
if (result != TCL_OK) {
if (errno == EXDEV) {
/*
* The copy failed because we're trying to do a
* cross-filesystem copy. We do this through our Tcl
* library.
*/
Tcl_SavedResult savedResult;
Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL);
Tcl_IncrRefCount(copyCommand);
Tcl_ListObjAppendElement(interp, copyCommand,
Tcl_NewStringObj("::tcl::CopyDirectory",-1));
if (copyFlag) {
Tcl_ListObjAppendElement(interp, copyCommand,
Tcl_NewStringObj("copying",-1));
} else {
Tcl_ListObjAppendElement(interp, copyCommand,
Tcl_NewStringObj("renaming",-1));
}
Tcl_ListObjAppendElement(interp, copyCommand, source);
Tcl_ListObjAppendElement(interp, copyCommand, target);
Tcl_SaveResult(interp, &savedResult);
result = Tcl_EvalObjEx(interp, copyCommand,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
Tcl_DecrRefCount(copyCommand);
if (result != TCL_OK) {
/*
* There was an error in the Tcl-level copy.
* We will pass on the Tcl error message and
* can ensure this by setting errfile to NULL
*/
Tcl_DiscardResult(&savedResult);
errfile = NULL;
} else {
/* The copy was successful */
Tcl_RestoreResult(interp, &savedResult);
}
} else {
errfile = errorBuffer;
if (Tcl_FSEqualPaths(errfile, source)) {
errfile = source;
} else if (Tcl_FSEqualPaths(errfile, target)) {
errfile = target;
}
}
}
} else {
result = Tcl_FSCopyFile(actualSource, target);
if ((result != TCL_OK) && (errno == EXDEV)) {
result = TclCrossFilesystemCopy(interp, source, target);
}
if (result != TCL_OK) {
/*
* We could examine 'errno' to double-check if the problem
* was with the target, but we checked the source above,
* so it should be quite clear
*/
errfile = target;
}
/*
* We now need to reset the result, because the above call,
* may have left set it. (Ideally we would prefer not to pass
* an interpreter in above, but the channel IO code used by
* TclCrossFilesystemCopy currently requires one)
*/
Tcl_ResetResult(interp);
}
if ((copyFlag == 0) && (result == TCL_OK)) {
if (S_ISDIR(sourceStatBuf.st_mode)) {
result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
if (result != TCL_OK) {
if (Tcl_FSEqualPaths(errfile, source) == 0) {
errfile = source;
}
}
} else {
result = Tcl_FSDeleteFile(source);
if (result != TCL_OK) {
errfile = source;
}
}
if (result != TCL_OK) {
Tcl_AppendResult(interp, "can't unlink \"",
Tcl_GetString(errfile), "\": ",
Tcl_PosixError(interp), (char *) NULL);
errfile = NULL;
}
}
done:
if (errfile != NULL) {
Tcl_AppendResult(interp,
((copyFlag) ? "error copying \"" : "error renaming \""),
Tcl_GetString(source), (char *) NULL);
if (errfile != source) {
Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target),
(char *) NULL);
if (errfile != target) {
Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile),
(char *) NULL);
}
}
Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
(char *) NULL);
}
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
}
if (actualSource != NULL) {
Tcl_DecrRefCount(actualSource);
}
return result;
}
/*
*---------------------------------------------------------------------------
*
* FileForceOption --
*
* Helps parse command line options for file commands that take
* the "-force" and "--" options.
*
* Results:
* The return value is how many arguments from argv were consumed
* by this function, or -1 if there was an error parsing the
* options. If an error occurred, an error message is left in the
* interp's result.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static int
FileForceOption(interp, objc, objv, forcePtr)
Tcl_Interp *interp; /* Interp, for error return. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument strings. First command line
* option, if it exists, begins at 0. */
int *forcePtr; /* If the "-force" was specified, *forcePtr
* is filled with 1, otherwise with 0. */
{
int force, i;
force = 0;
for (i = 0; i < objc; i++) {
if (Tcl_GetString(objv[i])[0] != '-') {
break;
}
if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) {
force = 1;
} else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) {
i++;
break;
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]),
"\": should be -force or --", (char *)NULL);
return -1;
}
}
*forcePtr = force;
return i;
}
/*
*---------------------------------------------------------------------------
*
* FileBasename --
*
* Given a path in either tcl format (with / separators), or in the
* platform-specific format for the current platform, return all the
* characters in the path after the last directory separator. But,
* if path is the root directory, returns no characters.
*
* Results:
* Returns the string object that represents the basename. If there
* is an error, an error message is left in interp, and NULL is
* returned.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj *
FileBasename(interp, pathPtr)
Tcl_Interp *interp; /* Interp, for error return. */
Tcl_Obj *pathPtr; /* Path whose basename to extract. */
{
int objc;
Tcl_Obj *splitPtr;
Tcl_Obj *resultPtr = NULL;
splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
if (objc != 0) {
if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) {
Tcl_DecrRefCount(splitPtr);
if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
return NULL;
}
splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
}
/*
* Return the last component, unless it is the only component, and it
* is the root of an absolute path.
*/
if (objc > 0) {
Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
if ((objc == 1) &&
(Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
resultPtr = NULL;
}
}
}
if (resultPtr == NULL) {
resultPtr = Tcl_NewObj();
}
Tcl_IncrRefCount(resultPtr);
Tcl_DecrRefCount(splitPtr);
return resultPtr;
}
/*
*----------------------------------------------------------------------
*
* TclFileAttrsCmd --
*
* Sets or gets the platform-specific attributes of a file. The
* objc-objv points to the file name with the rest of the command
* line following. This routine uses platform-specific tables of
* option strings and callbacks. The callback to get the
* attributes take three parameters:
* Tcl_Interp *interp; The interp to report errors with.
* Since this is an object-based API,
* the object form of the result should
* be used.
* CONST char *fileName; This is extracted using
* Tcl_TranslateFileName.
* TclObj **attrObjPtrPtr; A new object to hold the attribute
* is allocated and put here.
* The first two parameters of the callback used to write out the
* attributes are the same. The third parameter is:
* CONST *attrObjPtr; A pointer to the object that has
* the new attribute.
* They both return standard TCL errors; if the routine to get
* an attribute fails, no object is allocated and *attrObjPtrPtr
* is unchanged.
*
* Results:
* Standard TCL error.
*
* Side effects:
* May set file attributes for the file name.
*
*----------------------------------------------------------------------
*/
int
TclFileAttrsCmd(interp, objc, objv)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int objc; /* Number of command line arguments. */
Tcl_Obj *CONST objv[]; /* The command line objects. */
{
int result;
CONST char ** attributeStrings;
Tcl_Obj* objStrings = NULL;
int numObjStrings = -1;
Tcl_Obj *filePtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv,
"name ?option? ?value? ?option value ...?");
return TCL_ERROR;
}
filePtr = objv[2];
if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
return TCL_ERROR;
}
objc -= 3;
objv += 3;
result = TCL_ERROR;
Tcl_SetErrno(0);
attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
if (attributeStrings == NULL) {
int index;
Tcl_Obj *objPtr;
if (objStrings == NULL) {
if (Tcl_GetErrno() != 0) {
/*
* There was an error, probably that the filePtr is
* not accepted by any filesystem
*/
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not read \"", Tcl_GetString(filePtr),
"\": ", Tcl_PosixError(interp),
(char *) NULL);
return TCL_ERROR;
}
goto end;
}
/* We own the object now */
Tcl_IncrRefCount(objStrings);
/* Use objStrings as a list object */
if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
}
attributeStrings = (CONST char **)
ckalloc ((1+numObjStrings) * sizeof(char*));
for (index = 0; index < numObjStrings; index++) {
Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
attributeStrings[index] = Tcl_GetString(objPtr);
}
attributeStrings[index] = NULL;
}
if (objc == 0) {
/*
* Get all attributes.
*/
int index;
Tcl_Obj *listPtr;
listPtr = Tcl_NewListObj(0, NULL);
for (index = 0; attributeStrings[index] != NULL; index++) {
Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1);
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
/* We now forget about objPtr, it is in the list */
objPtr = NULL;
if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
Tcl_DecrRefCount(listPtr);
goto end;
}
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
}
Tcl_SetObjResult(interp, listPtr);
} else if (objc == 1) {
/*
* Get one attribute.
*/
int index;
Tcl_Obj *objPtr = NULL;
if (numObjStrings == 0) {
Tcl_AppendResult(interp, "bad option \"",
Tcl_GetString(objv[0]), "\", there are no file attributes"
" in this filesystem.", (char *) NULL);
goto end;
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
"option", 0, &index) != TCL_OK) {
goto end;
}
if (numObjStrings != -1 && objv[0]->typePtr != NULL
&& objv[0]->typePtr->freeIntRepProc != NULL) {
objv[0]->typePtr->freeIntRepProc(objv[0]);
objv[0]->typePtr = NULL;
}
if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
goto end;
}
Tcl_SetObjResult(interp, objPtr);
} else {
/*
* Set option/value pairs.
*/
int i, index;
if (numObjStrings == 0) {
Tcl_AppendResult(interp, "bad option \"",
Tcl_GetString(objv[0]), "\", there are no file attributes"
" in this filesystem.", (char *) NULL);
goto end;
}
for (i = 0; i < objc ; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
"option", 0, &index) != TCL_OK) {
goto end;
}
if (numObjStrings != -1 && objv[i]->typePtr != NULL
&& objv[i]->typePtr->freeIntRepProc != NULL) {
objv[i]->typePtr->freeIntRepProc(objv[i]);
objv[i]->typePtr = NULL;
}
if (i + 1 == objc) {
Tcl_AppendResult(interp, "value for \"",
Tcl_GetString(objv[i]), "\" missing",
(char *) NULL);
goto end;
}
if (Tcl_FSFileAttrsSet(interp, index, filePtr,
objv[i + 1]) != TCL_OK) {
goto end;
}
}
}
result = TCL_OK;
end:
if (numObjStrings != -1) {
/* Free up the array we allocated */
ckfree((char*)attributeStrings);
/*
* We don't need this object that was passed to us
* any more.
*/
if (objStrings != NULL) {
Tcl_DecrRefCount(objStrings);
}
}
return result;
}
tcl8.4.20/generic/regfronts.c 0000644 0036047 0045461 00000004532 11737050674 014514 0 ustar dgp 771div /*
* regcomp and regexec - front ends to re_ routines
*
* Mostly for implementation of backward-compatibility kludges. Note
* that these routines exist ONLY in char versions.
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*/
#include "regguts.h"
/*
- regcomp - compile regular expression
*/
int
regcomp(re, str, flags)
regex_t *re;
CONST char *str;
int flags;
{
size_t len;
int f = flags;
if (f®_PEND) {
len = re->re_endp - str;
f &= ~REG_PEND;
} else
len = strlen(str);
return re_comp(re, str, len, f);
}
/*
- regexec - execute regular expression
*/
int
regexec(re, str, nmatch, pmatch, flags)
regex_t *re;
CONST char *str;
size_t nmatch;
regmatch_t pmatch[];
int flags;
{
CONST char *start;
size_t len;
int f = flags;
if (f®_STARTEND) {
start = str + pmatch[0].rm_so;
len = pmatch[0].rm_eo - pmatch[0].rm_so;
f &= ~REG_STARTEND;
} else {
start = str;
len = strlen(str);
}
return re_exec(re, start, len, nmatch, pmatch, f);
}
tcl8.4.20/generic/tclIOUtil.c 0000644 0036047 0045461 00000565725 12052456744 014372 0 ustar dgp 771div /*
* tclIOUtil.c --
*
* This file contains the implementation of Tcl's generic
* filesystem code, which supports a pluggable filesystem
* architecture allowing both platform specific filesystems and
* 'virtual filesystems'. All filesystem access should go through
* the functions defined in this file. Most of this code was
* contributed by Vince Darley.
*
* Parts of this file are based on code contributed by Karl
* Lehenbauer, Mark Diekhans and Peter da Silva.
*
* Copyright (c) 1991-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.
*/
#ifndef _WIN64
/* See [Bug 3354324]: file mtime sets wrong time */
# define _USE_32BIT_TIME_T
#endif
#include
#include "tclInt.h"
#include "tclPort.h"
#ifdef __WIN32__
/* for tclWinProcs->useWide */
#include "tclWinInt.h"
#endif
/*
* struct FilesystemRecord --
*
* A filesystem record is used to keep track of each
* filesystem currently registered with the core,
* in a linked list. Pointers to these structures
* are also kept by each "path" Tcl_Obj, and we must
* retain a refCount on the number of such references.
*/
typedef struct FilesystemRecord {
ClientData clientData; /* Client specific data for the new
* filesystem (can be NULL) */
Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch
* table. */
int fileRefCount; /* How many Tcl_Obj's use this
* filesystem. */
struct FilesystemRecord *nextPtr;
/* The next filesystem registered
* to Tcl, or NULL if no more. */
struct FilesystemRecord *prevPtr;
/* The previous filesystem registered
* to Tcl, or NULL if no more. */
} FilesystemRecord;
/*
* The internal TclFS API provides routines for handling and
* manipulating paths efficiently, taking direct advantage of
* the "path" Tcl_Obj type.
*
* These functions are not exported at all at present.
*/
int TclFSCwdPointerEquals _ANSI_ARGS_((Tcl_Obj* objPtr));
int TclFSMakePathFromNormalized _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
int TclFSNormalizeToUniquePath _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, int startAt));
Tcl_Obj* TclFSMakePathRelative _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Obj *cwdPtr));
Tcl_Obj* TclFSInternalToNormalized _ANSI_ARGS_((
Tcl_Filesystem *fromFilesystem, ClientData clientData,
FilesystemRecord **fsRecPtrPtr));
int TclFSEnsureEpochOk _ANSI_ARGS_((Tcl_Obj* pathObjPtr,
Tcl_Filesystem **fsPtrPtr));
void TclFSSetPathDetails _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
FilesystemRecord *fsRecPtr, ClientData clientData));
/*
* Private variables for use in this file
*/
extern Tcl_Filesystem tclNativeFilesystem;
extern int theFilesystemEpoch;
/*
* Private functions for use in this file
*/
static Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr));
static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
static Tcl_FSPathInFilesystemProc NativePathInFilesystem;
static Tcl_Obj* TclFSNormalizeAbsolutePath
_ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));
/*
* Prototypes for procedures defined later in this file.
*/
static FilesystemRecord* FsGetFirstFilesystem(void);
static void FsThrExitProc(ClientData cd);
static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr,
CONST char *pattern));
static Tcl_Obj* FsAddMountsToGlobResult _ANSI_ARGS_((Tcl_Obj *result,
Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types));
#ifdef TCL_THREADS
static void FsRecacheFilesystemList(void);
#endif
/*
* These form part of the native filesystem support. They are needed
* here because we have a few native filesystem functions (which are
* the same for mac/win/unix) in this file. There is no need to place
* them in tclInt.h, because they are not (and should not be) used
* anywhere else.
*/
extern CONST char * tclpFileAttrStrings[];
extern CONST TclFileAttrProcs tclpFileAttrProcs[];
/*
* The following functions are obsolete string based APIs, and should
* be removed in a future release (Tcl 9 would be a good time).
*/
/* Obsolete */
int
Tcl_Stat(path, oldStyleBuf)
CONST char *path; /* Path of file to stat (in current CP). */
struct stat *oldStyleBuf; /* Filled with results of stat call. */
{
int ret;
Tcl_StatBuf buf;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSStat(pathPtr, &buf);
Tcl_DecrRefCount(pathPtr);
if (ret != -1) {
#ifndef TCL_WIDE_INT_IS_LONG
# define OUT_OF_RANGE(x) \
(((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
#if defined(__GNUC__) && __GNUC__ >= 2
/*
* Workaround gcc warning of "comparison is always false due to limited range of
* data type" in this macro by checking max type size, and when necessary ANDing
* with the complement of ULONG_MAX instead of the comparison:
*/
# define OUT_OF_URANGE(x) \
((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \
(((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX))
#else
# define OUT_OF_URANGE(x) \
(((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
#endif
/*
* Perform the result-buffer overflow check manually.
*
* Note that ino_t/ino64_t is unsigned...
*/
if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size)
#ifdef HAVE_ST_BLOCKS
|| OUT_OF_RANGE(buf.st_blocks)
#endif
) {
#ifdef EFBIG
errno = EFBIG;
#else
# ifdef EOVERFLOW
errno = EOVERFLOW;
# else
# error "What status should be returned for file size out of range?"
# endif
#endif
return -1;
}
# undef OUT_OF_RANGE
# undef OUT_OF_URANGE
#endif /* !TCL_WIDE_INT_IS_LONG */
/*
* Copy across all supported fields, with possible type
* coercions on those fields that change between the normal
* and lf64 versions of the stat structure (on Solaris at
* least.) This is slow when the structure sizes coincide,
* but that's what you get for using an obsolete interface.
*/
oldStyleBuf->st_mode = buf.st_mode;
oldStyleBuf->st_ino = (ino_t) buf.st_ino;
oldStyleBuf->st_dev = buf.st_dev;
oldStyleBuf->st_rdev = buf.st_rdev;
oldStyleBuf->st_nlink = buf.st_nlink;
oldStyleBuf->st_uid = buf.st_uid;
oldStyleBuf->st_gid = buf.st_gid;
oldStyleBuf->st_size = (off_t) buf.st_size;
oldStyleBuf->st_atime = buf.st_atime;
oldStyleBuf->st_mtime = buf.st_mtime;
oldStyleBuf->st_ctime = buf.st_ctime;
#ifdef HAVE_ST_BLOCKS
oldStyleBuf->st_blksize = buf.st_blksize;
oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks;
#endif
}
return ret;
}
/* Obsolete */
int
Tcl_Access(path, mode)
CONST char *path; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSAccess(pathPtr,mode);
Tcl_DecrRefCount(pathPtr);
return ret;
}
/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(interp, path, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
CONST char *path; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Channel ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
Tcl_DecrRefCount(pathPtr);
return ret;
}
/* Obsolete */
int
Tcl_Chdir(dirName)
CONST char *dirName;
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSChdir(pathPtr);
Tcl_DecrRefCount(pathPtr);
return ret;
}
/* Obsolete */
char *
Tcl_GetCwd(interp, cwdPtr)
Tcl_Interp *interp;
Tcl_DString *cwdPtr;
{
Tcl_Obj *cwd;
cwd = Tcl_FSGetCwd(interp);
if (cwd == NULL) {
return NULL;
} else {
Tcl_DStringInit(cwdPtr);
Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1);
Tcl_DecrRefCount(cwd);
return Tcl_DStringValue(cwdPtr);
}
}
/* Obsolete */
int
Tcl_EvalFile(interp, fileName)
Tcl_Interp *interp; /* Interpreter in which to process file. */
CONST char *fileName; /* Name of file to process. Tilde-substitution
* will be performed on this name. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSEvalFile(interp, pathPtr);
Tcl_DecrRefCount(pathPtr);
return ret;
}
/*
* The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The
* complete, general hooked filesystem APIs should be used instead.
* This define decides whether to include the obsolete hooks and
* related code. If these are removed, we'll also want to remove them
* from stubs/tclInt. The only known users of these APIs are prowrap
* and mktclapp. New code/extensions should not use them, since they
* do not provide as full support as the full filesystem API.
*
* As soon as prowrap and mktclapp are updated to use the full
* filesystem support, I suggest all these hooks are removed.
*/
#define USE_OBSOLETE_FS_HOOKS
#ifdef USE_OBSOLETE_FS_HOOKS
/*
* The following typedef declarations allow for hooking into the chain
* of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
* 'Tcl_OpenFileChannel(...)'. Basically for each hookable function
* a linked list is defined.
*/
typedef struct StatProc {
TclStatProc_ *proc; /* Function to process a 'stat()' call */
struct StatProc *nextPtr; /* The next 'stat()' function to call */
} StatProc;
typedef struct AccessProc {
TclAccessProc_ *proc; /* Function to process a 'access()' call */
struct AccessProc *nextPtr; /* The next 'access()' function to call */
} AccessProc;
typedef struct OpenFileChannelProc {
TclOpenFileChannelProc_ *proc; /* Function to process a
* 'Tcl_OpenFileChannel()' call */
struct OpenFileChannelProc *nextPtr;
/* The next 'Tcl_OpenFileChannel()'
* function to call */
} OpenFileChannelProc;
/*
* For each type of (obsolete) hookable function, a static node is
* declared to hold the function pointer for the "built-in" routine
* (e.g. 'TclpStat(...)') and the respective list is initialized as a
* pointer to that node.
*
* The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that
* these statically declared list entry cannot be inadvertently removed.
*
* This method avoids the need to call any sort of "initialization"
* function.
*
* All three lists are protected by a global obsoleteFsHookMutex.
*/
static StatProc *statProcList = NULL;
static AccessProc *accessProcList = NULL;
static OpenFileChannelProc *openFileChannelProcList = NULL;
TCL_DECLARE_MUTEX(obsoleteFsHookMutex)
#endif /* USE_OBSOLETE_FS_HOOKS */
/*
* Declare the native filesystem support. These functions should
* be considered private to Tcl, and should really not be called
* directly by any code other than this file (i.e. neither by
* Tcl's core nor by extensions). Similarly, the old string-based
* Tclp... native filesystem functions should not be called.
*
* The correct API to use now is the Tcl_FS... set of functions,
* which ensure correct and complete virtual filesystem support.
*
* We cannot make all of these static, since some of them
* are implemented in the platform-specific directories.
*/
static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
static Tcl_FSCreateInternalRepProc NativeCreateNativeRep;
static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;
/*
* The only reason these functions are not static is that they
* are either called by code in the native (win/unix/mac) directories
* or they are actually implemented in those directories. They
* should simply not be called by code outside Tcl's native
* filesystem core. i.e. they should be considered 'static' to
* Tcl's filesystem code (if we ever built the native filesystem
* support into a separate code library, this could actually be
* enforced).
*/
Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
Tcl_FSStatProc TclpObjStat;
Tcl_FSAccessProc TclpObjAccess;
Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;
Tcl_FSGetCwdProc TclpObjGetCwd;
Tcl_FSChdirProc TclpObjChdir;
Tcl_FSLstatProc TclpObjLstat;
Tcl_FSCopyFileProc TclpObjCopyFile;
Tcl_FSDeleteFileProc TclpObjDeleteFile;
Tcl_FSRenameFileProc TclpObjRenameFile;
Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
Tcl_FSUnloadFileProc TclpUnloadFile;
Tcl_FSLinkProc TclpObjLink;
Tcl_FSListVolumesProc TclpObjListVolumes;
/*
* Define the native filesystem dispatch table. If necessary, it
* is ok to make this non-static, but it should only be accessed
* by the functions actually listed within it (or perhaps other
* helper functions of them). Anything which is not part of this
* 'native filesystem implementation' should not be delving inside
* here!
*/
Tcl_Filesystem tclNativeFilesystem = {
"native",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
&NativePathInFilesystem,
&TclNativeDupInternalRep,
&NativeFreeInternalRep,
&TclpNativeToNormalized,
&NativeCreateNativeRep,
&TclpObjNormalizePath,
&TclpFilesystemPathType,
&NativeFilesystemSeparator,
&TclpObjStat,
&TclpObjAccess,
&TclpOpenFileChannel,
&TclpMatchInDirectory,
&TclpUtime,
#ifndef S_IFLNK
NULL,
#else
&TclpObjLink,
#endif /* S_IFLNK */
&TclpObjListVolumes,
&NativeFileAttrStrings,
&NativeFileAttrsGet,
&NativeFileAttrsSet,
&TclpObjCreateDirectory,
&TclpObjRemoveDirectory,
&TclpObjDeleteFile,
&TclpObjCopyFile,
&TclpObjRenameFile,
&TclpObjCopyDirectory,
&TclpObjLstat,
&TclpDlopen,
&TclpObjGetCwd,
&TclpObjChdir
};
/*
* Define the tail of the linked list. Note that for unconventional
* uses of Tcl without a native filesystem, we may in the future wish
* to modify the current approach of hard-coding the native filesystem
* in the lookup list 'filesystemList' below.
*
* We initialize the record so that it thinks one file uses it. This
* means it will never be freed.
*/
static FilesystemRecord nativeFilesystemRecord = {
NULL,
&tclNativeFilesystem,
1,
NULL,
NULL
};
/*
* This is incremented each time we modify the linked list of
* filesystems. Any time it changes, all cached filesystem
* representations are suspect and must be freed.
* For multithreading builds, change of the filesystem epoch
* will trigger cache cleanup in all threads.
*/
int theFilesystemEpoch = 0;
/*
* Stores the linked list of filesystems. A 1:1 copy of this
* list is also maintained in the TSD for each thread. This
* is to avoid synchronization issues.
*/
static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
TCL_DECLARE_MUTEX(filesystemMutex)
/*
* Used to implement Tcl_FSGetCwd in a file-system independent way.
*/
static Tcl_Obj* cwdPathPtr = NULL;
static int cwdPathEpoch = 0;
TCL_DECLARE_MUTEX(cwdMutex)
/*
* This structure holds per-thread private copies of
* some global data. This way we avoid most of the
* synchronization calls which boosts performance, at
* cost of having to update this information each
* time the corresponding epoch counter changes.
*
*/
typedef struct ThreadSpecificData {
int initialized;
int cwdPathEpoch;
int filesystemEpoch;
Tcl_Obj *cwdPathPtr;
FilesystemRecord *filesystemList;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Declare fallback support function and
* information for Tcl_FSLoadFile
*/
static Tcl_FSUnloadFileProc FSUnloadTempFile;
/*
* One of these structures is used each time we successfully load a
* file from a file system by way of making a temporary copy of the
* file on the native filesystem. We need to store both the actual
* unloadProc/clientData combination which was used, and the original
* and modified filenames, so that we can correctly undo the entire
* operation when we want to unload the code.
*/
typedef struct FsDivertLoad {
Tcl_LoadHandle loadHandle;
Tcl_FSUnloadFileProc *unloadProcPtr;
Tcl_Obj *divertedFile;
Tcl_Filesystem *divertedFilesystem;
ClientData divertedFileNativeRep;
} FsDivertLoad;
/* Now move on to the basic filesystem implementation */
static void
FsThrExitProc(cd)
ClientData cd;
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData*)cd;
FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;
/* Trash the cwd copy */
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
tsdPtr->cwdPathPtr = NULL;
}
/* Trash the filesystems cache */
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
if (--fsRecPtr->fileRefCount <= 0) {
ckfree((char *)fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
tsdPtr->initialized = 0;
}
int
TclFSCwdPointerEquals(objPtr)
Tcl_Obj* objPtr;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_MutexLock(&cwdMutex);
if (tsdPtr->cwdPathPtr == NULL) {
if (cwdPathPtr == NULL) {
tsdPtr->cwdPathPtr = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
tsdPtr->cwdPathEpoch = cwdPathEpoch;
} else if (tsdPtr->cwdPathEpoch != cwdPathEpoch) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
if (cwdPathPtr == NULL) {
tsdPtr->cwdPathPtr = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
}
Tcl_MutexUnlock(&cwdMutex);
if (tsdPtr->initialized == 0) {
Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
tsdPtr->initialized = 1;
}
return (tsdPtr->cwdPathPtr == objPtr);
}
#ifdef TCL_THREADS
static void
FsRecacheFilesystemList(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL;
/* Trash the current cache */
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
if (--fsRecPtr->fileRefCount <= 0) {
ckfree((char *)fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
tsdPtr->filesystemList = NULL;
/*
* Code below operates on shared data. We
* are already called under mutex lock so
* we can safely proceed.
*/
/* Locate tail of the global filesystem list */
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr;
fsRecPtr = fsRecPtr->nextPtr;
}
/* Refill the cache honouring the order */
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = tsdPtr->filesystemList;
tmpFsRecPtr->prevPtr = NULL;
if (tsdPtr->filesystemList) {
tsdPtr->filesystemList->prevPtr = tmpFsRecPtr;
}
tsdPtr->filesystemList = tmpFsRecPtr;
fsRecPtr = fsRecPtr->prevPtr;
}
/* Make sure the above gets released on thread exit */
if (tsdPtr->initialized == 0) {
Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
tsdPtr->initialized = 1;
}
}
#endif
static FilesystemRecord *
FsGetFirstFilesystem(void) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FilesystemRecord *fsRecPtr;
#ifndef TCL_THREADS
tsdPtr->filesystemEpoch = theFilesystemEpoch;
fsRecPtr = filesystemList;
#else
Tcl_MutexLock(&filesystemMutex);
if (tsdPtr->filesystemList == NULL
|| (tsdPtr->filesystemEpoch != theFilesystemEpoch)) {
FsRecacheFilesystemList();
tsdPtr->filesystemEpoch = theFilesystemEpoch;
}
Tcl_MutexUnlock(&filesystemMutex);
fsRecPtr = tsdPtr->filesystemList;
#endif
return fsRecPtr;
}
static void
FsUpdateCwd(cwdObj)
Tcl_Obj *cwdObj;
{
int len;
char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (cwdObj != NULL) {
str = Tcl_GetStringFromObj(cwdObj, &len);
}
Tcl_MutexLock(&cwdMutex);
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
}
if (cwdObj == NULL) {
cwdPathPtr = NULL;
} else {
/* This MUST be stored as string object! */
cwdPathPtr = Tcl_NewStringObj(str, len);
Tcl_IncrRefCount(cwdPathPtr);
}
cwdPathEpoch++;
tsdPtr->cwdPathEpoch = cwdPathEpoch;
Tcl_MutexUnlock(&cwdMutex);
if (tsdPtr->cwdPathPtr) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
}
if (cwdObj == NULL) {
tsdPtr->cwdPathPtr = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len);
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeFilesystem --
*
* Clean up the filesystem. After this, calls to all Tcl_FS...
* functions will fail.
*
* We will later call TclResetFilesystem to restore the FS
* to a pristine state.
*
* Results:
* None.
*
* Side effects:
* Frees any memory allocated by the filesystem.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeFilesystem()
{
FilesystemRecord *fsRecPtr;
/*
* Assumption that only one thread is active now. Otherwise
* we would need to put various mutexes around this code.
*/
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
cwdPathPtr = NULL;
cwdPathEpoch = 0;
}
/*
* Remove all filesystems, freeing any allocated memory
* that is no longer needed
*/
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
if (fsRecPtr->fileRefCount <= 0) {
/* The native filesystem is static, so we don't free it */
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
ckfree((char *)fsRecPtr);
}
}
fsRecPtr = tmpFsRecPtr;
}
filesystemList = NULL;
/*
* Now filesystemList is NULL. This means that any attempt
* to use the filesystem is likely to fail.
*/
statProcList = NULL;
accessProcList = NULL;
openFileChannelProcList = NULL;
#ifdef __WIN32__
TclWinEncodingsCleanup();
#endif
}
/*
*----------------------------------------------------------------------
*
* TclResetFilesystem --
*
* Restore the filesystem to a pristine state.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclResetFilesystem()
{
filesystemList = &nativeFilesystemRecord;
/*
* Note, at this point, I believe nativeFilesystemRecord ->
* fileRefCount should equal 1 and if not, we should try to track
* down the cause.
*/
#ifdef __WIN32__
/*
* Cleans up the win32 API filesystem proc lookup table. This must
* happen very late in finalization so that deleting of copied
* dlls can occur.
*/
TclWinResetInterfaces();
#endif
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSRegister --
*
* Insert the filesystem function table at the head of the list of
* functions which are used during calls to all file-system
* operations. The filesystem will be added even if it is
* already in the list. (You can use Tcl_FSData to
* check if it is in the list, provided the ClientData used was
* not NULL).
*
* Note that the filesystem handling is head-to-tail of the list.
* Each filesystem is asked in turn whether it can handle a
* particular request, _until_ one of them says 'yes'. At that
* point no further filesystems are asked.
*
* In particular this means if you want to add a diagnostic
* filesystem (which simply reports all fs activity), it must be
* at the head of the list: i.e. it must be the last registered.
*
* Results:
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
* could not be allocated.
*
* Side effects:
* Memory allocated and modifies the link list for filesystems.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSRegister(clientData, fsPtr)
ClientData clientData; /* Client specific data for this fs */
Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */
{
FilesystemRecord *newFilesystemPtr;
if (fsPtr == NULL) {
return TCL_ERROR;
}
newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));
newFilesystemPtr->clientData = clientData;
newFilesystemPtr->fsPtr = fsPtr;
/*
* We start with a refCount of 1. If this drops to zero, then
* anyone is welcome to ckfree us.
*/
newFilesystemPtr->fileRefCount = 1;
/*
* Is this lock and wait strictly speaking necessary? Since any
* iterators out there will have grabbed a copy of the head of
* the list and be iterating away from that, if we add a new
* element to the head of the list, it can't possibly have any
* effect on any of their loops. In fact it could be better not
* to wait, since we are adjusting the filesystem epoch, any
* cached representations calculated by existing iterators are
* going to have to be thrown away anyway.
*
* However, since registering and unregistering filesystems is
* a very rare action, this is not a very important point.
*/
Tcl_MutexLock(&filesystemMutex);
newFilesystemPtr->nextPtr = filesystemList;
newFilesystemPtr->prevPtr = NULL;
if (filesystemList) {
filesystemList->prevPtr = newFilesystemPtr;
}
filesystemList = newFilesystemPtr;
/*
* Increment the filesystem epoch counter, since existing paths
* might conceivably now belong to different filesystems.
*/
theFilesystemEpoch++;
Tcl_MutexUnlock(&filesystemMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSUnregister --
*
* Remove the passed filesystem from the list of filesystem
* function tables. It also ensures that the built-in
* (native) filesystem is not removable, although we may wish
* to change that decision in the future to allow a smaller
* Tcl core, in which the native filesystem is not used at
* all (we could, say, initialise Tcl completely over a network
* connection).
*
* Results:
* TCL_OK if the procedure pointer was successfully removed,
* TCL_ERROR otherwise.
*
* Side effects:
* Memory may be deallocated (or will be later, once no "path"
* objects refer to this filesystem), but the list of registered
* filesystems is updated immediately.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSUnregister(fsPtr)
Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */
{
int retVal = TCL_ERROR;
FilesystemRecord *fsRecPtr;
Tcl_MutexLock(&filesystemMutex);
/*
* Traverse the 'filesystemList' looking for the particular node
* whose 'fsPtr' member matches 'fsPtr' and remove that one from
* the list. Ensure that the "default" node cannot be removed.
*/
fsRecPtr = filesystemList;
while ((retVal == TCL_ERROR) && (fsRecPtr->fsPtr != &tclNativeFilesystem)) {
if (fsRecPtr->fsPtr == fsPtr) {
if (fsRecPtr->prevPtr) {
fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;
} else {
filesystemList = fsRecPtr->nextPtr;
}
if (fsRecPtr->nextPtr) {
fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr;
}
/*
* Increment the filesystem epoch counter, since existing
* paths might conceivably now belong to different
* filesystems. This should also ensure that paths which
* have cached the filesystem which is about to be deleted
* do not reference that filesystem (which would of course
* lead to memory exceptions).
*/
theFilesystemEpoch++;
fsRecPtr->fileRefCount--;
if (fsRecPtr->fileRefCount <= 0) {
ckfree((char *)fsRecPtr);
}
retVal = TCL_OK;
} else {
fsRecPtr = fsRecPtr->nextPtr;
}
}
Tcl_MutexUnlock(&filesystemMutex);
return (retVal);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSMatchInDirectory --
*
* This routine is used by the globbing code to search a directory
* for all files which match a given pattern. The appropriate
* function for the filesystem to which pathPtr belongs will be
* called. If pathPtr does not belong to any filesystem and if it
* is NULL or the empty string, then we assume the pattern is to be
* matched in the current working directory. To avoid each
* filesystem's Tcl_FSMatchInDirectoryProc having to deal with this
* issue, we create a pathPtr on the fly (equal to the cwd), and
* then remove it from the results returned. This makes filesystems
* easy to write, since they can assume the pathPtr passed to them
* is an ordinary path. In fact this means we could remove such
* special case handling from Tcl's native filesystems.
*
* If 'pattern' is NULL, then pathPtr is assumed to be a fully
* specified path of a single file/directory which must be
* checked for existence and correct type.
*
* Results:
*
* The return value is a standard Tcl result indicating whether an
* error occurred in globbing. Error messages are placed in
* interp, but good results are placed in the resultPtr given.
*
* Recursive searches, e.g.
*
* glob -dir $dir -join * pkgIndex.tcl
*
* which must recurse through each directory matching '*' are
* handled internally by Tcl, by passing specific flags in a
* modified 'types' parameter. This means the actual filesystem
* only ever sees patterns which match in a single directory.
*
* Side effects:
* The interpreter may have an error message inserted into it.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types)
Tcl_Interp *interp; /* Interpreter to receive error messages. */
Tcl_Obj *result; /* List object to receive results. */
Tcl_Obj *pathPtr; /* Contains path to directory to search. */
CONST char *pattern; /* Pattern to match against. */
Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
* May be NULL. In particular the directory
* flag is very important. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
if (proc != NULL) {
int ret = (*proc)(interp, result, pathPtr, pattern, types);
if (ret == TCL_OK && pattern != NULL) {
result = FsAddMountsToGlobResult(result, pathPtr,
pattern, types);
}
return ret;
}
} else {
Tcl_Obj* cwd;
int ret = -1;
if (pathPtr != NULL) {
int len;
Tcl_GetStringFromObj(pathPtr,&len);
if (len != 0) {
/*
* We have no idea how to match files in a directory
* which belongs to no known filesystem
*/
Tcl_SetErrno(ENOENT);
return -1;
}
}
/*
* We have an empty or NULL path. This is defined to mean we
* must search for files within the current 'cwd'. We
* therefore use that, but then since the proc we call will
* return results which include the cwd we must then trim it
* off the front of each path in the result. We choose to deal
* with this here (in the generic code), since if we don't,
* every single filesystem's implementation of
* Tcl_FSMatchInDirectory will have to deal with it for us.
*/
cwd = Tcl_FSGetCwd(NULL);
if (cwd == NULL) {
if (interp != NULL) {
Tcl_SetResult(interp, "glob couldn't determine "
"the current working directory", TCL_STATIC);
}
return TCL_ERROR;
}
fsPtr = Tcl_FSGetFileSystemForPath(cwd);
if (fsPtr != NULL) {
Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
if (proc != NULL) {
Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(tmpResultPtr);
ret = (*proc)(interp, tmpResultPtr, cwd, pattern, types);
if (ret == TCL_OK) {
int resLength;
tmpResultPtr = FsAddMountsToGlobResult(tmpResultPtr, cwd,
pattern, types);
ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength);
if (ret == TCL_OK) {
int i;
for (i = 0; i < resLength; i++) {
Tcl_Obj *elt;
Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt);
Tcl_ListObjAppendElement(interp, result,
TclFSMakePathRelative(interp, elt, cwd));
}
}
}
Tcl_DecrRefCount(tmpResultPtr);
}
}
Tcl_DecrRefCount(cwd);
return ret;
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* FsAddMountsToGlobResult --
*
* This routine is used by the globbing code to take the results
* of a directory listing and add any mounted paths to that
* listing. This is required so that simple things like
* 'glob *' merge mounts and listings correctly.
*
* Results:
*
* The passed in 'result' may be modified (in place, if
* necessary), and the correct list is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj*
FsAddMountsToGlobResult(result, pathPtr, pattern, types)
Tcl_Obj *result; /* The current list of matching paths */
Tcl_Obj *pathPtr; /* The directory in question */
CONST char *pattern;
Tcl_GlobTypeData *types;
{
int mLength, gLength, i;
int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
Tcl_Obj *mounts = FsListMounts(pathPtr, pattern);
if (mounts == NULL) return result;
if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
goto endOfMounts;
}
if (Tcl_ListObjLength(NULL, result, &gLength) != TCL_OK) {
goto endOfMounts;
}
for (i = 0; i < mLength; i++) {
Tcl_Obj *mElt;
int j;
int found = 0;
Tcl_ListObjIndex(NULL, mounts, i, &mElt);
for (j = 0; j < gLength; j++) {
Tcl_Obj *gElt;
Tcl_ListObjIndex(NULL, result, j, &gElt);
if (Tcl_FSEqualPaths(mElt, gElt)) {
found = 1;
if (!dir) {
/* We don't want to list this */
if (Tcl_IsShared(result)) {
Tcl_Obj *newList;
newList = Tcl_DuplicateObj(result);
Tcl_DecrRefCount(result);
result = newList;
}
Tcl_ListObjReplace(NULL, result, j, 1, 0, NULL);
gLength--;
}
/* Break out of for loop */
break;
}
}
if (!found && dir) {
if (Tcl_IsShared(result)) {
Tcl_Obj *newList;
newList = Tcl_DuplicateObj(result);
Tcl_DecrRefCount(result);
result = newList;
}
Tcl_ListObjAppendElement(NULL, result, mElt);
/*
* No need to increment gLength, since we
* don't want to compare mounts against
* mounts.
*/
}
}
endOfMounts:
Tcl_DecrRefCount(mounts);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSMountsChanged --
*
* Notify the filesystem that the available mounted filesystems
* (or within any one filesystem type, the number or location of
* mount points) have changed.
*
* Results:
* None.
*
* Side effects:
* The global filesystem variable 'theFilesystemEpoch' is
* incremented. The effect of this is to make all cached
* path representations invalid. Clearly it should only therefore
* be called when it is really required! There are a few
* circumstances when it should be called:
*
* (1) when a new filesystem is registered or unregistered.
* Strictly speaking this is only necessary if the new filesystem
* accepts file paths as is (normally the filesystem itself is
* really a shell which hasn't yet had any mount points established
* and so its 'pathInFilesystem' proc will always fail). However,
* for safety, Tcl always calls this for you in these circumstances.
*
* (2) when additional mount points are established inside any
* existing filesystem (except the native fs)
*
* (3) when any filesystem (except the native fs) changes the list
* of available volumes.
*
* (4) when the mapping from a string representation of a file to
* a full, normalized path changes. For example, if 'env(HOME)'
* is modified, then any path containing '~' will map to a different
* filesystem location. Therefore all such paths need to have
* their internal representation invalidated.
*
* Tcl has no control over (2) and (3), so any registered filesystem
* must make sure it calls this function when those situations
* occur.
*
* (Note: the reason for the exception in 2,3 for the native
* filesystem is that the native filesystem by default claims all
* unknown files even if it really doesn't understand them or if
* they don't exist).
*
*----------------------------------------------------------------------
*/
void
Tcl_FSMountsChanged(fsPtr)
Tcl_Filesystem *fsPtr;
{
/*
* We currently don't do anything with this parameter. We
* could in the future only invalidate files for this filesystem
* or otherwise take more advanced action.
*/
(void)fsPtr;
/*
* Increment the filesystem epoch counter, since existing paths
* might now belong to different filesystems.
*/
Tcl_MutexLock(&filesystemMutex);
theFilesystemEpoch++;
Tcl_MutexUnlock(&filesystemMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSData --
*
* Retrieve the clientData field for the filesystem given,
* or NULL if that filesystem is not registered.
*
* Results:
* A clientData value, or NULL. Note that if the filesystem
* was registered with a NULL clientData field, this function
* will return that NULL value.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_FSData(fsPtr)
Tcl_Filesystem *fsPtr; /* The filesystem record to query. */
{
ClientData retVal = NULL;
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
/*
* Traverse the 'filesystemList' looking for the particular node
* whose 'fsPtr' member matches 'fsPtr' and remove that one from
* the list. Ensure that the "default" node cannot be removed.
*/
while ((retVal == NULL) && (fsRecPtr != NULL)) {
if (fsRecPtr->fsPtr == fsPtr) {
retVal = fsRecPtr->clientData;
}
fsRecPtr = fsRecPtr->nextPtr;
}
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* TclFSNormalizeAbsolutePath --
*
* Description:
* Takes an absolute path specification and computes a 'normalized'
* path from it.
*
* A normalized path is one which has all '../', './' removed.
* Also it is one which is in the 'standard' format for the native
* platform. On MacOS, Unix, this means the path must be free of
* symbolic links/aliases, and on Windows it means we want the
* long form, with that long form's case-dependence (which gives
* us a unique, case-dependent path).
*
* The behaviour of this function if passed a non-absolute path
* is NOT defined.
*
* Results:
* The result is returned in a Tcl_Obj with a refCount of 1,
* which is therefore owned by the caller. It must be
* freed (with Tcl_DecrRefCount) by the caller when no longer needed.
*
* Side effects:
* None (beyond the memory allocation for the result).
*
* Special note:
* This code is based on code from Matt Newman and Jean-Claude
* Wippler, with additions from Vince Darley and is copyright
* those respective authors.
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj *
TclFSNormalizeAbsolutePath(interp, pathPtr)
Tcl_Interp* interp; /* Interpreter to use */
Tcl_Obj *pathPtr; /* Absolute path to normalize */
{
int splen = 0, nplen, eltLen, i;
char *eltName;
Tcl_Obj *retVal;
Tcl_Obj *split;
Tcl_Obj *elt;
/* Split has refCount zero */
split = Tcl_FSSplitPath(pathPtr, &splen);
/*
* Modify the list of entries in place, by removing '.', and
* removing '..' and the entry before -- unless that entry before
* is the top-level entry, i.e. the name of a volume.
*/
nplen = 0;
for (i = 0; i < splen; i++) {
Tcl_ListObjIndex(NULL, split, nplen, &elt);
eltName = Tcl_GetStringFromObj(elt, &eltLen);
if ((eltLen == 1) && (eltName[0] == '.')) {
Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
} else if ((eltLen == 2)
&& (eltName[0] == '.') && (eltName[1] == '.')) {
if (nplen > 1) {
nplen--;
Tcl_ListObjReplace(NULL, split, nplen, 2, 0, NULL);
} else {
Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
}
} else {
nplen++;
}
}
if (nplen > 0) {
retVal = Tcl_FSJoinPath(split, nplen);
/*
* Now we have an absolute path, with no '..', '.' sequences,
* but it still may not be in 'unique' form, depending on the
* platform. For instance, Unix is case-sensitive, so the
* path is ok. Windows is case-insensitive, and also has the
* weird 'longname/shortname' thing (e.g. C:/Program Files/ and
* C:/Progra~1/ are equivalent). MacOS is case-insensitive.
*
* Virtual file systems which may be registered may have
* other criteria for normalizing a path.
*/
Tcl_IncrRefCount(retVal);
TclFSNormalizeToUniquePath(interp, retVal, 0);
/*
* Since we know it is a normalized path, we can
* actually convert this object into an "path" object for
* greater efficiency
*/
TclFSMakePathFromNormalized(interp, retVal);
} else {
/* Init to an empty string */
retVal = Tcl_NewStringObj("",0);
Tcl_IncrRefCount(retVal);
}
/*
* We increment and then decrement the refCount of split to free
* it. We do this right at the end, in case there are
* optimisations in Tcl_FSJoinPath(split, nplen) above which would
* let it make use of split more effectively if it has a refCount
* of zero. Also we can't just decrement the ref count, in case
* 'split' was actually returned by the join call above, in a
* single-element optimisation when nplen == 1.
*/
Tcl_IncrRefCount(split);
Tcl_DecrRefCount(split);
/* This has a refCount of 1 for the caller */
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* TclFSNormalizeToUniquePath --
*
* Description:
* Takes a path specification containing no ../, ./ sequences,
* and converts it into a unique path for the given platform.
* On MacOS, Unix, this means the path must be free of
* symbolic links/aliases, and on Windows it means we want the
* long form, with that long form's case-dependence (which gives
* us a unique, case-dependent path).
*
* Results:
* The pathPtr is modified in place. The return value is
* the last byte offset which was recognised in the path
* string.
*
* Side effects:
* None (beyond the memory allocation for the result).
*
* Special notes:
* If the filesystem-specific normalizePathProcs can re-introduce
* ../, ./ sequences into the path, then this function will
* not return the correct result. This may be possible with
* symbolic links on unix/macos.
*
* Important assumption: if startAt is non-zero, it must point
* to a directory separator that we know exists and is already
* normalized (so it is important not to point to the char just
* after the separator).
*---------------------------------------------------------------------------
*/
int
TclFSNormalizeToUniquePath(interp, pathPtr, startAt)
Tcl_Interp *interp;
Tcl_Obj *pathPtr;
int startAt;
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
/*
* Call each of the "normalise path" functions in succession. This is
* a special case, in which if we have a native filesystem handler,
* we call it first. This is because the root of Tcl's filesystem
* is always a native filesystem (i.e. '/' on unix is native).
*/
firstFsRecPtr = FsGetFirstFilesystem();
fsRecPtr = firstFsRecPtr;
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr == &tclNativeFilesystem) {
Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
if (proc != NULL) {
startAt = (*proc)(interp, pathPtr, startAt);
}
break;
}
fsRecPtr = fsRecPtr->nextPtr;
}
fsRecPtr = firstFsRecPtr;
while (fsRecPtr != NULL) {
/* Skip the native system next time through */
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
if (proc != NULL) {
startAt = (*proc)(interp, pathPtr, startAt);
}
/*
* We could add an efficiency check like this:
*
* if (retVal == length-of(pathPtr)) {break;}
*
* but there's not much benefit.
*/
}
fsRecPtr = fsRecPtr->nextPtr;
}
return startAt;
}
/*
*---------------------------------------------------------------------------
*
* TclGetOpenMode --
*
* Description:
* Computes a POSIX mode mask for opening a file, from a given string,
* and also sets a flag to indicate whether the caller should seek to
* EOF after opening the file.
*
* Results:
* On success, returns mode to pass to "open". If an error occurs, the
* return value is -1 and if interp is not NULL, sets interp's result
* object to an error message.
*
* Side effects:
* Sets the integer referenced by seekFlagPtr to 1 to tell the caller
* to seek to EOF after opening the file.
*
* Special note:
* This code is based on a prototype implementation contributed
* by Mark Diekhans.
*
*---------------------------------------------------------------------------
*/
int
TclGetOpenMode(interp, string, seekFlagPtr)
Tcl_Interp *interp; /* Interpreter to use for error
* reporting - may be NULL. */
CONST char *string; /* Mode string, e.g. "r+" or
* "RDONLY CREAT". */
int *seekFlagPtr; /* Set this to 1 if the caller
* should seek to EOF during the
* opening of the file. */
{
int mode, modeArgc, c, i, gotRW;
CONST char **modeArgv, *flag;
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
/*
* Check for the simpler fopen-like access modes (e.g. "r"). They
* are distinguished from the POSIX access modes by the presence
* of a lower-case first letter.
*/
*seekFlagPtr = 0;
mode = 0;
/*
* Guard against international characters before using byte oriented
* routines.
*/
if (!(string[0] & 0x80)
&& islower(UCHAR(string[0]))) { /* INTL: ISO only. */
switch (string[0]) {
case 'r':
mode = O_RDONLY;
break;
case 'w':
mode = O_WRONLY|O_CREAT|O_TRUNC;
break;
case 'a':
/* [Bug 680143].
* Added O_APPEND for proper automatic
* seek-to-end-on-write by the OS.
*/
mode = O_WRONLY|O_CREAT|O_APPEND;
*seekFlagPtr = 1;
break;
default:
error:
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp,
"illegal access mode \"", string, "\"",
(char *) NULL);
}
return -1;
}
if (string[1] == '+') {
/*
* Must remove the O_APPEND flag so that the seek command
* works. [Bug 1773127]
*/
mode &= ~(O_RDONLY|O_WRONLY|O_APPEND);
mode |= O_RDWR;
if (string[2] != 0) {
goto error;
}
} else if (string[1] != 0) {
goto error;
}
return mode;
}
/*
* The access modes are specified using a list of POSIX modes
* such as O_CREAT.
*
* IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when
* a NULL interpreter is passed in.
*/
if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AddErrorInfo(interp,
"\n while processing open access modes \"");
Tcl_AddErrorInfo(interp, string);
Tcl_AddErrorInfo(interp, "\"");
}
return -1;
}
gotRW = 0;
for (i = 0; i < modeArgc; i++) {
flag = modeArgv[i];
c = flag[0];
if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
mode = (mode & ~RW_MODES) | O_RDONLY;
gotRW = 1;
} else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
mode = (mode & ~RW_MODES) | O_WRONLY;
gotRW = 1;
} else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
mode = (mode & ~RW_MODES) | O_RDWR;
gotRW = 1;
} else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
mode |= O_APPEND;
*seekFlagPtr = 1;
} else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
mode |= O_CREAT;
} else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
mode |= O_EXCL;
} else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
#ifdef O_NOCTTY
mode |= O_NOCTTY;
#else
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "access mode \"", flag,
"\" not supported by this system", (char *) NULL);
}
ckfree((char *) modeArgv);
return -1;
#endif
} else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
#if defined(O_NDELAY) || defined(O_NONBLOCK)
# ifdef O_NONBLOCK
mode |= O_NONBLOCK;
# else
mode |= O_NDELAY;
# endif
#else
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "access mode \"", flag,
"\" not supported by this system", (char *) NULL);
}
ckfree((char *) modeArgv);
return -1;
#endif
} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
mode |= O_TRUNC;
} else {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "invalid access mode \"", flag,
"\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
" EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
}
ckfree((char *) modeArgv);
return -1;
}
}
ckfree((char *) modeArgv);
if (!gotRW) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "access mode must include either",
" RDONLY, WRONLY, or RDWR", (char *) NULL);
}
return -1;
}
return mode;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSEvalFile --
*
* Read in a file and process the entire file as one gigantic
* Tcl command.
*
* Results:
* A standard Tcl result, which is either the result of executing
* the file or an error indicating why the file couldn't be read.
*
* Side effects:
* Depends on the commands in the file. During the evaluation
* of the contents of the file, iPtr->scriptFile is made to
* point to pathPtr (the old value is cached and replaced when
* this function returns).
*
*----------------------------------------------------------------------
*/
int
Tcl_FSEvalFile(interp, pathPtr)
Tcl_Interp *interp; /* Interpreter in which to process file. */
Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution
* will be performed on this name. */
{
int result, length;
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
char *string;
Tcl_Channel chan;
Tcl_Obj *objPtr;
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return TCL_ERROR;
}
result = TCL_ERROR;
objPtr = Tcl_NewObj();
Tcl_IncrRefCount(objPtr);
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
Tcl_AppendResult(interp, "couldn't read file \"",
Tcl_GetString(pathPtr),
"\": ", Tcl_PosixError(interp), (char *) NULL);
goto end;
}
chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
if (chan == (Tcl_Channel) NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't read file \"",
Tcl_GetString(pathPtr),
"\": ", Tcl_PosixError(interp), (char *) NULL);
goto end;
}
/*
* The eofchar is \32 (^Z). This is the usual on Windows, but we
* effect this cross-platform to allow for scripted documents.
* [Bug: 2040]
*/
Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
/* Try to read first character of stream, so we can
* check for utf-8 BOM to be handled especially.
*/
if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
Tcl_Close(interp, chan);
Tcl_AppendResult(interp, "couldn't read file \"",
Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
goto end;
}
string = Tcl_GetString(objPtr);
/*
* If first character is not a BOM, append the remaining characters,
* otherwise replace them [Bug 3466099].
*/
if (Tcl_ReadChars(chan, objPtr, -1,
memcmp(string, "\xef\xbb\xbf", 3)) < 0) {
Tcl_Close(interp, chan);
Tcl_AppendResult(interp, "couldn't read file \"",
Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
goto end;
}
if (Tcl_Close(interp, chan) != TCL_OK) {
goto end;
}
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
string = Tcl_GetStringFromObj(objPtr, &length);
#ifdef TCL_TIP280
/* TIP #280 Force the evaluator to open a frame for a sourced
* file. */
iPtr->evalFlags |= TCL_EVAL_FILE;
#endif
result = Tcl_EvalEx(interp, string, length, 0);
/*
* Now we have to be careful; the script may have changed the
* iPtr->scriptFile value, so we must reset it without
* assuming it still points to 'pathPtr'.
*/
if (iPtr->scriptFile != NULL) {
Tcl_DecrRefCount(iPtr->scriptFile);
}
iPtr->scriptFile = oldScriptFile;
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
char msg[200 + TCL_INTEGER_SPACE];
/*
* Record information telling where the error occurred.
*/
sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(pathPtr),
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
end:
Tcl_DecrRefCount(objPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetErrno --
*
* Gets the current value of the Tcl error code variable. This is
* currently the global variable "errno" but could in the future
* change to something else.
*
* Results:
* The value of the Tcl error code variable.
*
* Side effects:
* None. Note that the value of the Tcl error code variable is
* UNDEFINED if a call to Tcl_SetErrno did not precede this call.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetErrno()
{
return errno;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetErrno --
*
* Sets the Tcl error code variable to the supplied value.
*
* Results:
* None.
*
* Side effects:
* Modifies the value of the Tcl error code variable.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetErrno(err)
int err; /* The new value. */
{
errno = err;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PosixError --
*
* This procedure is typically called after UNIX kernel calls
* return errors. It stores machine-readable information about
* the error in $errorCode returns an information string for
* the caller's use.
*
* Results:
* The return value is a human-readable string describing the
* error.
*
* Side effects:
* The global variable $errorCode is reset.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_PosixError(interp)
Tcl_Interp *interp; /* Interpreter whose $errorCode variable
* is to be changed. */
{
CONST char *id, *msg;
msg = Tcl_ErrnoMsg(errno);
id = Tcl_ErrnoId();
if (interp) {
Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
}
return msg;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSStat --
*
* This procedure replaces the library version of stat and lsat.
*
* The appropriate function for the filesystem to which pathPtr
* belongs will be called.
*
* Results:
* See stat documentation.
*
* Side effects:
* See stat documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSStat(pathPtr, buf)
Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
Tcl_StatBuf *buf; /* Filled with results of stat call. */
{
Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
Tcl_StatBuf oldStyleStatBuffer;
int retVal = -1;
/*
* Call each of the "stat" function in succession. A non-return
* value of -1 indicates the particular function has succeeded.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
if (statProcList != NULL) {
StatProc *statProcPtr;
char *path;
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
path = NULL;
} else {
path = Tcl_GetString(transPtr);
}
statProcPtr = statProcList;
while ((retVal == -1) && (statProcPtr != NULL)) {
retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer);
statProcPtr = statProcPtr->nextPtr;
}
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
if (retVal != -1) {
/*
* Note that EOVERFLOW is not a problem here, and these
* assignments should all be widening (if not identity.)
*/
buf->st_mode = oldStyleStatBuffer.st_mode;
buf->st_ino = oldStyleStatBuffer.st_ino;
buf->st_dev = oldStyleStatBuffer.st_dev;
buf->st_rdev = oldStyleStatBuffer.st_rdev;
buf->st_nlink = oldStyleStatBuffer.st_nlink;
buf->st_uid = oldStyleStatBuffer.st_uid;
buf->st_gid = oldStyleStatBuffer.st_gid;
buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size);
buf->st_atime = oldStyleStatBuffer.st_atime;
buf->st_mtime = oldStyleStatBuffer.st_mtime;
buf->st_ctime = oldStyleStatBuffer.st_ctime;
#ifdef HAVE_ST_BLOCKS
buf->st_blksize = oldStyleStatBuffer.st_blksize;
buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks);
#endif
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSStatProc *proc = fsPtr->statProc;
if (proc != NULL) {
return (*proc)(pathPtr, buf);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSLstat --
*
* This procedure replaces the library version of lstat.
* The appropriate function for the filesystem to which pathPtr
* belongs will be called. If no 'lstat' function is listed,
* but a 'stat' function is, then Tcl will fall back on the
* stat function.
*
* Results:
* See lstat documentation.
*
* Side effects:
* See lstat documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSLstat(pathPtr, buf)
Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
Tcl_StatBuf *buf; /* Filled with results of stat call. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSLstatProc *proc = fsPtr->lstatProc;
if (proc != NULL) {
return (*proc)(pathPtr, buf);
} else {
Tcl_FSStatProc *sproc = fsPtr->statProc;
if (sproc != NULL) {
return (*sproc)(pathPtr, buf);
}
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSAccess --
*
* This procedure replaces the library version of access.
* The appropriate function for the filesystem to which pathPtr
* belongs will be called.
*
* Results:
* See access documentation.
*
* Side effects:
* See access documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSAccess(pathPtr, mode)
Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
int retVal = -1;
/*
* Call each of the "access" function in succession. A non-return
* value of -1 indicates the particular function has succeeded.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
if (accessProcList != NULL) {
AccessProc *accessProcPtr;
char *path;
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
path = NULL;
} else {
path = Tcl_GetString(transPtr);
}
accessProcPtr = accessProcList;
while ((retVal == -1) && (accessProcPtr != NULL)) {
retVal = (*accessProcPtr->proc)(path, mode);
accessProcPtr = accessProcPtr->nextPtr;
}
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
if (retVal != -1) {
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSAccessProc *proc = fsPtr->accessProc;
if (proc != NULL) {
return (*proc)(pathPtr, mode);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSOpenFileChannel --
*
* The appropriate function for the filesystem to which pathPtr
* belongs will be called.
*
* Results:
* The new channel or NULL, if the named file could not be opened.
*
* Side effects:
* May open the channel and may cause creation of a file on the
* file system.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
Tcl_Obj *pathPtr; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
Tcl_Channel retVal = NULL;
/*
* Call each of the "Tcl_OpenFileChannel" functions in succession.
* A non-NULL return value indicates the particular function has
* succeeded.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
if (openFileChannelProcList != NULL) {
OpenFileChannelProc *openFileChannelProcPtr;
char *path;
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr == NULL) {
path = NULL;
} else {
path = Tcl_GetString(transPtr);
}
openFileChannelProcPtr = openFileChannelProcList;
while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
retVal = (*openFileChannelProcPtr->proc)(interp, path,
modeString, permissions);
openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
}
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
if (retVal != NULL) {
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
/*
* We need this just to ensure we return the correct error messages
* under some circumstances.
*/
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return NULL;
}
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
if (proc != NULL) {
int mode, seekFlag;
mode = TclGetOpenMode(interp, modeString, &seekFlag);
if (mode == -1) {
return NULL;
}
retVal = (*proc)(interp, pathPtr, mode, permissions);
if (retVal != NULL) {
if (seekFlag) {
if (Tcl_Seek(retVal, (Tcl_WideInt)0,
SEEK_END) < (Tcl_WideInt)0) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp,
"could not seek to end of file while opening \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
Tcl_Close(NULL, retVal);
return NULL;
}
}
}
return retVal;
}
}
/* File doesn't belong to any filesystem that can open it */
Tcl_SetErrno(ENOENT);
if (interp != NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSUtime --
*
* This procedure replaces the library version of utime.
* The appropriate function for the filesystem to which pathPtr
* belongs will be called.
*
* Results:
* See utime documentation.
*
* Side effects:
* See utime documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSUtime (pathPtr, tval)
Tcl_Obj *pathPtr; /* File to change access/modification times */
struct utimbuf *tval; /* Structure containing access/modification
* times to use. Should not be modified. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSUtimeProc *proc = fsPtr->utimeProc;
if (proc != NULL) {
return (*proc)(pathPtr, tval);
}
}
return -1;
}
/*
*----------------------------------------------------------------------
*
* NativeFileAttrStrings --
*
* This procedure implements the platform dependent 'file
* attributes' subcommand, for the native filesystem, for listing
* the set of possible attribute strings. This function is part
* of Tcl's native filesystem support, and is placed here because
* it is shared by Unix, MacOS and Windows code.
*
* Results:
* An array of strings
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static CONST char**
NativeFileAttrStrings(pathPtr, objPtrRef)
Tcl_Obj *pathPtr;
Tcl_Obj** objPtrRef;
{
return tclpFileAttrStrings;
}
/*
*----------------------------------------------------------------------
*
* NativeFileAttrsGet --
*
* This procedure implements the platform dependent
* 'file attributes' subcommand, for the native
* filesystem, for 'get' operations. This function is part
* of Tcl's native filesystem support, and is placed here
* because it is shared by Unix, MacOS and Windows code.
*
* Results:
* Standard Tcl return code. The object placed in objPtrRef
* (if TCL_OK was returned) is likely to have a refCount of zero.
* Either way we must either store it somewhere (e.g. the Tcl
* result), or Incr/Decr its refCount to ensure it is properly
* freed.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
NativeFileAttrsGet(interp, index, pathPtr, objPtrRef)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *pathPtr; /* path of file we are operating on. */
Tcl_Obj **objPtrRef; /* for output. */
{
return (*tclpFileAttrProcs[index].getProc)(interp, index,
pathPtr, objPtrRef);
}
/*
*----------------------------------------------------------------------
*
* NativeFileAttrsSet --
*
* This procedure implements the platform dependent
* 'file attributes' subcommand, for the native
* filesystem, for 'set' operations. This function is part
* of Tcl's native filesystem support, and is placed here
* because it is shared by Unix, MacOS and Windows code.
*
* Results:
* Standard Tcl return code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
NativeFileAttrsSet(interp, index, pathPtr, objPtr)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *pathPtr; /* path of file we are operating on. */
Tcl_Obj *objPtr; /* set to this value. */
{
return (*tclpFileAttrProcs[index].setProc)(interp, index,
pathPtr, objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrStrings --
*
* This procedure implements part of the hookable 'file
* attributes' subcommand. The appropriate function for the
* filesystem to which pathPtr belongs will be called.
*
* Results:
* The called procedure may either return an array of strings,
* or may instead return NULL and place a Tcl list into the
* given objPtrRef. Tcl will take that list and first increment
* its refCount before using it. On completion of that use, Tcl
* will decrement its refCount. Hence if the list should be
* disposed of by Tcl when done, it should have a refCount of zero,
* and if the list should not be disposed of, the filesystem
* should ensure it retains a refCount on the object.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char **
Tcl_FSFileAttrStrings(pathPtr, objPtrRef)
Tcl_Obj* pathPtr;
Tcl_Obj** objPtrRef;
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
if (proc != NULL) {
return (*proc)(pathPtr, objPtrRef);
}
}
Tcl_SetErrno(ENOENT);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrsGet --
*
* This procedure implements read access for the hookable 'file
* attributes' subcommand. The appropriate function for the
* filesystem to which pathPtr belongs will be called.
*
* Results:
* Standard Tcl return code. The object placed in objPtrRef
* (if TCL_OK was returned) is likely to have a refCount of zero.
* Either way we must either store it somewhere (e.g. the Tcl
* result), or Incr/Decr its refCount to ensure it is properly
* freed.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *pathPtr; /* filename we are operating on. */
Tcl_Obj **objPtrRef; /* for output. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;
if (proc != NULL) {
return (*proc)(interp, index, pathPtr, objPtrRef);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrsSet --
*
* This procedure implements write access for the hookable 'file
* attributes' subcommand. The appropriate function for the
* filesystem to which pathPtr belongs will be called.
*
* Results:
* Standard Tcl return code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *pathPtr; /* filename we are operating on. */
Tcl_Obj *objPtr; /* Input value. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;
if (proc != NULL) {
return (*proc)(interp, index, pathPtr, objPtr);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSGetCwd --
*
* This function replaces the library version of getcwd().
*
* Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains
* its own record (in a Tcl_Obj) of the cwd, and an attempt
* is made to synchronise this with the cwd's containing filesystem,
* if that filesystem provides a cwdProc (e.g. the native filesystem).
*
* Note that if Tcl's cwd is not in the native filesystem, then of
* course Tcl's cwd and the native cwd are different: extensions
* should therefore ensure they only access the cwd through this
* function to avoid confusion.
*
* If a global cwdPathPtr already exists, it is cached in the thread's
* private data structures and reference to the cached copy is returned,
* subject to a synchronisation attempt in that cwdPathPtr's fs.
*
* Otherwise, the chain of functions that have been "inserted"
* into the filesystem will be called in succession until either a
* value other than NULL is returned, or the entire list is
* visited.
*
* Results:
* The result is a pointer to a Tcl_Obj specifying the current
* directory, or NULL if the current directory could not be
* determined. If NULL is returned, an error message is left in the
* interp's result.
*
* The result already has its refCount incremented for the caller.
* When it is no longer needed, that refCount should be decremented.
*
* Side effects:
* Various objects may be freed and allocated.
*
*----------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSGetCwd(interp)
Tcl_Interp *interp;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (TclFSCwdPointerEquals(NULL)) {
FilesystemRecord *fsRecPtr;
Tcl_Obj *retVal = NULL;
/*
* We've never been called before, try to find a cwd. Call
* each of the "Tcl_GetCwd" function in succession. A non-NULL
* return value indicates the particular function has
* succeeded.
*/
fsRecPtr = FsGetFirstFilesystem();
while ((retVal == NULL) && (fsRecPtr != NULL)) {
Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
if (proc != NULL) {
retVal = (*proc)(interp);
}
fsRecPtr = fsRecPtr->nextPtr;
}
/*
* Now the 'cwd' may NOT be normalized, at least on some
* platforms. For the sake of efficiency, we want a completely
* normalized cwd at all times.
*
* Finally, if retVal is NULL, we do not have a cwd, which
* could be problematic.
*/
if (retVal != NULL) {
Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal);
if (norm != NULL) {
/*
* We found a cwd, which is now in our global storage.
* We must make a copy. Norm already has a refCount of 1.
*
* Threading issue: note that multiple threads at system
* startup could in principle call this procedure
* simultaneously. They will therefore each set the
* cwdPathPtr independently. That behaviour is a bit
* peculiar, but should be fine. Once we have a cwd,
* we'll always be in the 'else' branch below which
* is simpler.
*/
FsUpdateCwd(norm);
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
}
} else {
/*
* We already have a cwd cached, but we want to give the
* filesystem it is in a chance to check whether that cwd
* has changed, or is perhaps no longer accessible. This
* allows an error to be thrown if, say, the permissions on
* that directory have changed.
*/
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr);
/*
* If the filesystem couldn't be found, or if no cwd function
* exists for this filesystem, then we simply assume the cached
* cwd is ok. If we do call a cwd, we must watch for errors
* (if the cwd returns NULL). This ensures that, say, on Unix
* if the permissions of the cwd change, 'pwd' does actually
* throw the correct error in Tcl. (This is tested for in the
* test suite on unix).
*/
if (fsPtr != NULL) {
Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc;
if (proc != NULL) {
Tcl_Obj *retVal = (*proc)(interp);
if (retVal != NULL) {
Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal);
/*
* Check whether cwd has changed from the value
* previously stored in cwdPathPtr. Really 'norm'
* shouldn't be null, but we are careful.
*/
if (norm == NULL) {
/* Do nothing */
} else if (Tcl_FSEqualPaths(tsdPtr->cwdPathPtr, norm)) {
/*
* If the paths were equal, we can be more
* efficient and retain the old path object
* which will probably already be shared. In
* this case we can simply free the normalized
* path we just calculated.
*/
Tcl_DecrRefCount(norm);
} else {
FsUpdateCwd(norm);
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
} else {
/* The 'cwd' function returned an error; reset the cwd */
FsUpdateCwd(NULL);
}
}
}
}
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
return tsdPtr->cwdPathPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSChdir --
*
* This function replaces the library version of chdir().
*
* The path is normalized and then passed to the filesystem
* which claims it.
*
* Results:
* See chdir() documentation. If successful, we keep a
* record of the successful path in cwdPathPtr for subsequent
* calls to getcwd.
*
* Side effects:
* See chdir() documentation. The global cwdPathPtr may
* change value.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSChdir(pathPtr)
Tcl_Obj *pathPtr;
{
Tcl_Filesystem *fsPtr;
int retVal = -1;
#ifdef WIN32
/*
* This complete hack addresses the bug tested in winFCmd-16.12,
* where having your HOME as "C:" (IOW, a seemingly path relative
* dir) would cause a crash when you cd'd to it and requested 'pwd'.
* The work-around is to force such a dir into an absolute path by
* tacking on '/'.
*
* We check for '~' specifically because that's what Tcl_CdObjCmd
* passes in that triggers the bug. A direct 'cd C:' call will not
* because that gets the volumerelative pwd.
*
* This is not an issue for 8.5 as that has a more elaborate change
* that requires the use of TCL_FILESYSTEM_VERSION_2.
*/
Tcl_Obj *objPtr = NULL;
if (pathPtr->bytes && pathPtr->length == 1 && pathPtr->bytes[0] == '~') {
int len;
char *str;
objPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (objPtr == NULL) {
Tcl_SetErrno(ENOENT);
return -1;
}
Tcl_IncrRefCount(objPtr);
str = Tcl_GetStringFromObj(objPtr, &len);
if (len == 2 && str[1] == ':') {
pathPtr = Tcl_NewStringObj(str, len);
Tcl_AppendToObj(pathPtr, "/", 1);
Tcl_IncrRefCount(pathPtr);
Tcl_DecrRefCount(objPtr);
objPtr = pathPtr;
} else {
Tcl_DecrRefCount(objPtr);
objPtr = NULL;
}
}
#endif
if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) {
#ifdef WIN32
if (objPtr) { Tcl_DecrRefCount(objPtr); }
#endif
Tcl_SetErrno(ENOENT);
return -1;
}
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSChdirProc *proc = fsPtr->chdirProc;
if (proc != NULL) {
retVal = (*proc)(pathPtr);
} else {
/* Fallback on stat-based implementation */
Tcl_StatBuf buf;
/* If the file can be stat'ed and is a directory and
* is readable, then we can chdir. */
if ((Tcl_FSStat(pathPtr, &buf) == 0)
&& (S_ISDIR(buf.st_mode))
&& (Tcl_FSAccess(pathPtr, R_OK) == 0)) {
/* We allow the chdir */
retVal = 0;
}
}
}
if (retVal != -1) {
/*
* The cwd changed, or an error was thrown. If an error was
* thrown, we can just continue (and that will report the error
* to the user). If there was no error we must assume that the
* cwd was actually changed to the normalized value we
* calculated above, and we must therefore cache that
* information.
*/
if (retVal == 0) {
/*
* Note that this normalized path may be different to what
* we found above (or at least a different object), if the
* filesystem epoch changed recently. This can actually
* happen with scripted documents very easily. Therefore
* we ask for the normalized path again (the correct value
* will have been cached as a result of the
* Tcl_FSGetFileSystemForPath call above anyway).
*/
Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normDirName == NULL) {
#ifdef WIN32
if (objPtr) { Tcl_DecrRefCount(objPtr); }
#endif
Tcl_SetErrno(ENOENT);
return -1;
}
FsUpdateCwd(normDirName);
}
} else {
Tcl_SetErrno(ENOENT);
}
#ifdef WIN32
if (objPtr) { Tcl_DecrRefCount(objPtr); }
#endif
return (retVal);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSLoadFile --
*
* Dynamically loads a binary code file into memory and returns
* the addresses of two procedures within that file, if they are
* defined. The appropriate function for the filesystem to which
* pathPtr belongs will be called.
*
* Note that the native filesystem doesn't actually assume
* 'pathPtr' is a path. Rather it assumes filename is either
* a path or just the name of a file which can be found somewhere
* in the environment's loadable path. This behaviour is not
* very compatible with virtual filesystems (and has other problems
* documented in the load man-page), so it is advised that full
* paths are always used.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error
* message is left in the interp's result.
*
* Side effects:
* New code suddenly appears in memory. This may later be
* unloaded by passing the clientData to the unloadProc.
*
*----------------------------------------------------------------------
*/
typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
int
Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
handlePtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code. */
CONST char *sym1, *sym2; /* Names of two procedures to look up in
* the file's symbol table. */
Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
/* Where to return the addresses corresponding
* to sym1 and sym2. */
Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr;
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for
* this file. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc;
if (proc != NULL) {
int retVal = ((Tcl_FSLoadFileProc2 *)proc)
(interp, pathPtr, handlePtr, unloadProcPtr, 0);
if (retVal != TCL_OK) {
return retVal;
}
if (*handlePtr == NULL) {
return TCL_ERROR;
}
if (sym1 != NULL) {
*proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1);
}
if (sym2 != NULL) {
*proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2);
}
return retVal;
} else {
Tcl_Filesystem *copyFsPtr;
Tcl_Obj *copyToPtr;
/* First check if it is readable -- and exists! */
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
Tcl_AppendResult(interp, "couldn't load library \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
#ifdef TCL_LOAD_FROM_MEMORY
/*
* The platform supports loading code from memory, so ask for a
* buffer of the appropriate size, read the file into it and
* load the code from the buffer:
*/
do {
int ret, size;
void *buffer;
Tcl_StatBuf statBuf;
Tcl_Channel data;
ret = Tcl_FSStat(pathPtr, &statBuf);
if (ret < 0) {
break;
}
size = (int) statBuf.st_size;
/* Tcl_Read takes an int: check that file size isn't wide */
if (size != (Tcl_WideInt)statBuf.st_size) {
break;
}
data = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0666);
if (!data) {
break;
}
buffer = TclpLoadMemoryGetBuffer(interp, size);
if (!buffer) {
Tcl_Close(interp, data);
break;
}
Tcl_SetChannelOption(interp, data, "-translation", "binary");
ret = Tcl_Read(data, buffer, size);
Tcl_Close(interp, data);
ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, unloadProcPtr);
if (ret == TCL_OK) {
if (*handlePtr == NULL) {
break;
}
if (sym1 != NULL) {
*proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1);
}
if (sym2 != NULL) {
*proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2);
}
return TCL_OK;
}
} while (0);
Tcl_ResetResult(interp);
#endif
/*
* Get a temporary filename to use, first to
* copy the file into, and then to load.
*/
copyToPtr = TclpTempFileName();
if (copyToPtr == NULL) {
return -1;
}
Tcl_IncrRefCount(copyToPtr);
copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
/*
* We already know we can't use Tcl_FSLoadFile from
* this filesystem, and we must avoid a possible
* infinite loop. Try to delete the file we
* probably created, and then exit.
*/
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return -1;
}
if (TclCrossFilesystemCopy(interp, pathPtr,
copyToPtr) == TCL_OK) {
Tcl_LoadHandle newLoadHandle = NULL;
Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
FsDivertLoad *tvdlPtr;
int retVal;
#if !defined(__WIN32__)
/*
* Do we need to set appropriate permissions
* on the file? This may be required on some
* systems. On Unix we could loop over
* the file attributes, and set any that are
* called "-permissions" to 0700. However,
* we just do this directly, like this:
*/
Tcl_Obj* perm = Tcl_NewStringObj("0700",-1);
Tcl_IncrRefCount(perm);
Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm);
Tcl_DecrRefCount(perm);
#endif
/*
* We need to reset the result now, because the cross-
* filesystem copy may have stored the number of bytes
* in the result
*/
Tcl_ResetResult(interp);
retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2,
proc1Ptr, proc2Ptr,
&newLoadHandle,
&newUnloadProcPtr);
if (retVal != TCL_OK) {
/* The file didn't load successfully */
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return retVal;
}
/*
* Try to delete the file immediately -- this is
* possible in some OSes, and avoids any worries
* about leaving the copy laying around on exit.
*/
if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
Tcl_DecrRefCount(copyToPtr);
/*
* We tell our caller about the real shared
* library which was loaded. Note that this
* does mean that the package list maintained
* by 'load' will store the original (vfs)
* path alongside the temporary load handle
* and unload proc ptr.
*/
(*handlePtr) = newLoadHandle;
(*unloadProcPtr) = newUnloadProcPtr;
return TCL_OK;
}
/*
* When we unload this file, we need to divert the
* unloading so we can unload and cleanup the
* temporary file correctly.
*/
tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad));
/*
* Remember three pieces of information. This allows
* us to cleanup the diverted load completely, on
* platforms which allow proper unloading of code.
*/
tvdlPtr->loadHandle = newLoadHandle;
tvdlPtr->unloadProcPtr = newUnloadProcPtr;
if (copyFsPtr != &tclNativeFilesystem) {
/* copyToPtr is already incremented for this reference */
tvdlPtr->divertedFile = copyToPtr;
/*
* This is the filesystem we loaded it into. Since
* we have a reference to 'copyToPtr', we already
* have a refCount on this filesystem, so we don't
* need to worry about it disappearing on us.
*/
tvdlPtr->divertedFilesystem = copyFsPtr;
tvdlPtr->divertedFileNativeRep = NULL;
} else {
/* We need the native rep */
tvdlPtr->divertedFileNativeRep =
TclNativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr,
copyFsPtr));
/*
* We don't need or want references to the copied
* Tcl_Obj or the filesystem if it is the native
* one.
*/
tvdlPtr->divertedFile = NULL;
tvdlPtr->divertedFilesystem = NULL;
Tcl_DecrRefCount(copyToPtr);
}
copyToPtr = NULL;
(*handlePtr) = (Tcl_LoadHandle) tvdlPtr;
(*unloadProcPtr) = &FSUnloadTempFile;
return retVal;
} else {
/* Cross-platform copy failed */
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return TCL_ERROR;
}
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
* This function used to be in the platform specific directories, but it
* has now been made to work cross-platform
*/
int
TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code (UTF-8). */
CONST char *sym1, *sym2; /* Names of two procedures to look up in
* the file's symbol table. */
Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
/* Where to return the addresses corresponding
* to sym1 and sym2. */
ClientData *clientDataPtr; /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr;
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for
* this file. */
{
Tcl_LoadHandle handle = NULL;
int res;
res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr);
if (res != TCL_OK) {
return res;
}
if (handle == NULL) {
return TCL_ERROR;
}
*clientDataPtr = (ClientData)handle;
*proc1Ptr = TclpFindSymbol(interp, handle, sym1);
*proc2Ptr = TclpFindSymbol(interp, handle, sym2);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* FSUnloadTempFile --
*
* This function is called when we loaded a library of code via
* an intermediate temporary file. This function ensures
* the library is correctly unloaded and the temporary file
* is correctly deleted.
*
* Results:
* None.
*
* Side effects:
* The effects of the 'unload' function called, and of course
* the temporary file will be deleted.
*
*---------------------------------------------------------------------------
*/
static void
FSUnloadTempFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to Tcl_FSLoadFile(). The loadHandle is
* a token that represents the loaded
* file. */
{
FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle;
/*
* This test should never trigger, since we give
* the client data in the function above.
*/
if (tvdlPtr == NULL) { return; }
/*
* Call the real 'unloadfile' proc we actually used. It is very
* important that we call this first, so that the shared library
* is actually unloaded by the OS. Otherwise, the following
* 'delete' may well fail because the shared library is still in
* use.
*/
if (tvdlPtr->unloadProcPtr != NULL) {
(*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle);
}
if (tvdlPtr->divertedFilesystem == NULL) {
/*
* It was the native filesystem, and we have a special
* function available just for this purpose, which we
* know works even at this late stage.
*/
TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);
} else {
/*
* Remove the temporary file we created. Note, we may crash
* here because encodings have been taken down already.
*/
if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile)
!= TCL_OK) {
/*
* The above may have failed because the filesystem, or something
* it depends upon (e.g. encodings) have been taken down because
* Tcl is exiting.
*
* We may need to work out how to delete this file more
* robustly (or give the filesystem the information it needs
* to delete the file more robustly).
*
* In particular, one problem might be that the filesystem
* cannot extract the information it needs from the above
* path object because Tcl's entire filesystem apparatus
* (the code in this file) has been finalized, and it
* refuses to pass the internal representation to the
* filesystem.
*/
}
/*
* And free up the allocations. This will also of course remove
* a refCount from the Tcl_Filesystem to which this file belongs,
* which could then free up the filesystem if we are exiting.
*/
Tcl_DecrRefCount(tvdlPtr->divertedFile);
}
ckfree((char*)tvdlPtr);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSLink --
*
* This function replaces the library version of readlink() and
* can also be used to make links. The appropriate function for
* the filesystem to which pathPtr belongs will be called.
*
* Results:
* If toPtr is NULL, then the result is a Tcl_Obj specifying the
* contents of the symbolic link given by 'pathPtr', or NULL if
* the symbolic link could not be read. The result is owned by
* the caller, which should call Tcl_DecrRefCount when the result
* is no longer needed.
*
* If toPtr is non-NULL, then the result is toPtr if the link action
* was successful, or NULL if not. In this case the result has no
* additional reference count, and need not be freed. The actual
* action to perform is given by the 'linkAction' flags, which is
* an or'd combination of:
*
* TCL_CREATE_SYMBOLIC_LINK
* TCL_CREATE_HARD_LINK
*
* Note that most filesystems will not support linking across
* to different filesystems, so this function will usually
* fail unless toPtr is in the same FS as pathPtr.
*
* Side effects:
* See readlink() documentation. A new filesystem link
* object may appear
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSLink(pathPtr, toPtr, linkAction)
Tcl_Obj *pathPtr; /* Path of file to readlink or link */
Tcl_Obj *toPtr; /* NULL or path to be linked to */
int linkAction; /* Action to perform */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSLinkProc *proc = fsPtr->linkProc;
if (proc != NULL) {
return (*proc)(pathPtr, toPtr, linkAction);
}
}
/*
* If S_IFLNK isn't defined it means that the machine doesn't
* support symbolic links, so the file can't possibly be a
* symbolic link. Generate an EINVAL error, which is what
* happens on machines that do support symbolic links when
* you invoke readlink on a file that isn't a symbolic link.
*/
#ifndef S_IFLNK
errno = EINVAL;
#else
Tcl_SetErrno(ENOENT);
#endif /* S_IFLNK */
return NULL;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSListVolumes --
*
* Lists the currently mounted volumes. The chain of functions
* that have been "inserted" into the filesystem will be called in
* succession; each may return a list of volumes, all of which are
* added to the result until all mounted file systems are listed.
*
* Notice that we assume the lists returned by each filesystem
* (if non NULL) have been given a refCount for us already.
* However, we are NOT allowed to hang on to the list itself
* (it belongs to the filesystem we called). Therefore we
* quite naturally add its contents to the result we are
* building, and then decrement the refCount.
*
* Results:
* The list of volumes, in an object which has refCount 0.
*
* Side effects:
* None
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSListVolumes(void)
{
FilesystemRecord *fsRecPtr;
Tcl_Obj *resultPtr = Tcl_NewObj();
/*
* Call each of the "listVolumes" function in succession.
* A non-NULL return value indicates the particular function has
* succeeded. We call all the functions registered, since we want
* a list of all drives from all filesystems.
*/
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
if (proc != NULL) {
Tcl_Obj *thisFsVolumes = (*proc)();
if (thisFsVolumes != NULL) {
Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
Tcl_DecrRefCount(thisFsVolumes);
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
return resultPtr;
}
/*
*---------------------------------------------------------------------------
*
* FsListMounts --
*
* List all mounts within the given directory, which match the
* given pattern.
*
* Results:
* The list of mounts, in a list object which has refCount 0, or
* NULL if we didn't even find any filesystems to try to list
* mounts.
*
* Side effects:
* None
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj*
FsListMounts(pathPtr, pattern)
Tcl_Obj *pathPtr; /* Contains path to directory to search. */
CONST char *pattern; /* Pattern to match against. */
{
FilesystemRecord *fsRecPtr;
Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL };
Tcl_Obj *resultPtr = NULL;
/*
* Call each of the "listMounts" functions in succession.
* A non-NULL return value indicates the particular function has
* succeeded. We call all the functions registered, since we want
* a list from each filesystems.
*/
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
Tcl_FSMatchInDirectoryProc *proc =
fsRecPtr->fsPtr->matchInDirectoryProc;
if (proc != NULL) {
if (resultPtr == NULL) {
resultPtr = Tcl_NewObj();
}
(*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly);
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
return resultPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSSplitPath --
*
* This function takes the given Tcl_Obj, which should be a valid
* path, and returns a Tcl List object containing each segment of
* that path as an element.
*
* Results:
* Returns list object with refCount of zero. If the passed in
* lenPtr is non-NULL, we use it to return the number of elements
* in the returned list.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSSplitPath(pathPtr, lenPtr)
Tcl_Obj *pathPtr; /* Path to split. */
int *lenPtr; /* int to store number of path elements. */
{
Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */
Tcl_Filesystem *fsPtr;
char separator = '/';
int driveNameLength;
char *p;
/*
* Perform platform specific splitting.
*/
if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength)
== TCL_PATH_ABSOLUTE) {
if (fsPtr == &tclNativeFilesystem) {
return TclpNativeSplitPath(pathPtr, lenPtr);
}
} else {
return TclpNativeSplitPath(pathPtr, lenPtr);
}
/* We assume separators are single characters */
if (fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr);
if (sep != NULL) {
separator = Tcl_GetString(sep)[0];
}
}
/*
* Place the drive name as first element of the
* result list. The drive name may contain strange
* characters, like colons and multiple forward slashes
* (for example 'ftp://' is a valid vfs drive name)
*/
result = Tcl_NewObj();
p = Tcl_GetString(pathPtr);
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(p, driveNameLength));
p+= driveNameLength;
/* Add the remaining path elements to the list */
for (;;) {
char *elementStart = p;
int length;
while ((*p != '\0') && (*p != separator)) {
p++;
}
length = p - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
if (elementStart[0] == '~') {
nextElt = Tcl_NewStringObj("./",2);
Tcl_AppendToObj(nextElt, elementStart, length);
} else {
nextElt = Tcl_NewStringObj(elementStart, length);
}
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
if (*p++ == '\0') {
break;
}
}
/*
* Compute the number of elements in the result.
*/
if (lenPtr != NULL) {
Tcl_ListObjLength(NULL, result, lenPtr);
}
return result;
}
/* Simple helper function */
Tcl_Obj*
TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr)
Tcl_Filesystem *fromFilesystem;
ClientData clientData;
FilesystemRecord **fsRecPtrPtr;
{
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr == fromFilesystem) {
*fsRecPtrPtr = fsRecPtr;
break;
}
fsRecPtr = fsRecPtr->nextPtr;
}
if ((fsRecPtr != NULL)
&& (fromFilesystem->internalToNormalizedProc != NULL)) {
return (*fromFilesystem->internalToNormalizedProc)(clientData);
} else {
return NULL;
}
}
/*
*----------------------------------------------------------------------
*
* GetPathType --
*
* Helper function used by FSGetPathType.
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
* TCL_PATH_VOLUME_RELATIVE. The filesystem reference will
* be set if and only if it is non-NULL and the function's
* return value is TCL_PATH_ABSOLUTE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_PathType
GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
Tcl_Obj *pathObjPtr;
Tcl_Filesystem **filesystemPtrPtr;
int *driveNameLengthPtr;
Tcl_Obj **driveNameRef;
{
FilesystemRecord *fsRecPtr;
int pathLen;
char *path;
Tcl_PathType type = TCL_PATH_RELATIVE;
path = Tcl_GetStringFromObj(pathObjPtr, &pathLen);
/*
* Call each of the "listVolumes" function in succession, checking
* whether the given path is an absolute path on any of the volumes
* returned (this is done by checking whether the path's prefix
* matches).
*/
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
/*
* We want to skip the native filesystem in this loop because
* otherwise we won't necessarily pass all the Tcl testsuite --
* this is because some of the tests artificially change the
* current platform (between mac, win, unix) but the list
* of volumes we get by calling (*proc) will reflect the current
* (real) platform only and this may cause some tests to fail.
* In particular, on unix '/' will match the beginning of
* certain absolute Windows paths starting '//' and those tests
* will go wrong.
*
* Besides these test-suite issues, there is one other reason
* to skip the native filesystem --- since the tclFilename.c
* code has nice fast 'absolute path' checkers, we don't want
* to waste time repeating that effort here, and this
* function is actually called quite often, so if we can
* save the overhead of the native filesystem returning us
* a list of volumes all the time, it is better.
*/
if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) {
int numVolumes;
Tcl_Obj *thisFsVolumes = (*proc)();
if (thisFsVolumes != NULL) {
if (Tcl_ListObjLength(NULL, thisFsVolumes,
&numVolumes) != TCL_OK) {
/*
* This is VERY bad; the Tcl_FSListVolumesProc
* didn't return a valid list. Set numVolumes to
* -1 so that we skip the while loop below and just
* return with the current value of 'type'.
*
* It would be better if we could signal an error
* here (but panic seems a bit excessive).
*/
numVolumes = -1;
}
while (numVolumes > 0) {
Tcl_Obj *vol;
int len;
char *strVol;
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
strVol = Tcl_GetStringFromObj(vol,&len);
if (pathLen < len) {
continue;
}
if (strncmp(strVol, path, (size_t) len) == 0) {
type = TCL_PATH_ABSOLUTE;
if (filesystemPtrPtr != NULL) {
*filesystemPtrPtr = fsRecPtr->fsPtr;
}
if (driveNameLengthPtr != NULL) {
*driveNameLengthPtr = len;
}
if (driveNameRef != NULL) {
*driveNameRef = vol;
Tcl_IncrRefCount(vol);
}
break;
}
}
Tcl_DecrRefCount(thisFsVolumes);
if (type == TCL_PATH_ABSOLUTE) {
/* We don't need to examine any more filesystems */
break;
}
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
if (type != TCL_PATH_ABSOLUTE) {
type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr,
driveNameRef);
if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
*filesystemPtrPtr = &tclNativeFilesystem;
}
}
return type;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSRenameFile --
*
* If the two paths given belong to the same filesystem, we call
* that filesystems rename function. Otherwise we simply
* return the posix error 'EXDEV', and -1.
*
* Results:
* Standard Tcl error code if a function was called.
*
* Side effects:
* A file may be renamed.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSRenameFile(srcPathPtr, destPathPtr)
Tcl_Obj* srcPathPtr; /* Pathname of file or dir to be renamed
* (UTF-8). */
Tcl_Obj *destPathPtr; /* New pathname of file or directory
* (UTF-8). */
{
int retVal = -1;
Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
if (fsPtr == fsPtr2 && fsPtr != NULL) {
Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc;
if (proc != NULL) {
retVal = (*proc)(srcPathPtr, destPathPtr);
}
}
if (retVal == -1) {
Tcl_SetErrno(EXDEV);
}
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSCopyFile --
*
* If the two paths given belong to the same filesystem, we call
* that filesystem's copy function. Otherwise we simply
* return the posix error 'EXDEV', and -1.
*
* Note that in the native filesystems, 'copyFileProc' is defined
* to copy soft links (i.e. it copies the links themselves, not
* the things they point to).
*
* Results:
* Standard Tcl error code if a function was called.
*
* Side effects:
* A file may be copied.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCopyFile(srcPathPtr, destPathPtr)
Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */
Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */
{
int retVal = -1;
Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
if (fsPtr == fsPtr2 && fsPtr != NULL) {
Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc;
if (proc != NULL) {
retVal = (*proc)(srcPathPtr, destPathPtr);
}
}
if (retVal == -1) {
Tcl_SetErrno(EXDEV);
}
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* TclCrossFilesystemCopy --
*
* Helper for above function, and for Tcl_FSLoadFile, to copy
* files from one filesystem to another. This function will
* overwrite the target file if it already exists.
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* A file may be created.
*
*---------------------------------------------------------------------------
*/
int
TclCrossFilesystemCopy(interp, source, target)
Tcl_Interp *interp; /* For error messages */
Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */
Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */
{
int result = TCL_ERROR;
int prot = 0666;
Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot);
if (out != NULL) {
/* It looks like we can copy it over */
Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source,
"r", prot);
if (in == NULL) {
/* This is very strange, we checked this above */
Tcl_Close(interp, out);
} else {
Tcl_StatBuf sourceStatBuf;
struct utimbuf tval;
/*
* Copy it synchronously. We might wish to add an
* asynchronous option to support vfs's which are
* slow (e.g. network sockets).
*/
Tcl_SetChannelOption(interp, in, "-translation", "binary");
Tcl_SetChannelOption(interp, out, "-translation", "binary");
if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
result = TCL_OK;
}
/*
* If the copy failed, assume that copy channel left
* a good error message.
*/
Tcl_Close(interp, in);
Tcl_Close(interp, out);
/* Set modification date of copied file */
if (Tcl_FSLstat(source, &sourceStatBuf) == 0) {
tval.actime = sourceStatBuf.st_atime;
tval.modtime = sourceStatBuf.st_mtime;
Tcl_FSUtime(target, &tval);
}
}
}
return result;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSDeleteFile --
*
* The appropriate function for the filesystem to which pathPtr
* belongs will be called.
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* A file may be deleted.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSDeleteFile(pathPtr)
Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
if (proc != NULL) {
return (*proc)(pathPtr);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSCreateDirectory --
*
* The appropriate function for the filesystem to which pathPtr
* belongs will be called.
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* A directory may be created.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCreateDirectory(pathPtr)
Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
if (proc != NULL) {
return (*proc)(pathPtr);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSCopyDirectory --
*
* If the two paths given belong to the same filesystem, we call
* that filesystems copy-directory function. Otherwise we simply
* return the posix error 'EXDEV', and -1.
*
* Results:
* Standard Tcl error code if a function was called.
*
* Side effects:
* A directory may be copied.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied
* (UTF-8). */
Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */
Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a
* new object containing name of file
* causing error, with refCount 1. */
{
int retVal = -1;
Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
if (fsPtr == fsPtr2 && fsPtr != NULL) {
Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc;
if (proc != NULL) {
retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr);
}
}
if (retVal == -1) {
Tcl_SetErrno(EXDEV);
}
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSRemoveDirectory --
*
* The appropriate function for the filesystem to which pathPtr
* belongs will be called.
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* A directory may be deleted.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
Tcl_Obj *pathPtr; /* Pathname of directory to be removed
* (UTF-8). */
int recursive; /* If non-zero, removes directories that
* are nonempty. Otherwise, will only remove
* empty directories. */
Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a
* new object containing name of file
* causing error, with refCount 1. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc;
if (proc != NULL) {
if (recursive) {
/*
* We check whether the cwd lies inside this directory
* and move it if it does.
*/
Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
if (cwdPtr != NULL) {
char *cwdStr, *normPathStr;
int cwdLen, normLen;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath != NULL) {
normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
if ((cwdLen >= normLen) && (strncmp(normPathStr,
cwdStr, (size_t) normLen) == 0)) {
/*
* the cwd is inside the directory, so we
* perform a 'cd [file dirname $path]'
*/
Tcl_Obj *dirPtr = TclFileDirname(NULL, pathPtr);
Tcl_FSChdir(dirPtr);
Tcl_DecrRefCount(dirPtr);
}
}
Tcl_DecrRefCount(cwdPtr);
}
}
return (*proc)(pathPtr, recursive, errorPtr);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetFileSystemForPath --
*
* This function determines which filesystem to use for a
* particular path object, and returns the filesystem which
* accepts this file. If no filesystem will accept this object
* as a valid file path, then NULL is returned.
*
* Results:
.* NULL or a filesystem which will accept this path.
*
* Side effects:
* The object may be converted to a path type.
*
*---------------------------------------------------------------------------
*/
Tcl_Filesystem*
Tcl_FSGetFileSystemForPath(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
FilesystemRecord *fsRecPtr;
Tcl_Filesystem* retVal = NULL;
/*
* If the object has a refCount of zero, we reject it. This
* is to avoid possible segfaults or nondeterministic memory
* leaks (i.e. the user doesn't know if they should decrement
* the ref count on return or not).
*/
if (pathObjPtr->refCount == 0) {
panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
return NULL;
}
/*
* Check if the filesystem has changed in some way since
* this object's internal representation was calculated.
* Before doing that, assure we have the most up-to-date
* copy of the master filesystem. This is accomplished
* by the FsGetFirstFilesystem() call.
*/
fsRecPtr = FsGetFirstFilesystem();
if (TclFSEnsureEpochOk(pathObjPtr, &retVal) != TCL_OK) {
return NULL;
}
/*
* Call each of the "pathInFilesystem" functions in succession. A
* non-return value of -1 indicates the particular function has
* succeeded.
*/
while ((retVal == NULL) && (fsRecPtr != NULL)) {
Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc;
if (proc != NULL) {
ClientData clientData = NULL;
int ret = (*proc)(pathObjPtr, &clientData);
if (ret != -1) {
/*
* We assume the type of pathObjPtr hasn't been changed
* by the above call to the pathInFilesystemProc.
*/
TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData);
retVal = fsRecPtr->fsPtr;
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetNativePath --
*
* This function is for use by the Win/Unix/MacOS native filesystems,
* so that they can easily retrieve the native (char* or TCHAR*)
* representation of a path. Other filesystems will probably
* want to implement similar functions. They basically act as a
* safety net around Tcl_FSGetInternalRep. Normally your file-
* system procedures will always be called with path objects
* already converted to the correct filesystem, but if for
* some reason they are called directly (i.e. by procedures
* not in this file), then one cannot necessarily guarantee that
* the path object pointer is from the correct filesystem.
*
* Note: in the future it might be desireable to have separate
* versions of this function with different signatures, for
* example Tcl_FSGetNativeMacPath, Tcl_FSGetNativeUnixPath etc.
* Right now, since native paths are all string based, we use just
* one function. On MacOS we could possibly use an FSSpec or
* FSRef as the native representation.
*
* Results:
* NULL or a valid native path.
*
* Side effects:
* See Tcl_FSGetInternalRep.
*
*---------------------------------------------------------------------------
*/
CONST char *
Tcl_FSGetNativePath(pathObjPtr)
Tcl_Obj *pathObjPtr;
{
return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem);
}
/*
*---------------------------------------------------------------------------
*
* NativeCreateNativeRep --
*
* Create a native representation for the given path.
*
* Results:
* None.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static ClientData
NativeCreateNativeRep(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
char *nativePathPtr;
Tcl_DString ds;
Tcl_Obj* validPathObjPtr;
int len;
char *str;
/* Make sure the normalized path is set */
validPathObjPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
if (validPathObjPtr == NULL) {
return NULL;
}
str = Tcl_GetStringFromObj(validPathObjPtr, &len);
#ifdef __WIN32__
Tcl_WinUtfToTChar(str, len, &ds);
if (tclWinProcs->useWide) {
len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
} else {
len = Tcl_DStringLength(&ds) + sizeof(char);
}
#else
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
#endif
nativePathPtr = ckalloc((unsigned) len);
memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len);
Tcl_DStringFree(&ds);
return (ClientData)nativePathPtr;
}
/*
*---------------------------------------------------------------------------
*
* TclpNativeToNormalized --
*
* Convert native format to a normalized path object, with refCount
* of zero.
*
* Results:
* A valid normalized path.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclpNativeToNormalized(clientData)
ClientData clientData;
{
Tcl_DString ds;
Tcl_Obj *objPtr;
CONST char *copy;
int len;
#ifdef __WIN32__
Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);
#else
Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);
#endif
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
#ifdef __WIN32__
/*
* Certain native path representations on Windows have this special
* prefix to indicate that they are to be treated specially. For
* example extremely long paths, or symlinks
*/
if (*copy == '\\') {
if (0 == strncmp(copy,"\\??\\",4)) {
copy += 4;
len -= 4;
} else if (0 == strncmp(copy,"\\\\?\\",4)) {
copy += 4;
len -= 4;
}
}
#endif
objPtr = Tcl_NewStringObj(copy,len);
Tcl_DStringFree(&ds);
return objPtr;
}
/*
*---------------------------------------------------------------------------
*
* TclNativeDupInternalRep --
*
* Duplicate the native representation.
*
* Results:
* The copied native representation, or NULL if it is not possible
* to copy the representation.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
ClientData
TclNativeDupInternalRep(clientData)
ClientData clientData;
{
ClientData copy;
size_t len;
if (clientData == NULL) {
return NULL;
}
#ifdef __WIN32__
if (tclWinProcs->useWide) {
/* unicode representation when running on NT/2K/XP */
len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR));
} else {
/* ansi representation when running on 95/98/ME */
len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
}
#else
/* ansi representation when running on Unix/MacOS */
len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
#endif
copy = (ClientData) ckalloc(len);
memcpy((VOID*)copy, (VOID*)clientData, len);
return copy;
}
/*
*---------------------------------------------------------------------------
*
* NativeFreeInternalRep --
*
* Free a native internal representation, which will be non-NULL.
*
* Results:
* None.
*
* Side effects:
* Memory is released.
*
*---------------------------------------------------------------------------
*/
static void
NativeFreeInternalRep(clientData)
ClientData clientData;
{
ckfree((char*)clientData);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSFileSystemInfo --
*
* This function returns a list of two elements. The first
* element is the name of the filesystem (e.g. "native" or "vfs"),
* and the second is the particular type of the given path within
* that filesystem.
*
* Results:
* A list of two elements.
*
* Side effects:
* The object may be converted to a path type.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSFileSystemInfo(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
Tcl_Obj *resPtr;
Tcl_FSFilesystemPathTypeProc *proc;
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
if (fsPtr == NULL) {
return NULL;
}
resPtr = Tcl_NewListObj(0,NULL);
Tcl_ListObjAppendElement(NULL, resPtr,
Tcl_NewStringObj(fsPtr->typeName,-1));
proc = fsPtr->filesystemPathTypeProc;
if (proc != NULL) {
Tcl_Obj *typePtr = (*proc)(pathObjPtr);
if (typePtr != NULL) {
Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
}
}
return resPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSPathSeparator --
*
* This function returns the separator to be used for a given
* path. The object returned should have a refCount of zero
*
* Results:
* A Tcl object, with a refCount of zero. If the caller
* needs to retain a reference to the object, it should
* call Tcl_IncrRefCount.
*
* Side effects:
* The path object may be converted to a path type.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSPathSeparator(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
if (fsPtr == NULL) {
return NULL;
}
if (fsPtr->filesystemSeparatorProc != NULL) {
return (*fsPtr->filesystemSeparatorProc)(pathObjPtr);
}
return NULL;
}
/*
*---------------------------------------------------------------------------
*
* NativeFilesystemSeparator --
*
* This function is part of the native filesystem support, and
* returns the separator for the given path.
*
* Results:
* String object containing the separator character.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj*
NativeFilesystemSeparator(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
char *separator = NULL; /* lint */
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separator = "/";
break;
case TCL_PLATFORM_WINDOWS:
separator = "\\";
break;
}
return Tcl_NewStringObj(separator,1);
}
/* Everything from here on is contained in this obsolete ifdef */
#ifdef USE_OBSOLETE_FS_HOOKS
/*
*----------------------------------------------------------------------
*
* TclStatInsertProc --
*
* Insert the passed procedure pointer at the head of the list of
* functions which are used during a call to 'TclStat(...)'. The
* passed function should behave exactly like 'TclStat' when called
* during that time (see 'TclStat(...)' for more information).
* The function will be added even if it already in the list.
*
* Results:
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
* could not be allocated.
*
* Side effects:
* Memory allocated and modifies the link list for 'TclStat'
* functions.
*
*----------------------------------------------------------------------
*/
int
TclStatInsertProc (proc)
TclStatProc_ *proc;
{
int retVal = TCL_ERROR;
if (proc != NULL) {
StatProc *newStatProcPtr;
newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc));
if (newStatProcPtr != NULL) {
newStatProcPtr->proc = proc;
Tcl_MutexLock(&obsoleteFsHookMutex);
newStatProcPtr->nextPtr = statProcList;
statProcList = newStatProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclStatDeleteProc --
*
* Removed the passed function pointer from the list of 'TclStat'
* functions. Ensures that the built-in stat function is not
* removvable.
*
* Results:
* TCL_OK if the procedure pointer was successfully removed,
* TCL_ERROR otherwise.
*
* Side effects:
* Memory is deallocated and the respective list updated.
*
*----------------------------------------------------------------------
*/
int
TclStatDeleteProc (proc)
TclStatProc_ *proc;
{
int retVal = TCL_ERROR;
StatProc *tmpStatProcPtr;
StatProc *prevStatProcPtr = NULL;
Tcl_MutexLock(&obsoleteFsHookMutex);
tmpStatProcPtr = statProcList;
/*
* Traverse the 'statProcList' looking for the particular node
* whose 'proc' member matches 'proc' and remove that one from
* the list. Ensure that the "default" node cannot be removed.
*/
while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) {
if (tmpStatProcPtr->proc == proc) {
if (prevStatProcPtr == NULL) {
statProcList = tmpStatProcPtr->nextPtr;
} else {
prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr;
}
ckfree((char *)tmpStatProcPtr);
retVal = TCL_OK;
} else {
prevStatProcPtr = tmpStatProcPtr;
tmpStatProcPtr = tmpStatProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclAccessInsertProc --
*
* Insert the passed procedure pointer at the head of the list of
* functions which are used during a call to 'TclAccess(...)'.
* The passed function should behave exactly like 'TclAccess' when
* called during that time (see 'TclAccess(...)' for more
* information). The function will be added even if it already in
* the list.
*
* Results:
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
* could not be allocated.
*
* Side effects:
* Memory allocated and modifies the link list for 'TclAccess'
* functions.
*
*----------------------------------------------------------------------
*/
int
TclAccessInsertProc(proc)
TclAccessProc_ *proc;
{
int retVal = TCL_ERROR;
if (proc != NULL) {
AccessProc *newAccessProcPtr;
newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc));
if (newAccessProcPtr != NULL) {
newAccessProcPtr->proc = proc;
Tcl_MutexLock(&obsoleteFsHookMutex);
newAccessProcPtr->nextPtr = accessProcList;
accessProcList = newAccessProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclAccessDeleteProc --
*
* Removed the passed function pointer from the list of 'TclAccess'
* functions. Ensures that the built-in access function is not
* removvable.
*
* Results:
* TCL_OK if the procedure pointer was successfully removed,
* TCL_ERROR otherwise.
*
* Side effects:
* Memory is deallocated and the respective list updated.
*
*----------------------------------------------------------------------
*/
int
TclAccessDeleteProc(proc)
TclAccessProc_ *proc;
{
int retVal = TCL_ERROR;
AccessProc *tmpAccessProcPtr;
AccessProc *prevAccessProcPtr = NULL;
/*
* Traverse the 'accessProcList' looking for the particular node
* whose 'proc' member matches 'proc' and remove that one from
* the list. Ensure that the "default" node cannot be removed.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
tmpAccessProcPtr = accessProcList;
while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) {
if (tmpAccessProcPtr->proc == proc) {
if (prevAccessProcPtr == NULL) {
accessProcList = tmpAccessProcPtr->nextPtr;
} else {
prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr;
}
ckfree((char *)tmpAccessProcPtr);
retVal = TCL_OK;
} else {
prevAccessProcPtr = tmpAccessProcPtr;
tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclOpenFileChannelInsertProc --
*
* Insert the passed procedure pointer at the head of the list of
* functions which are used during a call to
* 'Tcl_OpenFileChannel(...)'. The passed function should behave
* exactly like 'Tcl_OpenFileChannel' when called during that time
* (see 'Tcl_OpenFileChannel(...)' for more information). The
* function will be added even if it already in the list.
*
* Results:
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
* could not be allocated.
*
* Side effects:
* Memory allocated and modifies the link list for
* 'Tcl_OpenFileChannel' functions.
*
*----------------------------------------------------------------------
*/
int
TclOpenFileChannelInsertProc(proc)
TclOpenFileChannelProc_ *proc;
{
int retVal = TCL_ERROR;
if (proc != NULL) {
OpenFileChannelProc *newOpenFileChannelProcPtr;
newOpenFileChannelProcPtr =
(OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc));
if (newOpenFileChannelProcPtr != NULL) {
newOpenFileChannelProcPtr->proc = proc;
Tcl_MutexLock(&obsoleteFsHookMutex);
newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
openFileChannelProcList = newOpenFileChannelProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclOpenFileChannelDeleteProc --
*
* Removed the passed function pointer from the list of
* 'Tcl_OpenFileChannel' functions. Ensures that the built-in
* open file channel function is not removable.
*
* Results:
* TCL_OK if the procedure pointer was successfully removed,
* TCL_ERROR otherwise.
*
* Side effects:
* Memory is deallocated and the respective list updated.
*
*----------------------------------------------------------------------
*/
int
TclOpenFileChannelDeleteProc(proc)
TclOpenFileChannelProc_ *proc;
{
int retVal = TCL_ERROR;
OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;
/*
* Traverse the 'openFileChannelProcList' looking for the particular
* node whose 'proc' member matches 'proc' and remove that one from
* the list.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
tmpOpenFileChannelProcPtr = openFileChannelProcList;
while ((retVal == TCL_ERROR) &&
(tmpOpenFileChannelProcPtr != NULL)) {
if (tmpOpenFileChannelProcPtr->proc == proc) {
if (prevOpenFileChannelProcPtr == NULL) {
openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
} else {
prevOpenFileChannelProcPtr->nextPtr =
tmpOpenFileChannelProcPtr->nextPtr;
}
ckfree((char *)tmpOpenFileChannelProcPtr);
retVal = TCL_OK;
} else {
prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
/*
* Prototypes for procedures defined later in this file.
*/
static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr));
static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *objPtr));
static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static int FindSplitPos _ANSI_ARGS_((char *path, char *separator));
/*
* Define the 'path' object type, which Tcl uses to represent
* file paths internally.
*/
static Tcl_ObjType tclFsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
UpdateStringOfFsPath, /* updateStringProc */
SetFsPathFromAny /* setFromAnyProc */
};
/*
* struct FsPath --
*
* Internal representation of a Tcl_Obj of "path" type. This
* can be used to represent relative or absolute paths, and has
* certain optimisations when used to represent paths which are
* already normalized and absolute.
*
* Note that 'normPathPtr' can be a circular reference to the
* container Tcl_Obj of this FsPath.
*/
typedef struct FsPath {
Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences.
* If this is NULL, then this is a
* pure normalized, absolute path
* object, in which the parent Tcl_Obj's
* string rep is already both translated
* and normalized. */
Tcl_Obj *normPathPtr; /* Normalized absolute path, without
* ., .. or ~user sequences. If the
* Tcl_Obj containing
* this FsPath is already normalized,
* this may be a circular reference back
* to the container. If that is NOT the
* case, we have a refCount on the object. */
Tcl_Obj *cwdPtr; /* If null, path is absolute, else
* this points to the cwd object used
* for this path. We have a refCount
* on the object. */
int flags; /* Flags to describe interpretation */
ClientData nativePathPtr; /* Native representation of this path,
* which is filesystem dependent. */
int filesystemEpoch; /* Used to ensure the path representation
* was generated during the correct
* filesystem epoch. The epoch changes
* when filesystem-mounts are changed. */
struct FilesystemRecord *fsRecPtr;
/* Pointer to the filesystem record
* entry to use for this path. */
} FsPath;
/*
* Define some macros to give us convenient access to path-object
* specific fields.
*/
#define PATHOBJ(objPtr) (objPtr->internalRep.otherValuePtr)
#define PATHFLAGS(objPtr) \
(((FsPath*)(objPtr->internalRep.otherValuePtr))->flags)
#define TCLPATH_APPENDED 1
#define TCLPATH_RELATIVE 2
#define TCLPATH_NEEDNORM 4
/*
*----------------------------------------------------------------------
*
* Tcl_FSGetPathType --
*
* Determines whether a given path is relative to the current
* directory, relative to the current volume, or absolute.
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
* TCL_PATH_VOLUME_RELATIVE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_PathType
Tcl_FSGetPathType(pathObjPtr)
Tcl_Obj *pathObjPtr;
{
return FSGetPathType(pathObjPtr, NULL, NULL);
}
/*
*----------------------------------------------------------------------
*
* FSGetPathType --
*
* Determines whether a given path is relative to the current
* directory, relative to the current volume, or absolute. If the
* caller wishes to know which filesystem claimed the path (in the
* case for which the path is absolute), then a reference to a
* filesystem pointer can be passed in (but passing NULL is
* acceptable).
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
* TCL_PATH_VOLUME_RELATIVE. The filesystem reference will
* be set if and only if it is non-NULL and the function's
* return value is TCL_PATH_ABSOLUTE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_PathType
FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
Tcl_Obj *pathObjPtr;
Tcl_Filesystem **filesystemPtrPtr;
int *driveNameLengthPtr;
{
if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
return GetPathType(pathObjPtr, filesystemPtrPtr,
driveNameLengthPtr, NULL);
} else {
FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (fsPathPtr->cwdPtr != NULL) {
if (PATHFLAGS(pathObjPtr) == 0) {
/* The path is not absolute... */
#ifdef __WIN32__
/* ... on Windows we must make another call to determine
* whether it's relative or volumerelative [Bug 2571597]. */
return GetPathType(pathObjPtr, filesystemPtrPtr,
driveNameLengthPtr, NULL);
#else
/* On other systems, quickly deduce !absolute -> relative */
return TCL_PATH_RELATIVE;
#endif
}
return FSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr,
driveNameLengthPtr);
} else {
return GetPathType(pathObjPtr, filesystemPtrPtr,
driveNameLengthPtr, NULL);
}
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSJoinPath --
*
* This function takes the given Tcl_Obj, which should be a valid
* list, and returns the path object given by considering the
* first 'elements' elements as valid path segments. If elements < 0,
* we use the entire list.
*
* Results:
* Returns object with refCount of zero, (or if non-zero, it has
* references elsewhere in Tcl). Either way, the caller must
* increment its refCount before use.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSJoinPath(listObj, elements)
Tcl_Obj *listObj;
int elements;
{
Tcl_Obj *res;
int i;
Tcl_Filesystem *fsPtr = NULL;
if (elements < 0) {
if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
return NULL;
}
} else {
/* Just make sure it is a valid list */
int listTest;
if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) {
return NULL;
}
/*
* Correct this if it is too large, otherwise we will
* waste our time joining null elements to the path
*/
if (elements > listTest) {
elements = listTest;
}
}
res = Tcl_NewObj();
for (i = 0; i < elements; i++) {
Tcl_Obj *elt;
int driveNameLength;
Tcl_PathType type;
char *strElt;
int strEltLen;
int length;
char *ptr;
Tcl_Obj *driveName = NULL;
Tcl_ListObjIndex(NULL, listObj, i, &elt);
/*
* This is a special case where we can be much more
* efficient, where we are joining a single relative path
* onto an object that is already of path type. The
* 'TclNewFSPathObj' call below creates an object which
* can be normalized more efficiently. Currently we only
* use the special case when we have exactly two elements,
* but we could expand that in the future.
*/
if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType)
&& !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) {
Tcl_Obj *tail;
Tcl_PathType type;
Tcl_ListObjIndex(NULL, listObj, i+1, &tail);
type = GetPathType(tail, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
CONST char *str;
int len;
str = Tcl_GetStringFromObj(tail,&len);
if (len == 0) {
/*
* This happens if we try to handle the root volume
* '/'. There's no need to return a special path
* object, when the base itself is just fine!
*/
Tcl_DecrRefCount(res);
return elt;
}
/*
* If it doesn't begin with '.' and is a mac or unix
* path or it a windows path without backslashes, then we
* can be very efficient here. (In fact even a windows
* path with backslashes can be joined efficiently, but
* the path object would not have forward slashes only,
* and this would therefore contradict our 'file join'
* documentation).
*/
if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS)
|| (strchr(str, '\\') == NULL))) {
/*
* Finally, on Windows, 'file join' is defined to
* convert all backslashes to forward slashes,
* so the base part cannot have backslashes either.
*/
if ((tclPlatform != TCL_PLATFORM_WINDOWS)
|| (strchr(Tcl_GetString(elt), '\\') == NULL)) {
if (res != NULL) {
TclDecrRefCount(res);
}
return TclNewFSPathObj(elt, str, len);
}
}
/*
* Otherwise we don't have an easy join, and
* we must let the more general code below handle
* things
*/
} else {
if (tclPlatform == TCL_PLATFORM_UNIX) {
Tcl_DecrRefCount(res);
return tail;
} else {
CONST char *str;
int len;
str = Tcl_GetStringFromObj(tail,&len);
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
if (strchr(str, '\\') == NULL) {
Tcl_DecrRefCount(res);
return tail;
}
}
}
}
}
strElt = Tcl_GetStringFromObj(elt, &strEltLen);
type = GetPathType(elt, &fsPtr, &driveNameLength, &driveName);
if (type != TCL_PATH_RELATIVE) {
/* Zero out the current result */
Tcl_DecrRefCount(res);
if (driveName != NULL) {
res = Tcl_DuplicateObj(driveName);
Tcl_DecrRefCount(driveName);
} else {
res = Tcl_NewStringObj(strElt, driveNameLength);
}
strElt += driveNameLength;
}
ptr = Tcl_GetStringFromObj(res, &length);
/*
* Strip off any './' before a tilde, unless this is the
* beginning of the path.
*/
if (length > 0 && strEltLen > 0) {
if ((strElt[0] == '.') && (strElt[1] == '/')
&& (strElt[2] == '~')) {
strElt += 2;
}
}
/*
* A NULL value for fsPtr at this stage basically means
* we're trying to join a relative path onto something
* which is also relative (or empty). There's nothing
* particularly wrong with that.
*/
if (*strElt == '\0') continue;
if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
TclpNativeJoinPath(res, strElt);
} else {
char separator = '/';
int needsSep = 0;
if (fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);
if (sep != NULL) {
separator = Tcl_GetString(sep)[0];
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
Tcl_GetStringFromObj(res, &length);
}
Tcl_SetObjLength(res, length + (int) strlen(strElt));
ptr = Tcl_GetString(res) + length;
for (; *strElt != '\0'; strElt++) {
if (*strElt == separator) {
while (strElt[1] == separator) {
strElt++;
}
if (strElt[1] != '\0') {
if (needsSep) {
*ptr++ = separator;
}
}
} else {
*ptr++ = *strElt;
needsSep = 1;
}
}
length = ptr - Tcl_GetString(res);
Tcl_SetObjLength(res, length);
}
}
return res;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSConvertToPathType --
*
* This function tries to convert the given Tcl_Obj to a valid
* Tcl path type, taking account of the fact that the cwd may
* have changed even if this object is already supposedly of
* the correct type.
*
* The filename may begin with "~" (to indicate current user's
* home directory) or "~" (to indicate any user's home
* directory).
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSConvertToPathType(interp, objPtr)
Tcl_Interp *interp; /* Interpreter in which to store error
* message (if necessary). */
Tcl_Obj *objPtr; /* Object to convert to a valid, current
* path type. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* While it is bad practice to examine an object's type directly,
* this is actually the best thing to do here. The reason is that
* if we are converting this object to FsPath type for the first
* time, we don't need to worry whether the 'cwd' has changed.
* On the other hand, if this object is already of FsPath type,
* and is a relative path, we do have to worry about the cwd.
* If the cwd has changed, we must recompute the path.
*/
if (objPtr->typePtr == &tclFsPathType) {
FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
if (fsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) {
if (objPtr->bytes == NULL) {
UpdateStringOfFsPath(objPtr);
}
FreeFsPathInternalRep(objPtr);
objPtr->typePtr = NULL;
return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
}
return TCL_OK;
} else {
return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
}
}
/*
* Helper function for SetFsPathFromAny. Returns position of first
* directory delimiter in the path.
*/
static int
FindSplitPos(path, separator)
char *path;
char *separator;
{
int count = 0;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
while (path[count] != 0) {
if (path[count] == *separator) {
return count;
}
count++;
}
break;
case TCL_PLATFORM_WINDOWS:
while (path[count] != 0) {
if (path[count] == *separator || path[count] == '\\') {
return count;
}
count++;
}
break;
}
return count;
}
/*
*---------------------------------------------------------------------------
*
* TclNewFSPathObj --
*
* Creates a path object whose string representation is
* '[file join dirPtr addStrRep]', but does so in a way that
* allows for more efficient caching of normalized paths.
*
* Assumptions:
* 'dirPtr' must be an absolute path.
* 'len' may not be zero.
*
* Results:
* The new Tcl object, with refCount zero.
*
* Side effects:
* Memory is allocated. 'dirPtr' gets an additional refCount.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
{
FsPath *fsPathPtr;
Tcl_Obj *objPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
CONST char *p;
int state = 0, count = 0;
objPtr = Tcl_NewObj();
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
/* Setup the path */
fsPathPtr->translatedPathPtr = NULL;
fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->cwdPtr = dirPtr;
Tcl_IncrRefCount(dirPtr);
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = TCLPATH_RELATIVE | TCLPATH_APPENDED;
objPtr->typePtr = &tclFsPathType;
objPtr->bytes = NULL;
objPtr->length = 0;
/*
* Look for path components made up of only "."
* This is overly conservative analysis to keep simple. It may
* mark some things as needing more aggressive normalization
* that don't actually need it. No harm done.
*/
for (p = addStrRep; len > 0; p++, len--) {
switch (state) {
case 0: /* So far only "." since last dirsep or start */
switch (*p) {
case '.':
count++;
break;
case '/':
case '\\':
case ':':
if (count) {
PATHFLAGS(objPtr) |= TCLPATH_NEEDNORM;
len = 0;
}
break;
default:
count = 0;
state = 1;
}
case 1: /* Scanning for next dirsep */
switch (*p) {
case '/':
case '\\':
case ':':
state = 0;
break;
}
}
}
if (len == 0 && count) {
PATHFLAGS(objPtr) |= TCLPATH_NEEDNORM;
}
return objPtr;
}
/*
*---------------------------------------------------------------------------
*
* TclFSMakePathRelative --
*
* Only for internal use.
*
* Takes a path and a directory, where we _assume_ both path and
* directory are absolute, normalized and that the path lies
* inside the directory. Returns a Tcl_Obj representing filename
* of the path relative to the directory.
*
* In the case where the resulting path would start with a '~', we
* take special care to return an ordinary string. This means to
* use that path (and not have it interpreted as a user name),
* one must prepend './'. This may seem strange, but that is how
* 'glob' is currently defined.
*
* Results:
* NULL on error, otherwise a valid object, typically with
* refCount of zero, which it is assumed the caller will
* increment.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclFSMakePathRelative(interp, objPtr, cwdPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object we have. */
Tcl_Obj *cwdPtr; /* Make it relative to this. */
{
int cwdLen, len;
CONST char *tempStr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (objPtr->typePtr == &tclFsPathType) {
FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
if (PATHFLAGS(objPtr) != 0
&& fsPathPtr->cwdPtr == cwdPtr) {
objPtr = fsPathPtr->normPathPtr;
/* Free old representation */
if (objPtr->typePtr != NULL) {
if (objPtr->bytes == NULL) {
if (objPtr->typePtr->updateStringProc == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't find object",
"string representation", (char *) NULL);
}
return NULL;
}
objPtr->typePtr->updateStringProc(objPtr);
}
if ((objPtr->typePtr->freeIntRepProc) != NULL) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
}
/* Now objPtr is a string object */
if (Tcl_GetString(objPtr)[0] == '~') {
/*
* If the first character of the path is a tilde,
* we must just return the path as is, to agree
* with the defined behaviour of 'glob'.
*/
return objPtr;
}
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
/* Circular reference, by design */
fsPathPtr->translatedPathPtr = objPtr;
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = cwdPtr;
Tcl_IncrRefCount(cwdPtr);
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return objPtr;
}
}
/*
* We know the cwd is a normalised object which does
* not end in a directory delimiter, unless the cwd
* is the name of a volume, in which case it will
* end in a delimiter! We handle this situation here.
* A better test than the '!= sep' might be to simply
* check if 'cwd' is a root volume.
*
* Note that if we get this wrong, we will strip off
* either too much or too little below, leading to
* wrong answers returned by glob.
*/
tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root
* volume.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (tempStr[cwdLen-1] != '/') {
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
if (tempStr[cwdLen-1] != '/'
&& tempStr[cwdLen-1] != '\\') {
cwdLen++;
}
break;
}
tempStr = Tcl_GetStringFromObj(objPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
/*
*---------------------------------------------------------------------------
*
* TclFSMakePathFromNormalized --
*
* Like SetFsPathFromAny, but assumes the given object is an
* absolute normalized path. Only for internal use.
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
int
TclFSMakePathFromNormalized(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object to convert. */
{
FsPath *fsPathPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (objPtr->typePtr == &tclFsPathType) {
return TCL_OK;
}
/* Free old representation */
if (objPtr->typePtr != NULL) {
if (objPtr->bytes == NULL) {
if (objPtr->typePtr->updateStringProc == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't find object",
"string representation", (char *) NULL);
}
return TCL_ERROR;
}
objPtr->typePtr->updateStringProc(objPtr);
}
if ((objPtr->typePtr->freeIntRepProc) != NULL) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
}
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
/* It's a pure normalized absolute path */
fsPathPtr->translatedPathPtr = NULL;
fsPathPtr->normPathPtr = objPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSNewNativePath --
*
* This function performs the something like that reverse of the
* usual obj->path->nativerep conversions. If some code retrieves
* a path in native form (from, e.g. readlink or a native dialog),
* and that path is to be used at the Tcl level, then calling
* this function is an efficient way of creating the appropriate
* path object type.
*
* Any memory which is allocated for 'clientData' should be retained
* until clientData is passed to the filesystem's freeInternalRepProc
* when it can be freed. The built in platform-specific filesystems
* use 'ckalloc' to allocate clientData, and ckfree to free it.
*
* Results:
* NULL or a valid path object pointer, with refCount zero.
*
* Side effects:
* New memory may be allocated.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSNewNativePath(fromFilesystem, clientData)
Tcl_Filesystem* fromFilesystem;
ClientData clientData;
{
Tcl_Obj *objPtr;
FsPath *fsPathPtr;
FilesystemRecord *fsFromPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
objPtr = TclFSInternalToNormalized(fromFilesystem, clientData, &fsFromPtr);
if (objPtr == NULL) {
return NULL;
}
/*
* Free old representation; shouldn't normally be any,
* but best to be safe.
*/
if (objPtr->typePtr != NULL) {
if (objPtr->bytes == NULL) {
if (objPtr->typePtr->updateStringProc == NULL) {
return NULL;
}
objPtr->typePtr->updateStringProc(objPtr);
}
if ((objPtr->typePtr->freeIntRepProc) != NULL) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
}
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
fsPathPtr->translatedPathPtr = NULL;
/* Circular reference, by design */
fsPathPtr->normPathPtr = objPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsRecPtr = fsFromPtr;
fsPathPtr->fsRecPtr->fileRefCount++;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return objPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetTranslatedPath --
*
* This function attempts to extract the translated path
* from the given Tcl_Obj. If the translation succeeds (i.e. the
* object is a valid path), then it is returned. Otherwise NULL
* will be returned, and an error message may be left in the
* interpreter (if it is non-NULL)
*
* Results:
* NULL or a valid Tcl_Obj pointer.
*
* Side effects:
* Only those of 'Tcl_FSConvertToPathType'
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSGetTranslatedPath(interp, pathPtr)
Tcl_Interp *interp;
Tcl_Obj* pathPtr;
{
Tcl_Obj *retObj = NULL;
FsPath *srcFsPathPtr;
if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
return NULL;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
if (srcFsPathPtr->translatedPathPtr == NULL) {
if (PATHFLAGS(pathPtr) != 0) {
/*
* We lack a translated path result, but we have a directory
* (cwdPtr) and a tail (normPathPtr), and if we join the
* translated version of cwdPtr to normPathPtr, we'll get the
* translated result we need, and can store it for future use.
*/
Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp,
srcFsPathPtr->cwdPtr);
retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1,
&(srcFsPathPtr->normPathPtr));
srcFsPathPtr->translatedPathPtr = retObj;
Tcl_IncrRefCount(retObj);
Tcl_DecrRefCount(translatedCwdPtr);
} else {
/*
* It is a pure absolute, normalized path object.
* This is something like being a 'pure list'. The
* object's string, translatedPath and normalizedPath
* are all identical.
*/
retObj = srcFsPathPtr->normPathPtr;
}
} else {
/* It is an ordinary path object */
retObj = srcFsPathPtr->translatedPathPtr;
}
if (retObj) {
Tcl_IncrRefCount(retObj);
}
return retObj;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetTranslatedStringPath --
*
* This function attempts to extract the translated path
* from the given Tcl_Obj. If the translation succeeds (i.e. the
* object is a valid path), then the path is returned. Otherwise NULL
* will be returned, and an error message may be left in the
* interpreter (if it is non-NULL)
*
* Results:
* NULL or a valid string.
*
* Side effects:
* Only those of 'Tcl_FSConvertToPathType'
*
*---------------------------------------------------------------------------
*/
CONST char*
Tcl_FSGetTranslatedStringPath(interp, pathPtr)
Tcl_Interp *interp;
Tcl_Obj* pathPtr;
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
int len;
CONST char *result, *orig;
orig = Tcl_GetStringFromObj(transPtr, &len);
result = (char*) ckalloc((unsigned)(len+1));
memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1));
Tcl_DecrRefCount(transPtr);
return result;
}
return NULL;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetNormalizedPath --
*
* This important function attempts to extract from the given Tcl_Obj
* a unique normalised path representation, whose string value can
* be used as a unique identifier for the file.
*
* Results:
* NULL or a valid path object pointer.
*
* Side effects:
* New memory may be allocated. The Tcl 'errno' may be modified
* in the process of trying to examine various path possibilities.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSGetNormalizedPath(interp, pathObjPtr)
Tcl_Interp *interp;
Tcl_Obj* pathObjPtr;
{
FsPath *fsPathPtr;
if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) {
return NULL;
}
fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (PATHFLAGS(pathObjPtr) != 0) {
/*
* This is a special path object which is the result of
* something like 'file join'
*/
Tcl_Obj *dir, *copy;
int cwdLen;
int pathType;
CONST char *cwdStr;
pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
if (dir == NULL) {
return NULL;
}
if (pathObjPtr->bytes == NULL) {
UpdateStringOfFsPath(pathObjPtr);
}
copy = Tcl_DuplicateObj(dir);
Tcl_IncrRefCount(copy);
Tcl_IncrRefCount(dir);
/* We now own a reference on both 'dir' and 'copy' */
cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root volume.
* We should never get cwdLen == 0 in this code path.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (cwdStr[cwdLen-1] != '/') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
if (cwdStr[cwdLen-1] != '/'
&& cwdStr[cwdLen-1] != '\\') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
}
Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
/* Normalize the combined string. */
if (PATHFLAGS(pathObjPtr) & TCLPATH_NEEDNORM) {
/*
* If the "tail" part has components (like /../) that cause
* the combined path to need more complete normalizing,
* call on the more powerful routine to accomplish that so
* we avoid [Bug 2385549] ...
*/
Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy);
Tcl_DecrRefCount(copy);
copy = newCopy;
} else {
/*
* ... but in most cases where we join a trouble free tail
* to a normalized head, we can more efficiently normalize the
* combined path by passing over only the unnormalized tail
* portion. When this is sufficient, prior developers claim
* this should be much faster. We use 'cwdLen-1' so that we are
* already pointing at the dir-separator that we know about.
* The normalization code will actually start off directly
* after that separator.
*/
TclFSNormalizeToUniquePath(interp, copy, cwdLen-1);
}
/* Now we need to construct the new path object */
if (pathType == TCL_PATH_RELATIVE) {
FsPath* origDirFsPathPtr;
Tcl_Obj *origDir = fsPathPtr->cwdPtr;
origDirFsPathPtr = (FsPath*) PATHOBJ(origDir);
fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
Tcl_IncrRefCount(fsPathPtr->cwdPtr);
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
/* That's our reference to copy used */
Tcl_DecrRefCount(dir);
Tcl_DecrRefCount(origDir);
} else {
Tcl_DecrRefCount(fsPathPtr->cwdPtr);
fsPathPtr->cwdPtr = NULL;
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
/* That's our reference to copy used */
Tcl_DecrRefCount(dir);
}
PATHFLAGS(pathObjPtr) = 0;
}
/* Ensure cwd hasn't changed */
if (fsPathPtr->cwdPtr != NULL) {
if (!TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) {
if (pathObjPtr->bytes == NULL) {
UpdateStringOfFsPath(pathObjPtr);
}
FreeFsPathInternalRep(pathObjPtr);
pathObjPtr->typePtr = NULL;
if (Tcl_ConvertToType(interp, pathObjPtr,
&tclFsPathType) != TCL_OK) {
return NULL;
}
fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
} else if (fsPathPtr->normPathPtr == NULL) {
int cwdLen;
Tcl_Obj *copy;
CONST char *cwdStr;
copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
Tcl_IncrRefCount(copy);
cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root volume.
* We should never get cwdLen == 0 in this code path.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (cwdStr[cwdLen-1] != '/') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
if (cwdStr[cwdLen-1] != '/'
&& cwdStr[cwdLen-1] != '\\') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
}
Tcl_AppendObjToObj(copy, pathObjPtr);
/*
* Normalize the combined string, but only starting after
* the end of the previously normalized 'dir'. This should
* be much faster!
*/
TclFSNormalizeToUniquePath(interp, copy, cwdLen-1);
fsPathPtr->normPathPtr = copy;
}
}
if (fsPathPtr->normPathPtr == NULL) {
Tcl_Obj *useThisCwd = NULL;
/*
* Since normPathPtr is NULL, but this is a valid path
* object, we know that the translatedPathPtr cannot be NULL.
*/
Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
char *path = Tcl_GetString(absolutePath);
/*
* We have to be a little bit careful here to avoid infinite loops
* we're asking Tcl_FSGetPathType to return the path's type, but
* that call can actually result in a lot of other filesystem
* action, which might loop back through here.
*/
if (path[0] != '\0') {
Tcl_PathType type = Tcl_FSGetPathType(pathObjPtr);
if (type == TCL_PATH_RELATIVE) {
useThisCwd = Tcl_FSGetCwd(interp);
if (useThisCwd == NULL) return NULL;
absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
Tcl_IncrRefCount(absolutePath);
/* We have a refCount on the cwd */
#ifdef __WIN32__
} else if (type == TCL_PATH_VOLUME_RELATIVE) {
/*
* Only Windows has volume-relative paths. These
* paths are rather rare, but is is nice if Tcl can
* handle them. It is much better if we can
* handle them here, rather than in the native fs code,
* because we really need to have a real absolute path
* just below.
*
* We do not let this block compile on non-Windows
* platforms because the test suite's manual forcing
* of tclPlatform can otherwise cause this code path
* to be executed, causing various errors because
* volume-relative paths really do not exist.
*/
useThisCwd = Tcl_FSGetCwd(interp);
if (useThisCwd == NULL) return NULL;
if (path[0] == '/') {
/*
* Path of form /foo/bar which is a path in the
* root directory of the current volume.
*/
CONST char *drive = Tcl_GetString(useThisCwd);
absolutePath = Tcl_NewStringObj(drive,2);
Tcl_AppendToObj(absolutePath, path, -1);
Tcl_IncrRefCount(absolutePath);
/* We have a refCount on the cwd */
} else {
/*
* Path of form C:foo/bar, but this only makes
* sense if the cwd is also on drive C.
*/
CONST char *drive = Tcl_GetString(useThisCwd);
char drive_c = path[0];
if (drive_c >= 'a') {
drive_c -= ('a' - 'A');
}
if (drive[0] == drive_c) {
absolutePath = Tcl_DuplicateObj(useThisCwd);
/* We have a refCount on the cwd */
} else {
Tcl_DecrRefCount(useThisCwd);
useThisCwd = NULL;
/*
* The path is not in the current drive, but
* is volume-relative. The way Tcl 8.3 handles
* this is that it treats such a path as
* relative to the root of the drive. We
* therefore behave the same here.
*/
absolutePath = Tcl_NewStringObj(path, 2);
}
Tcl_IncrRefCount(absolutePath);
Tcl_AppendToObj(absolutePath, "/", 1);
Tcl_AppendToObj(absolutePath, path+2, -1);
}
#endif /* __WIN32__ */
}
}
/* Already has refCount incremented */
fsPathPtr->normPathPtr
= TclFSNormalizeAbsolutePath(interp, absolutePath);
if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr),
Tcl_GetString(pathObjPtr))) {
/*
* The path was already normalized.
* Get rid of the duplicate.
*/
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
/*
* We do *not* increment the refCount for
* this circular reference
*/
fsPathPtr->normPathPtr = pathObjPtr;
}
if (useThisCwd != NULL) {
/* This was returned by Tcl_FSJoinToPath above */
Tcl_DecrRefCount(absolutePath);
fsPathPtr->cwdPtr = useThisCwd;
}
}
return fsPathPtr->normPathPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetInternalRep --
*
* Extract the internal representation of a given path object,
* in the given filesystem. If the path object belongs to a
* different filesystem, we return NULL.
*
* If the internal representation is currently NULL, we attempt
* to generate it, by calling the filesystem's
* 'Tcl_FSCreateInternalRepProc'.
*
* Results:
* NULL or a valid internal representation.
*
* Side effects:
* An attempt may be made to convert the object.
*
*---------------------------------------------------------------------------
*/
ClientData
Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
Tcl_Obj* pathObjPtr;
Tcl_Filesystem *fsPtr;
{
FsPath *srcFsPathPtr;
if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
return NULL;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
/*
* We will only return the native representation for the caller's
* filesystem. Otherwise we will simply return NULL. This means
* that there must be a unique bi-directional mapping between paths
* and filesystems, and that this mapping will not allow 'remapped'
* files -- files which are in one filesystem but mapped into
* another. Another way of putting this is that 'stacked'
* filesystems are not allowed. We recognise that this is a
* potentially useful feature for the future.
*
* Even something simple like a 'pass through' filesystem which
* logs all activity and passes the calls onto the native system
* would be nice, but not easily achievable with the current
* implementation.
*/
if (srcFsPathPtr->fsRecPtr == NULL) {
/*
* This only usually happens in wrappers like TclpStat which
* create a string object and pass it to TclpObjStat. Code
* which calls the Tcl_FS.. functions should always have a
* filesystem already set. Whether this code path is legal or
* not depends on whether we decide to allow external code to
* call the native filesystem directly. It is at least safer
* to allow this sub-optimal routing.
*/
Tcl_FSGetFileSystemForPath(pathObjPtr);
/*
* If we fail through here, then the path is probably not a
* valid path in the filesystsem, and is most likely to be a
* use of the empty path "" via a direct call to one of the
* objectified interfaces (e.g. from the Tcl testsuite).
*/
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (srcFsPathPtr->fsRecPtr == NULL) {
return NULL;
}
}
if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) {
/*
* There is still one possibility we should consider; if the
* file belongs to a different filesystem, perhaps it is
* actually linked through to a file in our own filesystem
* which we do care about. The way we can check for this
* is we ask what filesystem this path belongs to.
*/
Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr);
if (actualFs == fsPtr) {
return Tcl_FSGetInternalRep(pathObjPtr, fsPtr);
}
return NULL;
}
if (srcFsPathPtr->nativePathPtr == NULL) {
Tcl_FSCreateInternalRepProc *proc;
char *nativePathPtr;
proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc;
if (proc == NULL) {
return NULL;
}
nativePathPtr = (*proc)(pathObjPtr);
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
srcFsPathPtr->nativePathPtr = nativePathPtr;
}
return srcFsPathPtr->nativePathPtr;
}
/*
*---------------------------------------------------------------------------
*
* TclFSEnsureEpochOk --
*
* This will ensure the pathObjPtr is up to date and can be
* converted into a "path" type, and that we are able to generate a
* complete normalized path which is used to determine the
* filesystem match.
*
* Results:
* Standard Tcl return code.
*
* Side effects:
* An attempt may be made to convert the object.
*
*---------------------------------------------------------------------------
*/
int
TclFSEnsureEpochOk(pathObjPtr, fsPtrPtr)
Tcl_Obj* pathObjPtr;
Tcl_Filesystem **fsPtrPtr;
{
FsPath *srcFsPathPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* SHOULD BE ABLE TO IMPROVE EFFICIENCY HERE.
*/
if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) {
return TCL_ERROR;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
/*
* Check if the filesystem has changed in some way since
* this object's internal representation was calculated.
*/
if (srcFsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) {
/*
* We have to discard the stale representation and
* recalculate it
*/
if (pathObjPtr->bytes == NULL) {
UpdateStringOfFsPath(pathObjPtr);
}
FreeFsPathInternalRep(pathObjPtr);
pathObjPtr->typePtr = NULL;
if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) {
return TCL_ERROR;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
}
/* Check whether the object is already assigned to a fs */
if (srcFsPathPtr->fsRecPtr != NULL) {
*fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr;
}
return TCL_OK;
}
void
TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData)
Tcl_Obj *pathObjPtr;
FilesystemRecord *fsRecPtr;
ClientData clientData;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/* We assume pathObjPtr is already of the correct type */
FsPath *srcFsPathPtr;
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
srcFsPathPtr->fsRecPtr = fsRecPtr;
srcFsPathPtr->nativePathPtr = clientData;
srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
fsRecPtr->fileRefCount++;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSEqualPaths --
*
* This function tests whether the two paths given are equal path
* objects. If either or both is NULL, 0 is always returned.
*
* Results:
* 1 or 0.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSEqualPaths(firstPtr, secondPtr)
Tcl_Obj* firstPtr;
Tcl_Obj* secondPtr;
{
if (firstPtr == secondPtr) {
return 1;
} else {
char *firstStr, *secondStr;
int firstLen, secondLen, tempErrno;
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) {
return 1;
}
/*
* Try the most thorough, correct method of comparing fully
* normalized paths
*/
tempErrno = Tcl_GetErrno();
firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
Tcl_SetErrno(tempErrno);
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) {
return 1;
}
}
return 0;
}
/*
*---------------------------------------------------------------------------
*
* SetFsPathFromAny --
*
* This function tries to convert the given Tcl_Obj to a valid
* Tcl path type.
*
* The filename may begin with "~" (to indicate current user's
* home directory) or "~" (to indicate any user's home
* directory).
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
static int
SetFsPathFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object to convert. */
{
int len;
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
char *name;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (objPtr->typePtr == &tclFsPathType) {
return TCL_OK;
}
/*
* First step is to translate the filename. This is similar to
* Tcl_TranslateFilename, but shouldn't convert everything to
* windows backslashes on that platform. The current
* implementation of this piece is a slightly optimised version
* of the various Tilde/Split/Join stuff to avoid multiple
* split/join operations.
*
* We remove any trailing directory separator.
*
* However, the split/join routines are quite complex, and
* one has to make sure not to break anything on Unix, Win
* or MacOS (fCmd.test, fileName.test and cmdAH.test exercise
* most of the code).
*/
name = Tcl_GetStringFromObj(objPtr,&len);
/*
* Handle tilde substitutions, if needed.
*/
if (name[0] == '~') {
char *expandedUser;
Tcl_DString temp;
int split;
char separator='/';
split = FindSplitPos(name, &separator);
if (split != len) {
/* We have multiple pieces '~user/foo/bar...' */
name[split] = '\0';
}
/* Do some tilde substitution */
if (name[1] == '\0') {
/* We have just '~' */
CONST char *dir;
Tcl_DString dirString;
if (split != len) { name[split] = separator; }
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't find HOME environment ",
"variable to expand path", (char *) NULL);
}
return TCL_ERROR;
}
Tcl_DStringInit(&temp);
Tcl_JoinPath(1, &dir, &temp);
Tcl_DStringFree(&dirString);
} else {
/* We have a user name '~user' */
Tcl_DStringInit(&temp);
if (TclpGetUserHome(name+1, &temp) == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "user \"", (name+1),
"\" doesn't exist", (char *) NULL);
}
Tcl_DStringFree(&temp);
if (split != len) { name[split] = separator; }
return TCL_ERROR;
}
if (split != len) { name[split] = separator; }
}
expandedUser = Tcl_DStringValue(&temp);
transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));
if (split != len) {
/* Join up the tilde substitution with the rest */
if (name[split+1] == separator) {
/*
* Somewhat tricky case like ~//foo/bar.
* Make use of Split/Join machinery to get it right.
* Assumes all paths beginning with ~ are part of the
* native filesystem.
*/
int objc;
Tcl_Obj **objv;
Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL);
Tcl_ListObjGetElements(NULL, parts, &objc, &objv);
/* Skip '~'. It's replaced by its expansion */
objc--; objv++;
while (objc--) {
TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++));
}
Tcl_DecrRefCount(parts);
} else {
/* Simple case. "rest" is relative path. Just join it. */
Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1);
transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest);
}
}
Tcl_DStringFree(&temp);
} else {
transPtr = Tcl_FSJoinToPath(objPtr,0,NULL);
}
/*
* Now we have a translated filename in 'transPtr'. This will have
* forward slashes on Windows, and will not contain any ~user
* sequences.
*/
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
fsPathPtr->translatedPathPtr = transPtr;
Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
/*
* Free old representation before installing our new one.
*/
if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
(objPtr->typePtr->freeIntRepProc)(objPtr);
}
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
static void
FreeFsPathInternalRep(pathObjPtr)
Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */
{
FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (fsPathPtr->translatedPathPtr != NULL) {
if (fsPathPtr->translatedPathPtr != pathObjPtr) {
Tcl_DecrRefCount(fsPathPtr->translatedPathPtr);
}
}
if (fsPathPtr->normPathPtr != NULL) {
if (fsPathPtr->normPathPtr != pathObjPtr) {
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
}
fsPathPtr->normPathPtr = NULL;
}
if (fsPathPtr->cwdPtr != NULL) {
Tcl_DecrRefCount(fsPathPtr->cwdPtr);
}
if (fsPathPtr->nativePathPtr != NULL) {
if (fsPathPtr->fsRecPtr != NULL) {
if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) {
(*fsPathPtr->fsRecPtr->fsPtr
->freeInternalRepProc)(fsPathPtr->nativePathPtr);
fsPathPtr->nativePathPtr = NULL;
}
}
}
if (fsPathPtr->fsRecPtr != NULL) {
fsPathPtr->fsRecPtr->fileRefCount--;
if (fsPathPtr->fsRecPtr->fileRefCount <= 0) {
/* It has been unregistered already, so simply free it */
ckfree((char *)fsPathPtr->fsRecPtr);
}
}
ckfree((char*) fsPathPtr);
}
static void
DupFsPathInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */
Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */
{
FsPath *srcFsPathPtr = (FsPath*) PATHOBJ(srcPtr);
FsPath *copyFsPathPtr = (FsPath*) ckalloc((unsigned)sizeof(FsPath));
Tcl_FSDupInternalRepProc *dupProc;
PATHOBJ(copyPtr) = (VOID *) copyFsPathPtr;
if (srcFsPathPtr->translatedPathPtr != NULL) {
copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
if (copyFsPathPtr->translatedPathPtr != copyPtr) {
Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
}
} else {
copyFsPathPtr->translatedPathPtr = NULL;
}
if (srcFsPathPtr->normPathPtr != NULL) {
copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
if (copyFsPathPtr->normPathPtr != copyPtr) {
Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
}
} else {
copyFsPathPtr->normPathPtr = NULL;
}
if (srcFsPathPtr->cwdPtr != NULL) {
copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
Tcl_IncrRefCount(copyFsPathPtr->cwdPtr);
} else {
copyFsPathPtr->cwdPtr = NULL;
}
copyFsPathPtr->flags = srcFsPathPtr->flags;
if (srcFsPathPtr->fsRecPtr != NULL
&& srcFsPathPtr->nativePathPtr != NULL) {
dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc;
if (dupProc != NULL) {
copyFsPathPtr->nativePathPtr =
(*dupProc)(srcFsPathPtr->nativePathPtr);
} else {
copyFsPathPtr->nativePathPtr = NULL;
}
} else {
copyFsPathPtr->nativePathPtr = NULL;
}
copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
if (copyFsPathPtr->fsRecPtr != NULL) {
copyFsPathPtr->fsRecPtr->fileRefCount++;
}
copyPtr->typePtr = &tclFsPathType;
}
/*
*---------------------------------------------------------------------------
*
* UpdateStringOfFsPath --
*
* Gives an object a valid string rep.
*
* Results:
* None.
*
* Side effects:
* Memory may be allocated.
*
*---------------------------------------------------------------------------
*/
static void
UpdateStringOfFsPath(objPtr)
register Tcl_Obj *objPtr; /* path obj with string rep to update. */
{
FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
CONST char *cwdStr;
int cwdLen;
Tcl_Obj *copy;
if (PATHFLAGS(objPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
panic("Called UpdateStringOfFsPath with invalid object");
}
copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
Tcl_IncrRefCount(copy);
cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root volume.
* We should never get cwdLen == 0 in this code path.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (cwdStr[cwdLen-1] != '/') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
/*
* We need the extra 'cwdLen != 2', and ':' checks because
* a volume relative path doesn't get a '/'. For example
* 'glob C:*cat*.exe' will return 'C:cat32.exe'
*/
if (cwdStr[cwdLen-1] != '/'
&& cwdStr[cwdLen-1] != '\\') {
if (cwdLen != 2 || cwdStr[1] != ':') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
}
break;
}
Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
objPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
objPtr->length = cwdLen;
copy->bytes = tclEmptyStringRep;
copy->length = 0;
Tcl_DecrRefCount(copy);
}
/*
*---------------------------------------------------------------------------
*
* NativePathInFilesystem --
*
* Any path object is acceptable to the native filesystem, by
* default (we will throw errors when illegal paths are actually
* tried to be used).
*
* However, this behavior means the native filesystem must be
* the last filesystem in the lookup list (otherwise it will
* claim all files belong to it, and other filesystems will
* never get a look in).
*
* Results:
* TCL_OK, to indicate 'yes', -1 to indicate no.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static int
NativePathInFilesystem(pathPtr, clientDataPtr)
Tcl_Obj *pathPtr;
ClientData *clientDataPtr;
{
/*
* A special case is required to handle the empty path "".
* This is a valid path (i.e. the user should be able
* to do 'file exists ""' without throwing an error), but
* equally the path doesn't exist. Those are the semantics
* of Tcl (at present anyway), so we have to abide by them
* here.
*/
if (pathPtr->typePtr == &tclFsPathType) {
if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {
/* We reject the empty path "" */
return -1;
}
/* Otherwise there is no way this path can be empty */
} else {
/*
* It is somewhat unusual to reach this code path without
* the object being of tclFsPathType. However, we do
* our best to deal with the situation.
*/
int len;
Tcl_GetStringFromObj(pathPtr,&len);
if (len == 0) {
/* We reject the empty path "" */
return -1;
}
}
/*
* Path is of correct type, or is of non-zero length,
* so we accept it.
*/
return TCL_OK;
}
tcl8.4.20/generic/tclBasic.c 0000644 0036047 0045461 00000615650 12151137515 014227 0 ustar dgp 771div /*
* tclBasic.c --
*
* Contains the basic facilities for TCL command interpretation,
* including interpreter creation and deletion, command creation
* and deletion, and command/script execution.
*
* Copyright (c) 1987-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2007 Daniel A. Steffen
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#if defined(_WIN32) && !defined(_WIN64)
# define _USE_32BIT_TIME_T
# include
#endif
#include "tclInt.h"
#include "tclCompile.h"
#ifndef TCL_GENERIC_ONLY
# include "tclPort.h"
#endif
/*
* Static procedures in this file:
*/
static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr,
Command *cmdPtr, CONST char *oldName,
CONST char* newName, int flags));
static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
static void ProcessUnexpectedResult _ANSI_ARGS_((
Tcl_Interp *interp, int returnCode));
static int StringTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp* interp,
int level,
CONST char* command,
Tcl_Command commandInfo,
int objc,
Tcl_Obj *CONST objv[]));
static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData));
#ifdef TCL_TIP280
/* TIP #280 - Modified token based evaluation, with line information */
static int EvalEx _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script,
int numBytes, int flags, int line,
int* clNextOuter, CONST char* outerScript));
static int EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *tokenPtr,
int count, int line,
int* clNextOuter, CONST char* outerScript));
#endif
#ifdef USE_DTRACE
static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]);
#endif
extern TclStubs tclStubs;
/*
* The following structure defines the commands in the Tcl core.
*/
typedef struct {
CONST char *name; /* Name of object-based command. */
Tcl_CmdProc *proc; /* String-based procedure for command. */
Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */
CompileProc *compileProc; /* Procedure called to compile command. */
int isSafe; /* If non-zero, command will be present
* in safe interpreter. Otherwise it will
* be hidden. */
} CmdInfo;
/*
* The built-in commands, and the procedures that implement them:
*/
static CONST CmdInfo builtInCmds[] = {
/*
* Commands in the generic core. Note that at least one of the proc or
* objProc members should be non-NULL. This avoids infinitely recursive
* calls between TclInvokeObjectCommand and TclInvokeStringCommand if a
* command name is computed at runtime and results in the name of a
* compiled command.
*/
{"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd,
TclCompileAppendCmd, 1},
{"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd,
(CompileProc *) NULL, 1},
{"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd,
(CompileProc *) NULL, 1},
{"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd,
TclCompileBreakCmd, 1},
{"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd,
(CompileProc *) NULL, 1},
{"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd,
TclCompileCatchCmd, 1},
{"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd,
(CompileProc *) NULL, 1},
{"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd,
(CompileProc *) NULL, 1},
{"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd,
TclCompileContinueCmd, 1},
{"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd,
(CompileProc *) NULL, 0},
{"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd,
(CompileProc *) NULL, 1},
{"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd,
(CompileProc *) NULL, 1},
{"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd,
(CompileProc *) NULL, 0},
{"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd,
TclCompileExprCmd, 1},
{"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd,
(CompileProc *) NULL, 1},
{"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd,
(CompileProc *) NULL, 1},
{"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd,
TclCompileForCmd, 1},
{"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd,
TclCompileForeachCmd, 1},
{"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd,
(CompileProc *) NULL, 1},
{"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd,
(CompileProc *) NULL, 1},
{"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd,
TclCompileIfCmd, 1},
{"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd,
TclCompileIncrCmd, 1},
{"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd,
(CompileProc *) NULL, 1},
{"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd,
(CompileProc *) NULL, 1},
{"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd,
TclCompileLappendCmd, 1},
{"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd,
TclCompileLindexCmd, 1},
{"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd,
(CompileProc *) NULL, 1},
{"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd,
TclCompileListCmd, 1},
{"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd,
TclCompileLlengthCmd, 1},
{"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd,
(CompileProc *) NULL, 0},
{"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd,
(CompileProc *) NULL, 1},
{"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd,
(CompileProc *) NULL, 1},
{"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd,
(CompileProc *) NULL, 1},
{"lset", (Tcl_CmdProc *) NULL, Tcl_LsetObjCmd,
TclCompileLsetCmd, 1},
{"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd,
(CompileProc *) NULL, 1},
{"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd,
(CompileProc *) NULL, 1},
{"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd,
(CompileProc *) NULL, 1},
{"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd,
(CompileProc *) NULL, 1},
{"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd,
TclCompileRegexpCmd, 1},
{"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd,
(CompileProc *) NULL, 1},
{"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd,
(CompileProc *) NULL, 1},
{"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd,
TclCompileReturnCmd, 1},
{"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd,
(CompileProc *) NULL, 1},
{"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd,
TclCompileSetCmd, 1},
{"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd,
(CompileProc *) NULL, 1},
{"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
TclCompileStringCmd, 1},
{"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd,
(CompileProc *) NULL, 1},
{"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd,
(CompileProc *) NULL, 1},
{"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd,
(CompileProc *) NULL, 1},
{"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd,
(CompileProc *) NULL, 1},
{"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd,
(CompileProc *) NULL, 1},
{"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd,
(CompileProc *) NULL, 1},
{"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd,
(CompileProc *) NULL, 1},
{"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd,
TclCompileWhileCmd, 1},
/*
* Commands in the UNIX core:
*/
#ifndef TCL_GENERIC_ONLY
{"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd,
(CompileProc *) NULL, 1},
{"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd,
(CompileProc *) NULL, 0},
{"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd,
(CompileProc *) NULL, 1},
{"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd,
(CompileProc *) NULL, 1},
{"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd,
(CompileProc *) NULL, 1},
{"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd,
(CompileProc *) NULL, 0},
{"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd,
(CompileProc *) NULL, 0},
{"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd,
(CompileProc *) NULL, 1},
{"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd,
(CompileProc *) NULL, 1},
{"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd,
(CompileProc *) NULL, 0},
{"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd,
(CompileProc *) NULL, 0},
{"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd,
(CompileProc *) NULL, 1},
{"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd,
(CompileProc *) NULL, 1},
{"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd,
(CompileProc *) NULL, 0},
{"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd,
(CompileProc *) NULL, 1},
{"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd,
(CompileProc *) NULL, 1},
{"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd,
(CompileProc *) NULL, 0},
{"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd,
(CompileProc *) NULL, 1},
{"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd,
(CompileProc *) NULL, 1},
{"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd,
(CompileProc *) NULL, 1},
{"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd,
(CompileProc *) NULL, 1},
{"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd,
(CompileProc *) NULL, 0},
{"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd,
(CompileProc *) NULL, 0},
#endif /* TCL_GENERIC_ONLY */
{NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL,
(CompileProc *) NULL, 0}
};
/*
* The following structure holds the client data for string-based
* trace procs
*/
typedef struct StringTraceData {
ClientData clientData; /* Client data from Tcl_CreateTrace */
Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */
} StringTraceData;
/*
*----------------------------------------------------------------------
*
* Tcl_CreateInterp --
*
* Create a new TCL command interpreter.
*
* Results:
* The return value is a token for the interpreter, which may be
* used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
* Tcl_DeleteInterp.
*
* Side effects:
* The command interpreter is initialized with the built-in commands
* and with the variables documented in tclvars(n).
*
*----------------------------------------------------------------------
*/
Tcl_Interp *
Tcl_CreateInterp()
{
Interp *iPtr;
Tcl_Interp *interp;
Command *cmdPtr;
BuiltinFunc *builtinFuncPtr;
MathFunc *mathFuncPtr;
Tcl_HashEntry *hPtr;
CONST CmdInfo *cmdInfoPtr;
int i;
union {
char c[sizeof(short)];
short s;
} order;
#ifdef TCL_COMPILE_STATS
ByteCodeStats *statsPtr;
#endif /* TCL_COMPILE_STATS */
TclInitSubsystems(NULL);
/*
* Panic if someone updated the CallFrame structure without
* also updating the Tcl_CallFrame structure (or vice versa).
*/
if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) {
/*NOTREACHED*/
panic("Tcl_CallFrame must not be smaller than CallFrame");
}
#if defined(_WIN32) && !defined(_WIN64)
if (sizeof(time_t) != 4) {
/*NOTREACHED*/
Tcl_Panic("sys/time.h is not compatible with MSVC");
}
if (sizeof(Tcl_StatBuf) != 48) {
/*NOTREACHED*/
Tcl_Panic("sys/stat.h is not compatible with MSVC");
}
#endif
/*
* Initialize support for namespaces and create the global namespace
* (whose name is ""; an alias is "::"). This also initializes the
* Tcl object type table and other object management code.
*/
iPtr = (Interp *) ckalloc(sizeof(Interp));
interp = (Tcl_Interp *) iPtr;
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = NULL;
iPtr->errorLine = 0;
iPtr->objResultPtr = Tcl_NewObj();
Tcl_IncrRefCount(iPtr->objResultPtr);
iPtr->handle = TclHandleCreate(iPtr);
iPtr->globalNsPtr = NULL;
iPtr->hiddenCmdTablePtr = NULL;
iPtr->interpInfo = NULL;
Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
iPtr->numLevels = 0;
iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
iPtr->framePtr = NULL;
iPtr->varFramePtr = NULL;
#ifdef TCL_TIP280
/*
* TIP #280 - Initialize the arrays used to extend the ByteCode and
* Proc structures.
*/
iPtr->cmdFramePtr = NULL;
iPtr->linePBodyPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
iPtr->lineBCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
iPtr->lineLABCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
iPtr->scriptCLLocPtr = NULL;
#endif
iPtr->activeVarTracePtr = NULL;
iPtr->returnCode = TCL_OK;
iPtr->errorInfo = NULL;
iPtr->errorCode = NULL;
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
#ifdef TCL_TIP268
/* TIP #268 */
iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ?
PKG_PREFER_STABLE :
PKG_PREFER_LATEST);
#endif
iPtr->cmdCount = 0;
iPtr->termOffset = 0;
TclInitLiteralTable(&(iPtr->literalTable));
iPtr->compileEpoch = 0;
iPtr->compiledProcPtr = NULL;
iPtr->resolverPtr = NULL;
iPtr->evalFlags = 0;
iPtr->scriptFile = NULL;
iPtr->flags = 0;
iPtr->tracePtr = NULL;
iPtr->tracesForbiddingInline = 0;
iPtr->activeCmdTracePtr = NULL;
iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = (Tcl_HashTable *) NULL;
iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
iPtr->resultSpace[0] = 0;
iPtr->threadId = Tcl_GetCurrentThread();
iPtr->globalNsPtr = NULL; /* force creation of global ns below */
iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
(ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
if (iPtr->globalNsPtr == NULL) {
panic("Tcl_CreateInterp: can't create global namespace");
}
/*
* Initialize support for code compilation and execution. We call
* TclCreateExecEnv after initializing namespaces since it tries to
* reference a Tcl variable (it links to the Tcl "tcl_traceExec"
* variable).
*/
iPtr->execEnvPtr = TclCreateExecEnv(interp);
/*
* Initialize the compilation and execution statistics kept for this
* interpreter.
*/
#ifdef TCL_COMPILE_STATS
statsPtr = &(iPtr->stats);
statsPtr->numExecutions = 0;
statsPtr->numCompilations = 0;
statsPtr->numByteCodesFreed = 0;
(VOID *) memset(statsPtr->instructionCount, 0,
sizeof(statsPtr->instructionCount));
statsPtr->totalSrcBytes = 0.0;
statsPtr->totalByteCodeBytes = 0.0;
statsPtr->currentSrcBytes = 0.0;
statsPtr->currentByteCodeBytes = 0.0;
(VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
(VOID *) memset(statsPtr->byteCodeCount, 0,
sizeof(statsPtr->byteCodeCount));
(VOID *) memset(statsPtr->lifetimeCount, 0,
sizeof(statsPtr->lifetimeCount));
statsPtr->currentInstBytes = 0.0;
statsPtr->currentLitBytes = 0.0;
statsPtr->currentExceptBytes = 0.0;
statsPtr->currentAuxBytes = 0.0;
statsPtr->currentCmdMapBytes = 0.0;
statsPtr->numLiteralsCreated = 0;
statsPtr->totalLitStringBytes = 0.0;
statsPtr->currentLitStringBytes = 0.0;
(VOID *) memset(statsPtr->literalCount, 0,
sizeof(statsPtr->literalCount));
#endif /* TCL_COMPILE_STATS */
/*
* Initialise the stub table pointer.
*/
iPtr->stubTable = &tclStubs;
/*
* Create the core commands. Do it here, rather than calling
* Tcl_CreateCommand, because it's faster (there's no need to check for
* a pre-existing command by the same name). If a command has a
* Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
* TclInvokeStringCommand. This is an object-based wrapper procedure
* that extracts strings, calls the string procedure, and creates an
* object for the result. Similarly, if a command has a Tcl_ObjCmdProc
* but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
*/
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL;
cmdInfoPtr++) {
int new;
Tcl_HashEntry *hPtr;
if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL)
&& (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
&& (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");
}
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
cmdInfoPtr->name, &new);
if (new) {
cmdPtr = (Command *) ckalloc(sizeof(Command));
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = iPtr->globalNsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = cmdInfoPtr->compileProc;
if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) {
cmdPtr->proc = TclInvokeObjectCommand;
cmdPtr->clientData = (ClientData) cmdPtr;
} else {
cmdPtr->proc = cmdInfoPtr->proc;
cmdPtr->clientData = (ClientData) NULL;
}
if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
cmdPtr->objProc = TclInvokeStringCommand;
cmdPtr->objClientData = (ClientData) cmdPtr;
} else {
cmdPtr->objProc = cmdInfoPtr->objProc;
cmdPtr->objClientData = (ClientData) NULL;
}
cmdPtr->deleteProc = NULL;
cmdPtr->deleteData = (ClientData) NULL;
cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
Tcl_SetHashValue(hPtr, cmdPtr);
}
}
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
*/
Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
#endif /* USE_DTRACE */
/*
* Register the builtin math functions.
*/
i = 0;
for (builtinFuncPtr = tclBuiltinFuncTable; builtinFuncPtr->name != NULL;
builtinFuncPtr++) {
Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
(Tcl_MathProc *) NULL, (ClientData) 0);
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
builtinFuncPtr->name);
if (hPtr == NULL) {
panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name);
return NULL;
}
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
mathFuncPtr->builtinFuncIndex = i;
i++;
}
iPtr->flags |= EXPR_INITIALIZED;
/*
* Do Multiple/Safe Interps Tcl init stuff
*/
TclInterpInit(interp);
/*
* We used to create the "errorInfo" and "errorCode" global vars at this
* point because so much of the Tcl implementation assumes they already
* exist. This is not quite enough, however, since they can be unset
* at any time.
*
* There are 2 choices:
* + Check every place where a GetVar of those is used
* and the NULL result is not checked (like in tclLoad.c)
* + Make SetVar,... NULL friendly
* We choose the second option because :
* + It is easy and low cost to check for NULL pointer before
* calling strlen()
* + It can be helpfull to other people using those API
* + Passing a NULL value to those closest 'meaning' is empty string
* (specially with the new objects where 0 bytes strings are ok)
* So the following init is commented out: -- dl
*
* (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL,
* "", TCL_GLOBAL_ONLY);
* (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL,
* "NONE", TCL_GLOBAL_ONLY);
*/
#ifndef TCL_GENERIC_ONLY
TclSetupEnv(interp);
#endif
/*
* Compute the byte order of this machine.
*/
order.s = 1;
Tcl_SetVar2(interp, "tcl_platform", "byteOrder",
((order.c[0] == 1) ? "littleEndian" : "bigEndian"),
TCL_GLOBAL_ONLY);
Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize",
Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY);
/*
* Set up other variables such as tcl_version and tcl_library
*/
Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
TclPrecTraceProc, (ClientData) NULL);
TclpSetVariables(interp);
#ifdef TCL_THREADS
/*
* The existence of the "threaded" element of the tcl_platform array indicates
* that this particular Tcl shell has been compiled with threads turned on.
* Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the
* interpreter level of thread safety.
*/
Tcl_SetVar2(interp, "tcl_platform", "threaded", "1",
TCL_GLOBAL_ONLY);
#endif
/*
* Register Tcl's version number.
* TIP#268: Expose information about its status,
* for runtime switches in the core library
* and tests.
*/
Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
#ifdef TCL_TIP268
Tcl_SetVar2(interp, "tcl_platform", "tip,268", "1",
TCL_GLOBAL_ONLY);
#endif
#ifdef TCL_TIP280
Tcl_SetVar2(interp, "tcl_platform", "tip,280", "1",
TCL_GLOBAL_ONLY);
#endif
#ifdef Tcl_InitStubs
#undef Tcl_InitStubs
#endif
Tcl_InitStubs(interp, TCL_VERSION, 1);
return interp;
}
/*
*----------------------------------------------------------------------
*
* TclHideUnsafeCommands --
*
* Hides base commands that are not marked as safe from this
* interpreter.
*
* Results:
* TCL_OK if it succeeds, TCL_ERROR else.
*
* Side effects:
* Hides functionality in an interpreter.
*
*----------------------------------------------------------------------
*/
int
TclHideUnsafeCommands(interp)
Tcl_Interp *interp; /* Hide commands in this interpreter. */
{
register CONST CmdInfo *cmdInfoPtr;
if (interp == (Tcl_Interp *) NULL) {
return TCL_ERROR;
}
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
if (!cmdInfoPtr->isSafe) {
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
return TCL_OK;
}
/*
*--------------------------------------------------------------
*
* Tcl_CallWhenDeleted --
*
* Arrange for a procedure to be called before a given
* interpreter is deleted. The procedure is called as soon
* as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
* called on an interpreter that has already been deleted,
* the procedure will be called when the last Tcl_Release is
* done on the interpreter.
*
* Results:
* None.
*
* Side effects:
* When Tcl_DeleteInterp is invoked to delete interp,
* proc will be invoked. See the manual entry for
* details.
*
*--------------------------------------------------------------
*/
void
Tcl_CallWhenDeleted(interp, proc, clientData)
Tcl_Interp *interp; /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
* is about to be deleted. */
ClientData clientData; /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
int *assocDataCounterPtr =
Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int));
int new;
char buffer[32 + TCL_INTEGER_SPACE];
AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
Tcl_HashEntry *hPtr;
sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
(*assocDataCounterPtr)++;
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
dPtr->proc = proc;
dPtr->clientData = clientData;
Tcl_SetHashValue(hPtr, dPtr);
}
/*
*--------------------------------------------------------------
*
* Tcl_DontCallWhenDeleted --
*
* Cancel the arrangement for a procedure to be called when
* a given interpreter is deleted.
*
* Results:
* None.
*
* Side effects:
* If proc and clientData were previously registered as a
* callback via Tcl_CallWhenDeleted, they are unregistered.
* If they weren't previously registered then nothing
* happens.
*
*--------------------------------------------------------------
*/
void
Tcl_DontCallWhenDeleted(interp, proc, clientData)
Tcl_Interp *interp; /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
* is about to be deleted. */
ClientData clientData; /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTablePtr;
Tcl_HashSearch hSearch;
Tcl_HashEntry *hPtr;
AssocData *dPtr;
hTablePtr = iPtr->assocData;
if (hTablePtr == (Tcl_HashTable *) NULL) {
return;
}
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
ckfree((char *) dPtr);
Tcl_DeleteHashEntry(hPtr);
return;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetAssocData --
*
* Creates a named association between user-specified data, a delete
* function and this interpreter. If the association already exists
* the data is overwritten with the new data. The delete function will
* be invoked when the interpreter is deleted.
*
* Results:
* None.
*
* Side effects:
* Sets the associated data, creates the association if needed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetAssocData(interp, name, proc, clientData)
Tcl_Interp *interp; /* Interpreter to associate with. */
CONST char *name; /* Name for association. */
Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
* about to be deleted. */
ClientData clientData; /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
Tcl_HashEntry *hPtr;
int new;
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
if (new == 0) {
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
} else {
dPtr = (AssocData *) ckalloc(sizeof(AssocData));
}
dPtr->proc = proc;
dPtr->clientData = clientData;
Tcl_SetHashValue(hPtr, dPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteAssocData --
*
* Deletes a named association of user-specified data with
* the specified interpreter.
*
* Results:
* None.
*
* Side effects:
* Deletes the association.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteAssocData(interp, name)
Tcl_Interp *interp; /* Interpreter to associate with. */
CONST char *name; /* Name of association. */
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
Tcl_HashEntry *hPtr;
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
return;
}
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
if (hPtr == (Tcl_HashEntry *) NULL) {
return;
}
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
if (dPtr->proc != NULL) {
(dPtr->proc) (dPtr->clientData, interp);
}
ckfree((char *) dPtr);
Tcl_DeleteHashEntry(hPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetAssocData --
*
* Returns the client data associated with this name in the
* specified interpreter.
*
* Results:
* The client data in the AssocData record denoted by the named
* association, or NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_GetAssocData(interp, name, procPtr)
Tcl_Interp *interp; /* Interpreter associated with. */
CONST char *name; /* Name of association. */
Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address
* of current deletion callback. */
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
Tcl_HashEntry *hPtr;
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
return (ClientData) NULL;
}
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
if (hPtr == (Tcl_HashEntry *) NULL) {
return (ClientData) NULL;
}
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
*procPtr = dPtr->proc;
}
return dPtr->clientData;
}
/*
*----------------------------------------------------------------------
*
* Tcl_InterpDeleted --
*
* Returns nonzero if the interpreter has been deleted with a call
* to Tcl_DeleteInterp.
*
* Results:
* Nonzero if the interpreter is deleted, zero otherwise.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_InterpDeleted(interp)
Tcl_Interp *interp;
{
return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteInterp --
*
* Ensures that the interpreter will be deleted eventually. If there
* are no Tcl_Preserve calls in effect for this interpreter, it is
* deleted immediately, otherwise the interpreter is deleted when
* the last Tcl_Preserve is matched by a call to Tcl_Release. In either
* case, the procedure runs the currently registered deletion callbacks.
*
* Results:
* None.
*
* Side effects:
* The interpreter is marked as deleted. The caller may still use it
* safely if there are calls to Tcl_Preserve in effect for the
* interpreter, but further calls to Tcl_Eval etc in this interpreter
* will fail.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteInterp(interp)
Tcl_Interp *interp; /* Token for command interpreter (returned
* by a previous call to Tcl_CreateInterp). */
{
Interp *iPtr = (Interp *) interp;
/*
* If the interpreter has already been marked deleted, just punt.
*/
if (iPtr->flags & DELETED) {
return;
}
/*
* Mark the interpreter as deleted. No further evals will be allowed.
*/
iPtr->flags |= DELETED;
/*
* Ensure that the interpreter is eventually deleted.
*/
Tcl_EventuallyFree((ClientData) interp,
(Tcl_FreeProc *) DeleteInterpProc);
}
/*
*----------------------------------------------------------------------
*
* DeleteInterpProc --
*
* Helper procedure to delete an interpreter. This procedure is
* called when the last call to Tcl_Preserve on this interpreter
* is matched by a call to Tcl_Release. The procedure cleans up
* all resources used in the interpreter and calls all currently
* registered interpreter deletion callbacks.
*
* Results:
* None.
*
* Side effects:
* Whatever the interpreter deletion callbacks do. Frees resources
* used by the interpreter.
*
*----------------------------------------------------------------------
*/
static void
DeleteInterpProc(interp)
Tcl_Interp *interp; /* Interpreter to delete. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable *hTablePtr;
ResolverScheme *resPtr, *nextResPtr;
/*
* Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
*/
if (iPtr->numLevels > 0) {
panic("DeleteInterpProc called with active evals");
}
/*
* The interpreter should already be marked deleted; otherwise how
* did we get here?
*/
if (!(iPtr->flags & DELETED)) {
panic("DeleteInterpProc called on interpreter not marked deleted");
}
TclHandleFree(iPtr->handle);
/*
* Dismantle everything in the global namespace except for the
* "errorInfo" and "errorCode" variables. These remain until the
* namespace is actually destroyed, in case any errors occur.
*
* Dismantle the namespace here, before we clear the assocData. If any
* background errors occur here, they will be deleted below.
*/
TclTeardownNamespace(iPtr->globalNsPtr);
/*
* Delete all the hidden commands.
*/
hTablePtr = iPtr->hiddenCmdTablePtr;
if (hTablePtr != NULL) {
/*
* Non-pernicious deletion. The deletion callbacks will not be
* allowed to create any new hidden or non-hidden commands.
* Tcl_DeleteCommandFromToken() will remove the entry from the
* hiddenCmdTablePtr.
*/
hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_DeleteCommandFromToken(interp,
(Tcl_Command) Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(hTablePtr);
ckfree((char *) hTablePtr);
}
/*
* Tear down the math function table.
*/
for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
ckfree((char *) Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(&iPtr->mathFuncTable);
/*
* Invoke deletion callbacks; note that a callback can create new
* callbacks, so we iterate.
*/
while (iPtr->assocData != (Tcl_HashTable *) NULL) {
AssocData *dPtr;
hTablePtr = iPtr->assocData;
iPtr->assocData = (Tcl_HashTable *) NULL;
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (dPtr->proc != NULL) {
(*dPtr->proc)(dPtr->clientData, interp);
}
ckfree((char *) dPtr);
}
Tcl_DeleteHashTable(hTablePtr);
ckfree((char *) hTablePtr);
}
/*
* Finish deleting the global namespace.
*/
Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
/*
* Free up the result *after* deleting variables, since variable
* deletion could have transferred ownership of the result string
* to Tcl.
*/
Tcl_FreeResult(interp);
interp->result = NULL;
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = NULL;
if (iPtr->errorInfo != NULL) {
ckfree(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
if (iPtr->errorCode != NULL) {
ckfree(iPtr->errorCode);
iPtr->errorCode = NULL;
}
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
}
TclFreePackageInfo(iPtr);
while (iPtr->tracePtr != NULL) {
Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr);
}
if (iPtr->execEnvPtr != NULL) {
TclDeleteExecEnv(iPtr->execEnvPtr);
}
if (iPtr->scriptFile) {
Tcl_DecrRefCount(iPtr->scriptFile);
iPtr->scriptFile = NULL;
}
Tcl_DecrRefCount(iPtr->emptyObjPtr);
iPtr->emptyObjPtr = NULL;
resPtr = iPtr->resolverPtr;
while (resPtr) {
nextResPtr = resPtr->nextPtr;
ckfree(resPtr->name);
ckfree((char *) resPtr);
resPtr = nextResPtr;
}
/*
* Free up literal objects created for scripts compiled by the
* interpreter.
*/
TclDeleteLiteralTable(interp, &(iPtr->literalTable));
#ifdef TCL_TIP280
/* TIP #280 - Release the arrays for ByteCode/Proc extension, and contents.
*/
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
CmdFrame* cfPtr;
ExtCmdLoc* eclPtr;
int i;
for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
cfPtr = (CmdFrame*) Tcl_GetHashValue (hPtr);
if (cfPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (cfPtr->data.eval.path);
}
ckfree ((char*) cfPtr->line);
ckfree ((char*) cfPtr);
Tcl_DeleteHashEntry (hPtr);
}
Tcl_DeleteHashTable (iPtr->linePBodyPtr);
ckfree ((char*) iPtr->linePBodyPtr);
iPtr->linePBodyPtr = NULL;
/* See also tclCompile.c, TclCleanupByteCode */
for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hPtr);
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (eclPtr->path);
}
for (i=0; i< eclPtr->nuloc; i++) {
ckfree ((char*) eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
ckfree ((char*) eclPtr->loc);
}
Tcl_DeleteHashTable (&eclPtr->litInfo);
ckfree ((char*) eclPtr);
Tcl_DeleteHashEntry (hPtr);
}
Tcl_DeleteHashTable (iPtr->lineBCPtr);
ckfree((char*) iPtr->lineBCPtr);
iPtr->lineBCPtr = NULL;
/*
* Location stack for uplevel/eval/... scripts which were passed
* through proc arguments. Actually we track all arguments as we
* don't, cannot know which arguments will be used as scripts and
* which won't.
*/
if (iPtr->lineLAPtr->numEntries) {
/*
* When the interp goes away we have nothing on the stack, so
* there are no arguments, so this table has to be empty.
*/
Tcl_Panic ("Argument location tracking table not empty");
}
Tcl_DeleteHashTable (iPtr->lineLAPtr);
ckfree((char*) iPtr->lineLAPtr);
iPtr->lineLAPtr = NULL;
if (iPtr->lineLABCPtr->numEntries) {
/*
* When the interp goes away we have nothing on the stack, so
* there are no arguments, so this table has to be empty.
*/
Tcl_Panic ("Argument location tracking table not empty");
}
Tcl_DeleteHashTable (iPtr->lineLABCPtr);
ckfree((char*) iPtr->lineLABCPtr);
iPtr->lineLABCPtr = NULL;
}
#endif
ckfree((char *) iPtr);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_HideCommand --
*
* Makes a command hidden so that it cannot be invoked from within
* an interpreter, only from within an ancestor.
*
* Results:
* A standard Tcl result; also leaves a message in the interp's result
* if an error occurs.
*
* Side effects:
* Removes a command from the command table and create an entry
* into the hidden command table under the specified token name.
*
*---------------------------------------------------------------------------
*/
int
Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
Tcl_Interp *interp; /* Interpreter in which to hide command. */
CONST char *cmdName; /* Name of command to hide. */
CONST char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Command cmd;
Command *cmdPtr;
Tcl_HashTable *hiddenCmdTablePtr;
Tcl_HashEntry *hPtr;
int new;
if (iPtr->flags & DELETED) {
/*
* The interpreter is being deleted. Do not create any new
* structures, because it is not safe to modify the interpreter.
*/
return TCL_ERROR;
}
/*
* Disallow hiding of commands that are currently in a namespace or
* renaming (as part of hiding) into a namespace.
*
* (because the current implementation with a single global table
* and the needed uniqueness of names cause problems with namespaces)
*
* we don't need to check for "::" in cmdName because the real check is
* on the nsPtr below.
*
* hiddenCmdToken is just a string which is not interpreted in any way.
* It may contain :: but the string is not interpreted as a namespace
* qualifier command name. Thus, hiding foo::bar to foo::bar and then
* trying to expose or invoke ::foo::bar will NOT work; but if the
* application always uses the same strings it will get consistent
* behaviour.
*
* But as we currently limit ourselves to the global namespace only
* for the source, in order to avoid potential confusion,
* lets prevent "::" in the token too. --dl
*/
if (strstr(hiddenCmdToken, "::") != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot use namespace qualifiers in hidden command",
" token (rename)", (char *) NULL);
return TCL_ERROR;
}
/*
* Find the command to hide. An error is returned if cmdName can't
* be found. Look up the command only from the global namespace.
* Full path of the command must be given if using namespaces.
*/
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
/*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
if (cmd == (Tcl_Command) NULL) {
return TCL_ERROR;
}
cmdPtr = (Command *) cmd;
/*
* Check that the command is really in global namespace
*/
if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can only hide global namespace commands",
" (use rename then hide)", (char *) NULL);
return TCL_ERROR;
}
/*
* Initialize the hidden command table if necessary.
*/
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr == NULL) {
hiddenCmdTablePtr = (Tcl_HashTable *)
ckalloc((unsigned) sizeof(Tcl_HashTable));
Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
}
/*
* It is an error to move an exposed command to a hidden command with
* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
* exists.
*/
hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new);
if (!new) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"hidden command named \"", hiddenCmdToken, "\" already exists",
(char *) NULL);
return TCL_ERROR;
}
/*
* Nb : This code is currently 'like' a rename to a specialy set apart
* name table. Changes here and in TclRenameCommand must
* be kept in synch untill the common parts are actually
* factorized out.
*/
/*
* Remove the hash entry for the command from the interpreter command
* table. This is like deleting the command, so bump its command epoch;
* this invalidates any cached references that point to the command.
*/
if (cmdPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(cmdPtr->hPtr);
cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
cmdPtr->cmdEpoch++;
}
/*
* Now link the hash table entry with the command structure.
* We ensured above that the nsPtr was right.
*/
cmdPtr->hPtr = hPtr;
Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
/*
* If the command being hidden has a compile procedure, increment the
* interpreter's compileEpoch to invalidate its compiled code. This
* makes sure that we don't later try to execute old code compiled with
* command-specific (i.e., inline) bytecodes for the now-hidden
* command. This field is checked in Tcl_EvalObj and ObjInterpProc,
* and code whose compilation epoch doesn't match is recompiled.
*/
if (cmdPtr->compileProc != NULL) {
iPtr->compileEpoch++;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ExposeCommand --
*
* Makes a previously hidden command callable from inside the
* interpreter instead of only by its ancestors.
*
* Results:
* A standard Tcl result. If an error occurs, a message is left
* in the interp's result.
*
* Side effects:
* Moves commands from one hash table to another.
*
*----------------------------------------------------------------------
*/
int
Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
Tcl_Interp *interp; /* Interpreter in which to make command
* callable. */
CONST char *hiddenCmdToken; /* Name of hidden command. */
CONST char *cmdName; /* Name of to-be-exposed command. */
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr;
Namespace *nsPtr;
Tcl_HashEntry *hPtr;
Tcl_HashTable *hiddenCmdTablePtr;
int new;
if (iPtr->flags & DELETED) {
/*
* The interpreter is being deleted. Do not create any new
* structures, because it is not safe to modify the interpreter.
*/
return TCL_ERROR;
}
/*
* Check that we have a regular name for the command
* (that the user is not trying to do an expose and a rename
* (to another namespace) at the same time)
*/
if (strstr(cmdName, "::") != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can not expose to a namespace ",
"(use expose to toplevel, then rename)",
(char *) NULL);
return TCL_ERROR;
}
/*
* Get the command from the hidden command table:
*/
hPtr = NULL;
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr != NULL) {
hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
}
if (hPtr == (Tcl_HashEntry *) NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown hidden command \"", hiddenCmdToken,
"\"", (char *) NULL);
return TCL_ERROR;
}
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
/*
* Check that we have a true global namespace
* command (enforced by Tcl_HideCommand() but let's double
* check. (If it was not, we would not really know how to
* handle it).
*/
if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
/*
* This case is theoritically impossible,
* we might rather panic() than 'nicely' erroring out ?
*/
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"trying to expose a non global command name space command",
(char *) NULL);
return TCL_ERROR;
}
/* This is the global table */
nsPtr = cmdPtr->nsPtr;
/*
* It is an error to overwrite an existing exposed command as a result
* of exposing a previously hidden command.
*/
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
if (!new) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"exposed command \"", cmdName,
"\" already exists", (char *) NULL);
return TCL_ERROR;
}
/*
* Remove the hash entry for the command from the interpreter hidden
* command table.
*/
if (cmdPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(cmdPtr->hPtr);
cmdPtr->hPtr = NULL;
}
/*
* Now link the hash table entry with the command structure.
* This is like creating a new command, so deal with any shadowing
* of commands in the global namespace.
*/
cmdPtr->hPtr = hPtr;
Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
/*
* Not needed as we are only in the global namespace
* (but would be needed again if we supported namespace command hiding)
*
* TclResetShadowedCmdRefs(interp, cmdPtr);
*/
/*
* If the command being exposed has a compile procedure, increment
* interpreter's compileEpoch to invalidate its compiled code. This
* makes sure that we don't later try to execute old code compiled
* assuming the command is hidden. This field is checked in Tcl_EvalObj
* and ObjInterpProc, and code whose compilation epoch doesn't match is
* recompiled.
*/
if (cmdPtr->compileProc != NULL) {
iPtr->compileEpoch++;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateCommand --
*
* Define a new command in a command table.
*
* Results:
* The return value is a token for the command, which can
* be used in future calls to Tcl_GetCommandName.
*
* Side effects:
* If a command named cmdName already exists for interp, it is deleted.
* In the future, when cmdName is seen as the name of a command by
* Tcl_Eval, proc will be called. To support the bytecode interpreter,
* the command is created with a wrapper Tcl_ObjCmdProc
* (TclInvokeStringCommand) that eventially calls proc. When the
* command is deleted from the table, deleteProc will be called.
* See the manual entry for details on the calling sequence.
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
Tcl_Interp *interp; /* Token for command interpreter returned by
* a previous call to Tcl_CreateInterp. */
CONST char *cmdName; /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put
* in the global namespace. */
Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */
ClientData clientData; /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* If not NULL, gives a procedure to call
* when this command is deleted. */
{
Interp *iPtr = (Interp *) interp;
ImportRef *oldRefPtr = NULL;
Namespace *nsPtr, *dummy1, *dummy2;
Command *cmdPtr, *refCmdPtr;
Tcl_HashEntry *hPtr;
CONST char *tail;
int new;
ImportedCmdData *dataPtr;
if (iPtr->flags & DELETED) {
/*
* The interpreter is being deleted. Don't create any new
* commands; it's not safe to muck with the interpreter anymore.
*/
return (Tcl_Command) NULL;
}
/*
* Determine where the command should reside. If its name contains
* namespace qualifiers, we put it in the specified namespace;
* otherwise, we always put it in the global namespace.
*/
if (strstr(cmdName, "::") != NULL) {
TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
if ((nsPtr == NULL) || (tail == NULL)) {
return (Tcl_Command) NULL;
}
} else {
nsPtr = iPtr->globalNsPtr;
tail = cmdName;
}
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
if (!new) {
/*
* Command already exists. Delete the old one.
* Be careful to preserve any existing import links so we can
* restore them down below. That way, you can redefine a
* command and its import status will remain intact.
*/
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
oldRefPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = NULL;
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
if (!new) {
/*
* If the deletion callback recreated the command, just throw
* away the new command (if we try to delete it again, we
* could get stuck in an infinite loop).
*/
ckfree((char*) Tcl_GetHashValue(hPtr));
}
}
cmdPtr = (Command *) ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = (CompileProc *) NULL;
cmdPtr->objProc = TclInvokeStringCommand;
cmdPtr->objClientData = (ClientData) cmdPtr;
cmdPtr->proc = proc;
cmdPtr->clientData = clientData;
cmdPtr->deleteProc = deleteProc;
cmdPtr->deleteData = clientData;
cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
/*
* Plug in any existing import references found above. Be sure
* to update all of these references to point to the new command.
*/
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
refCmdPtr = oldRefPtr->importedCmdPtr;
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
}
/*
* We just created a command, so in its namespace and all of its parent
* namespaces, it may shadow global commands with the same name. If any
* shadowed commands are found, invalidate all cached command references
* in the affected namespaces.
*/
TclResetShadowedCmdRefs(interp, cmdPtr);
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateObjCommand --
*
* Define a new object-based command in a command table.
*
* Results:
* The return value is a token for the command, which can
* be used in future calls to Tcl_GetCommandName.
*
* Side effects:
* If no command named "cmdName" already exists for interp, one is
* created. Otherwise, if a command does exist, then if the
* object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume
* Tcl_CreateCommand was called previously for the same command and
* just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we
* delete the old command.
*
* In the future, during bytecode evaluation when "cmdName" is seen as
* the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
* Tcl_ObjCmdProc proc will be called. When the command is deleted from
* the table, deleteProc will be called. See the manual entry for
* details on the calling sequence.
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
Tcl_Interp *interp; /* Token for command interpreter (returned
* by previous call to Tcl_CreateInterp). */
CONST char *cmdName; /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put
* in the global namespace. */
Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with
* name. */
ClientData clientData; /* Arbitrary value to pass to object
* procedure. */
Tcl_CmdDeleteProc *deleteProc;
/* If not NULL, gives a procedure to call
* when this command is deleted. */
{
Interp *iPtr = (Interp *) interp;
ImportRef *oldRefPtr = NULL;
Namespace *nsPtr, *dummy1, *dummy2;
Command *cmdPtr, *refCmdPtr;
Tcl_HashEntry *hPtr;
CONST char *tail;
int new;
ImportedCmdData *dataPtr;
if (iPtr->flags & DELETED) {
/*
* The interpreter is being deleted. Don't create any new
* commands; it's not safe to muck with the interpreter anymore.
*/
return (Tcl_Command) NULL;
}
/*
* Determine where the command should reside. If its name contains
* namespace qualifiers, we put it in the specified namespace;
* otherwise, we always put it in the global namespace.
*/
if (strstr(cmdName, "::") != NULL) {
TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
if ((nsPtr == NULL) || (tail == NULL)) {
return (Tcl_Command) NULL;
}
} else {
nsPtr = iPtr->globalNsPtr;
tail = cmdName;
}
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
if (!new) {
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
/*
* Command already exists. If its object-based Tcl_ObjCmdProc is
* TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
* argument "proc". Otherwise, we delete the old command.
*/
if (cmdPtr->objProc == TclInvokeStringCommand) {
cmdPtr->objProc = proc;
cmdPtr->objClientData = clientData;
cmdPtr->deleteProc = deleteProc;
cmdPtr->deleteData = clientData;
return (Tcl_Command) cmdPtr;
}
/*
* Otherwise, we delete the old command. Be careful to preserve
* any existing import links so we can restore them down below.
* That way, you can redefine a command and its import status
* will remain intact.
*/
oldRefPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = NULL;
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
if (!new) {
/*
* If the deletion callback recreated the command, just throw
* away the new command (if we try to delete it again, we
* could get stuck in an infinite loop).
*/
ckfree((char *) Tcl_GetHashValue(hPtr));
}
}
cmdPtr = (Command *) ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = (CompileProc *) NULL;
cmdPtr->objProc = proc;
cmdPtr->objClientData = clientData;
cmdPtr->proc = TclInvokeObjectCommand;
cmdPtr->clientData = (ClientData) cmdPtr;
cmdPtr->deleteProc = deleteProc;
cmdPtr->deleteData = clientData;
cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
/*
* Plug in any existing import references found above. Be sure
* to update all of these references to point to the new command.
*/
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
refCmdPtr = oldRefPtr->importedCmdPtr;
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
}
/*
* We just created a command, so in its namespace and all of its parent
* namespaces, it may shadow global commands with the same name. If any
* shadowed commands are found, invalidate all cached command references
* in the affected namespaces.
*/
TclResetShadowedCmdRefs(interp, cmdPtr);
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
*
* TclInvokeStringCommand --
*
* "Wrapper" Tcl_ObjCmdProc used to call an existing string-based
* Tcl_CmdProc if no object-based procedure exists for a command. A
* pointer to this procedure is stored as the Tcl_ObjCmdProc in a
* Command structure. It simply turns around and calls the string
* Tcl_CmdProc in the Command structure.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* Besides those side effects of the called Tcl_CmdProc,
* TclInvokeStringCommand allocates and frees storage.
*
*----------------------------------------------------------------------
*/
int
TclInvokeStringCommand(clientData, interp, objc, objv)
ClientData clientData; /* Points to command's Command structure. */
Tcl_Interp *interp; /* Current interpreter. */
register int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Command *cmdPtr = (Command *) clientData;
register int i;
int result;
/*
* This procedure generates an argv array for the string arguments. It
* starts out with stack-allocated space but uses dynamically-allocated
* storage if needed.
*/
#define NUM_ARGS 20
CONST char *(argStorage[NUM_ARGS]);
CONST char **argv = argStorage;
/*
* Create the string argument array "argv". Make sure argv is large
* enough to hold the objc arguments plus 1 extra for the zero
* end-of-argv word.
*/
if ((objc + 1) > NUM_ARGS) {
argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
}
for (i = 0; i < objc; i++) {
argv[i] = Tcl_GetString(objv[i]);
}
argv[objc] = 0;
/*
* Invoke the command's string-based Tcl_CmdProc.
*/
result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
/*
* Free the argv array if malloc'ed storage was used.
*/
if (argv != argStorage) {
ckfree((char *) argv);
}
return result;
#undef NUM_ARGS
}
/*
*----------------------------------------------------------------------
*
* TclInvokeObjectCommand --
*
* "Wrapper" Tcl_CmdProc used to call an existing object-based
* Tcl_ObjCmdProc if no string-based procedure exists for a command.
* A pointer to this procedure is stored as the Tcl_CmdProc in a
* Command structure. It simply turns around and calls the object
* Tcl_ObjCmdProc in the Command structure.
*
* Results:
* A standard Tcl string result value.
*
* Side effects:
* Besides those side effects of the called Tcl_CmdProc,
* TclInvokeStringCommand allocates and frees storage.
*
*----------------------------------------------------------------------
*/
int
TclInvokeObjectCommand(clientData, interp, argc, argv)
ClientData clientData; /* Points to command's Command structure. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
register CONST char **argv; /* Argument strings. */
{
Command *cmdPtr = (Command *) clientData;
register Tcl_Obj *objPtr;
register int i;
int length, result;
/*
* This procedure generates an objv array for object arguments that hold
* the argv strings. It starts out with stack-allocated space but uses
* dynamically-allocated storage if needed.
*/
#define NUM_ARGS 20
Tcl_Obj *(argStorage[NUM_ARGS]);
register Tcl_Obj **objv = argStorage;
/*
* Create the object argument array "objv". Make sure objv is large
* enough to hold the objc arguments plus 1 extra for the zero
* end-of-objv word.
*/
if (argc > NUM_ARGS) {
objv = (Tcl_Obj **)
ckalloc((unsigned)(argc * sizeof(Tcl_Obj *)));
}
for (i = 0; i < argc; i++) {
length = strlen(argv[i]);
TclNewObj(objPtr);
TclInitStringRep(objPtr, argv[i], length);
Tcl_IncrRefCount(objPtr);
objv[i] = objPtr;
}
/*
* Invoke the command's object-based Tcl_ObjCmdProc.
*/
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
/*
* Decrement the ref counts for the argument objects created above,
* then free the objv array if malloc'ed storage was used.
*/
for (i = 0; i < argc; i++) {
objPtr = objv[i];
Tcl_DecrRefCount(objPtr);
}
if (objv != argStorage) {
ckfree((char *) objv);
}
return result;
#undef NUM_ARGS
}
/*
*----------------------------------------------------------------------
*
* TclRenameCommand --
*
* Called to give an existing Tcl command a different name. Both the
* old command name and the new command name can have "::" namespace
* qualifiers. If the new command has a different namespace context,
* the command will be moved to that namespace and will execute in
* the context of that new namespace.
*
* If the new command name is NULL or the null string, the command is
* deleted.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* If anything goes wrong, an error message is returned in the
* interpreter's result object.
*
*----------------------------------------------------------------------
*/
int
TclRenameCommand(interp, oldName, newName)
Tcl_Interp *interp; /* Current interpreter. */
char *oldName; /* Existing command name. */
char *newName; /* New command name. */
{
Interp *iPtr = (Interp *) interp;
CONST char *newTail;
Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
Tcl_Command cmd;
Command *cmdPtr;
Tcl_HashEntry *hPtr, *oldHPtr;
int new, result;
Tcl_Obj* oldFullName;
Tcl_DString newFullName;
/*
* Find the existing command. An error is returned if cmdName can't
* be found.
*/
cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
/*flags*/ 0);
cmdPtr = (Command *) cmd;
if (cmdPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
((newName == NULL)||(*newName == '\0'))? "delete":"rename",
" \"", oldName, "\": command doesn't exist", (char *) NULL);
return TCL_ERROR;
}
cmdNsPtr = cmdPtr->nsPtr;
oldFullName = Tcl_NewObj();
Tcl_IncrRefCount( oldFullName );
Tcl_GetCommandFullName( interp, cmd, oldFullName );
/*
* If the new command name is NULL or empty, delete the command. Do this
* with Tcl_DeleteCommandFromToken, since we already have the command.
*/
if ((newName == NULL) || (*newName == '\0')) {
Tcl_DeleteCommandFromToken(interp, cmd);
result = TCL_OK;
goto done;
}
/*
* Make sure that the destination command does not already exist.
* The rename operation is like creating a command, so we should
* automatically create the containing namespaces just like
* Tcl_CreateCommand would.
*/
TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
if ((newNsPtr == NULL) || (newTail == NULL)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't rename to \"", newName, "\": bad command name",
(char *) NULL);
result = TCL_ERROR;
goto done;
}
if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't rename to \"", newName,
"\": command already exists", (char *) NULL);
result = TCL_ERROR;
goto done;
}
/*
* Warning: any changes done in the code here are likely
* to be needed in Tcl_HideCommand() code too.
* (until the common parts are extracted out) --dl
*/
/*
* Put the command in the new namespace so we can check for an alias
* loop. Since we are adding a new command to a namespace, we must
* handle any shadowing of the global commands that this might create.
*/
oldHPtr = cmdPtr->hPtr;
hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = newNsPtr;
TclResetShadowedCmdRefs(interp, cmdPtr);
/*
* Now check for an alias loop. If we detect one, put everything back
* the way it was and report the error.
*/
result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
if (result != TCL_OK) {
Tcl_DeleteHashEntry(cmdPtr->hPtr);
cmdPtr->hPtr = oldHPtr;
cmdPtr->nsPtr = cmdNsPtr;
goto done;
}
/*
* Script for rename traces can delete the command "oldName".
* Therefore increment the reference count for cmdPtr so that
* it's Command structure is freed only towards the end of this
* function by calling TclCleanupCommand.
*
* The trace procedure needs to get a fully qualified name for
* old and new commands [Tcl bug #651271], or else there's no way
* for the trace procedure to get the namespace from which the old
* command is being renamed!
*/
Tcl_DStringInit( &newFullName );
Tcl_DStringAppend( &newFullName, newNsPtr->fullName, -1 );
if ( newNsPtr != iPtr->globalNsPtr ) {
Tcl_DStringAppend( &newFullName, "::", 2 );
}
Tcl_DStringAppend( &newFullName, newTail, -1 );
cmdPtr->refCount++;
CallCommandTraces( iPtr, cmdPtr,
Tcl_GetString( oldFullName ),
Tcl_DStringValue( &newFullName ),
TCL_TRACE_RENAME);
Tcl_DStringFree( &newFullName );
/*
* The new command name is okay, so remove the command from its
* current namespace. This is like deleting the command, so bump
* the cmdEpoch to invalidate any cached references to the command.
*/
Tcl_DeleteHashEntry(oldHPtr);
cmdPtr->cmdEpoch++;
/*
* If the command being renamed has a compile procedure, increment the
* interpreter's compileEpoch to invalidate its compiled code. This
* makes sure that we don't later try to execute old code compiled for
* the now-renamed command.
*/
if (cmdPtr->compileProc != NULL) {
iPtr->compileEpoch++;
}
/*
* Now free the Command structure, if the "oldName" command has
* been deleted by invocation of rename traces.
*/
TclCleanupCommand(cmdPtr);
result = TCL_OK;
done:
TclDecrRefCount( oldFullName );
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetCommandInfo --
*
* Modifies various information about a Tcl command. Note that
* this procedure will not change a command's namespace; use
* Tcl_RenameCommand to do that. Also, the isNativeObjectProc
* member of *infoPtr is ignored.
*
* Results:
* If cmdName exists in interp, then the information at *infoPtr
* is stored with the command in place of the current information
* and 1 is returned. If the command doesn't exist then 0 is
* returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetCommandInfo(interp, cmdName, infoPtr)
Tcl_Interp *interp; /* Interpreter in which to look
* for command. */
CONST char *cmdName; /* Name of desired command. */
CONST Tcl_CmdInfo *infoPtr; /* Where to find information
* to store in the command. */
{
Tcl_Command cmd;
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
/*flags*/ 0);
return Tcl_SetCommandInfoFromToken( cmd, infoPtr );
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetCommandInfoFromToken --
*
* Modifies various information about a Tcl command. Note that
* this procedure will not change a command's namespace; use
* Tcl_RenameCommand to do that. Also, the isNativeObjectProc
* member of *infoPtr is ignored.
*
* Results:
* If cmdName exists in interp, then the information at *infoPtr
* is stored with the command in place of the current information
* and 1 is returned. If the command doesn't exist then 0 is
* returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetCommandInfoFromToken( cmd, infoPtr )
Tcl_Command cmd;
CONST Tcl_CmdInfo* infoPtr;
{
Command* cmdPtr; /* Internal representation of the command */
if (cmd == (Tcl_Command) NULL) {
return 0;
}
/*
* The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
*/
cmdPtr = (Command *) cmd;
cmdPtr->proc = infoPtr->proc;
cmdPtr->clientData = infoPtr->clientData;
if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
cmdPtr->objProc = TclInvokeStringCommand;
cmdPtr->objClientData = (ClientData) cmdPtr;
} else {
cmdPtr->objProc = infoPtr->objProc;
cmdPtr->objClientData = infoPtr->objClientData;
}
cmdPtr->deleteProc = infoPtr->deleteProc;
cmdPtr->deleteData = infoPtr->deleteData;
return 1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandInfo --
*
* Returns various information about a Tcl command.
*
* Results:
* If cmdName exists in interp, then *infoPtr is modified to
* hold information about cmdName and 1 is returned. If the
* command doesn't exist then 0 is returned and *infoPtr isn't
* modified.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetCommandInfo(interp, cmdName, infoPtr)
Tcl_Interp *interp; /* Interpreter in which to look
* for command. */
CONST char *cmdName; /* Name of desired command. */
Tcl_CmdInfo *infoPtr; /* Where to store information about
* command. */
{
Tcl_Command cmd;
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
/*flags*/ 0);
return Tcl_GetCommandInfoFromToken( cmd, infoPtr );
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandInfoFromToken --
*
* Returns various information about a Tcl command.
*
* Results:
* Copies information from the command identified by 'cmd' into
* a caller-supplied structure and returns 1. If the 'cmd' is
* NULL, leaves the structure untouched and returns 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetCommandInfoFromToken( cmd, infoPtr )
Tcl_Command cmd;
Tcl_CmdInfo* infoPtr;
{
Command* cmdPtr; /* Internal representation of the command */
if ( cmd == (Tcl_Command) NULL ) {
return 0;
}
/*
* Set isNativeObjectProc 1 if objProc was registered by a call to
* Tcl_CreateObjCommand. Otherwise set it to 0.
*/
cmdPtr = (Command *) cmd;
infoPtr->isNativeObjectProc =
(cmdPtr->objProc != TclInvokeStringCommand);
infoPtr->objProc = cmdPtr->objProc;
infoPtr->objClientData = cmdPtr->objClientData;
infoPtr->proc = cmdPtr->proc;
infoPtr->clientData = cmdPtr->clientData;
infoPtr->deleteProc = cmdPtr->deleteProc;
infoPtr->deleteData = cmdPtr->deleteData;
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
return 1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandName --
*
* Given a token returned by Tcl_CreateCommand, this procedure
* returns the current name of the command (which may have changed
* due to renaming).
*
* Results:
* The return value is the name of the given command.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_GetCommandName(interp, command)
Tcl_Interp *interp; /* Interpreter containing the command. */
Tcl_Command command; /* Token for command returned by a previous
* call to Tcl_CreateCommand. The command
* must not have been deleted. */
{
Command *cmdPtr = (Command *) command;
if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
/*
* This should only happen if command was "created" after the
* interpreter began to be deleted, so there isn't really any
* command. Just return an empty string.
*/
return "";
}
return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandFullName --
*
* Given a token returned by, e.g., Tcl_CreateCommand or
* Tcl_FindCommand, this procedure appends to an object the command's
* full name, qualified by a sequence of parent namespace names. The
* command's fully-qualified name may have changed due to renaming.
*
* Results:
* None.
*
* Side effects:
* The command's fully-qualified name is appended to the string
* representation of objPtr.
*
*----------------------------------------------------------------------
*/
void
Tcl_GetCommandFullName(interp, command, objPtr)
Tcl_Interp *interp; /* Interpreter containing the command. */
Tcl_Command command; /* Token for command returned by a previous
* call to Tcl_CreateCommand. The command
* must not have been deleted. */
Tcl_Obj *objPtr; /* Points to the object onto which the
* command's full name is appended. */
{
Interp *iPtr = (Interp *) interp;
register Command *cmdPtr = (Command *) command;
char *name;
/*
* Add the full name of the containing namespace, followed by the "::"
* separator, and the command name.
*/
if (cmdPtr != NULL) {
if (cmdPtr->nsPtr != NULL) {
Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
Tcl_AppendToObj(objPtr, "::", 2);
}
}
if (cmdPtr->hPtr != NULL) {
name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
Tcl_AppendToObj(objPtr, name, -1);
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteCommand --
*
* Remove the given command from the given interpreter.
*
* Results:
* 0 is returned if the command was deleted successfully.
* -1 is returned if there didn't exist a command by that name.
*
* Side effects:
* cmdName will no longer be recognized as a valid command for
* interp.
*
*----------------------------------------------------------------------
*/
int
Tcl_DeleteCommand(interp, cmdName)
Tcl_Interp *interp; /* Token for command interpreter (returned
* by a previous Tcl_CreateInterp call). */
CONST char *cmdName; /* Name of command to remove. */
{
Tcl_Command cmd;
/*
* Find the desired command and delete it.
*/
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
/*flags*/ 0);
if (cmd == (Tcl_Command) NULL) {
return -1;
}
return Tcl_DeleteCommandFromToken(interp, cmd);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteCommandFromToken --
*
* Removes the given command from the given interpreter. This procedure
* resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
* of a command name for efficiency.
*
* Results:
* 0 is returned if the command was deleted successfully.
* -1 is returned if there didn't exist a command by that name.
*
* Side effects:
* The command specified by "cmd" will no longer be recognized as a
* valid command for "interp".
*
*----------------------------------------------------------------------
*/
int
Tcl_DeleteCommandFromToken(interp, cmd)
Tcl_Interp *interp; /* Token for command interpreter returned by
* a previous call to Tcl_CreateInterp. */
Tcl_Command cmd; /* Token for command to delete. */
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = (Command *) cmd;
ImportRef *refPtr, *nextRefPtr;
Tcl_Command importCmd;
/*
* The code here is tricky. We can't delete the hash table entry
* before invoking the deletion callback because there are cases
* where the deletion callback needs to invoke the command (e.g.
* object systems such as OTcl). However, this means that the
* callback could try to delete or rename the command. The deleted
* flag allows us to detect these cases and skip nested deletes.
*/
if (cmdPtr->flags & CMD_IS_DELETED) {
/*
* Another deletion is already in progress. Remove the hash
* table entry now, but don't invoke a callback or free the
* command structure.
*/
Tcl_DeleteHashEntry(cmdPtr->hPtr);
cmdPtr->hPtr = NULL;
return 0;
}
/*
* We must delete this command, even though both traces and
* delete procs may try to avoid this (renaming the command etc).
* Also traces and delete procs may try to delete the command
* themsevles. This flag declares that a delete is in progress
* and that recursive deletes should be ignored.
*/
cmdPtr->flags |= CMD_IS_DELETED;
/*
* Bump the command epoch counter. This will invalidate all cached
* references that point to this command.
*/
cmdPtr->cmdEpoch++;
/*
* Call trace procedures for the command being deleted. Then delete
* its traces.
*/
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
/* Now delete these traces */
tracePtr = cmdPtr->tracePtr;
while (tracePtr != NULL) {
CommandTrace *nextPtr = tracePtr->nextPtr;
if ((--tracePtr->refCount) <= 0) {
ckfree((char*)tracePtr);
}
tracePtr = nextPtr;
}
cmdPtr->tracePtr = NULL;
}
/*
* If the command being deleted has a compile procedure, increment the
* interpreter's compileEpoch to invalidate its compiled code. This
* makes sure that we don't later try to execute old code compiled with
* command-specific (i.e., inline) bytecodes for the now-deleted
* command. This field is checked in Tcl_EvalObj and ObjInterpProc, and
* code whose compilation epoch doesn't match is recompiled.
*/
if (cmdPtr->compileProc != NULL) {
iPtr->compileEpoch++;
}
if (cmdPtr->deleteProc != NULL) {
/*
* Delete the command's client data. If this was an imported command
* created when a command was imported into a namespace, this client
* data will be a pointer to a ImportedCmdData structure describing
* the "real" command that this imported command refers to.
*/
/*
* If you are getting a crash during the call to deleteProc and
* cmdPtr->deleteProc is a pointer to the function free(), the
* most likely cause is that your extension allocated memory
* for the clientData argument to Tcl_CreateObjCommand() with
* the ckalloc() macro and you are now trying to deallocate
* this memory with free() instead of ckfree(). You should
* pass a pointer to your own method that calls ckfree().
*/
(*cmdPtr->deleteProc)(cmdPtr->deleteData);
}
/*
* If this command was imported into other namespaces, then imported
* commands were created that refer back to this command. Delete these
* imported commands now.
*/
for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
refPtr = nextRefPtr) {
nextRefPtr = refPtr->nextPtr;
importCmd = (Tcl_Command) refPtr->importedCmdPtr;
Tcl_DeleteCommandFromToken(interp, importCmd);
}
/*
* Don't use hPtr to delete the hash entry here, because it's
* possible that the deletion callback renamed the command.
* Instead, use cmdPtr->hptr, and make sure that no-one else
* has already deleted the hash entry.
*/
if (cmdPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(cmdPtr->hPtr);
}
/*
* Mark the Command structure as no longer valid. This allows
* TclExecuteByteCode to recognize when a Command has logically been
* deleted and a pointer to this Command structure cached in a CmdName
* object is invalid. TclExecuteByteCode will look up the command again
* in the interpreter's command hashtable.
*/
cmdPtr->objProc = NULL;
/*
* Now free the Command structure, unless there is another reference to
* it from a CmdName Tcl object in some ByteCode code sequence. In that
* case, delay the cleanup until all references are either discarded
* (when a ByteCode is freed) or replaced by a new reference (when a
* cached CmdName Command reference is found to be invalid and
* TclExecuteByteCode looks up the command in the command hashtable).
*/
TclCleanupCommand(cmdPtr);
return 0;
}
static char *
CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
Interp *iPtr; /* Interpreter containing command. */
Command *cmdPtr; /* Command whose traces are to be
* invoked. */
CONST char *oldName; /* Command's old name, or NULL if we
* must get the name from cmdPtr */
CONST char *newName; /* Command's new name, or NULL if
* the command is not being renamed */
int flags; /* Flags indicating the type of traces
* to trigger, either TCL_TRACE_DELETE
* or TCL_TRACE_RENAME. */
{
register CommandTrace *tracePtr;
ActiveCommandTrace active;
char *result;
Tcl_Obj *oldNamePtr = NULL;
int mask = (TCL_TRACE_DELETE | TCL_TRACE_RENAME); /* Safety */
flags &= mask;
if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
/*
* While a rename trace is active, we will not process any more
* rename traces; while a delete trace is active we will never
* reach here -- because Tcl_DeleteCommandFromToken checks for the
* condition (cmdPtr->flags & CMD_IS_DELETED) and returns immediately
* when a command deletion is in progress. For all other traces,
* delete traces will not be invoked but a call to TraceCommandProc
* will ensure that tracePtr->clientData is freed whenever the
* command "oldName" is deleted.
*/
if (cmdPtr->flags & TCL_TRACE_RENAME) {
flags &= ~TCL_TRACE_RENAME;
}
if (flags == 0) {
return NULL;
}
}
cmdPtr->flags |= CMD_TRACE_ACTIVE;
cmdPtr->refCount++;
result = NULL;
active.nextPtr = iPtr->activeCmdTracePtr;
active.reverseScan = 0;
iPtr->activeCmdTracePtr = &active;
if (flags & TCL_TRACE_DELETE) {
flags |= TCL_TRACE_DESTROYED;
}
active.cmdPtr = cmdPtr;
Tcl_Preserve((ClientData) iPtr);
for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
int traceFlags = (tracePtr->flags & mask);
active.nextTracePtr = tracePtr->nextPtr;
if (!(traceFlags & flags)) {
continue;
}
cmdPtr->flags |= traceFlags;
if (oldName == NULL) {
TclNewObj(oldNamePtr);
Tcl_IncrRefCount(oldNamePtr);
Tcl_GetCommandFullName((Tcl_Interp *) iPtr,
(Tcl_Command) cmdPtr, oldNamePtr);
oldName = TclGetString(oldNamePtr);
}
tracePtr->refCount++;
(*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, oldName, newName, flags);
cmdPtr->flags &= ~traceFlags;
if ((--tracePtr->refCount) <= 0) {
ckfree((char*)tracePtr);
}
}
/*
* If a new object was created to hold the full oldName,
* free it now.
*/
if (oldNamePtr != NULL) {
TclDecrRefCount(oldNamePtr);
}
/*
* Restore the variable's flags, remove the record of our active
* traces, and then return.
*/
cmdPtr->flags &= ~CMD_TRACE_ACTIVE;
cmdPtr->refCount--;
iPtr->activeCmdTracePtr = active.nextPtr;
Tcl_Release((ClientData) iPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* TclCleanupCommand --
*
* This procedure frees up a Command structure unless it is still
* referenced from an interpreter's command hashtable or from a CmdName
* Tcl object representing the name of a command in a ByteCode
* instruction sequence.
*
* Results:
* None.
*
* Side effects:
* Memory gets freed unless a reference to the Command structure still
* exists. In that case the cleanup is delayed until the command is
* deleted or when the last ByteCode referring to it is freed.
*
*----------------------------------------------------------------------
*/
void
TclCleanupCommand(cmdPtr)
register Command *cmdPtr; /* Points to the Command structure to
* be freed. */
{
cmdPtr->refCount--;
if (cmdPtr->refCount <= 0) {
ckfree((char *) cmdPtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateMathFunc --
*
* Creates a new math function for expressions in a given
* interpreter.
*
* Results:
* None.
*
* Side effects:
* The function defined by "name" is created or redefined. If the
* function already exists then its definition is replaced; this
* includes the builtin functions. Redefining a builtin function forces
* all existing code to be invalidated since that code may be compiled
* using an instruction specific to the replaced function. In addition,
* redefioning a non-builtin function will force existing code to be
* invalidated if the number of arguments has changed.
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which function is
* to be available. */
CONST char *name; /* Name of function (e.g. "sin"). */
int numArgs; /* Nnumber of arguments required by
* function. */
Tcl_ValueType *argTypes; /* Array of types acceptable for
* each argument. */
Tcl_MathProc *proc; /* Procedure that implements the
* math function. */
ClientData clientData; /* Additional value to pass to the
* function. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
MathFunc *mathFuncPtr;
int new, i;
hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
if (new) {
Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
}
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
if (!new) {
if (mathFuncPtr->builtinFuncIndex >= 0) {
/*
* We are redefining a builtin math function. Invalidate the
* interpreter's existing code by incrementing its
* compileEpoch member. This field is checked in Tcl_EvalObj
* and ObjInterpProc, and code whose compilation epoch doesn't
* match is recompiled. Newly compiled code will no longer
* treat the function as builtin.
*/
iPtr->compileEpoch++;
} else {
/*
* A non-builtin function is being redefined. We must invalidate
* existing code if the number of arguments has changed. This
* is because existing code was compiled assuming that number.
*/
if (numArgs != mathFuncPtr->numArgs) {
iPtr->compileEpoch++;
}
}
}
mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */
if (numArgs > MAX_MATH_ARGS) {
numArgs = MAX_MATH_ARGS;
}
mathFuncPtr->numArgs = numArgs;
for (i = 0; i < numArgs; i++) {
mathFuncPtr->argTypes[i] = argTypes[i];
}
mathFuncPtr->proc = proc;
mathFuncPtr->clientData = clientData;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetMathFuncInfo --
*
* Discovers how a particular math function was created in a given
* interpreter.
*
* Results:
* TCL_OK if it succeeds, TCL_ERROR else (leaving an error message
* in the interpreter result if that happens.)
*
* Side effects:
* If this function succeeds, the variables pointed to by the
* numArgsPtr and argTypePtr arguments will be updated to detail the
* arguments allowed by the function. The variable pointed to by the
* procPtr argument will be set to NULL if the function is a builtin
* function, and will be set to the address of the C function used to
* implement the math function otherwise (in which case the variable
* pointed to by the clientDataPtr argument will also be updated.)
*
*----------------------------------------------------------------------
*/
int
Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr,
clientDataPtr)
Tcl_Interp *interp;
CONST char *name;
int *numArgsPtr;
Tcl_ValueType **argTypesPtr;
Tcl_MathProc **procPtr;
ClientData *clientDataPtr;
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
MathFunc *mathFuncPtr;
Tcl_ValueType *argTypes;
int i,numArgs;
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"math function \"", name, "\" not known in this interpreter",
(char *) NULL);
return TCL_ERROR;
}
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
*numArgsPtr = numArgs = mathFuncPtr->numArgs;
if (numArgs == 0) {
/* Avoid doing zero-sized allocs... */
numArgs = 1;
}
*argTypesPtr = argTypes =
(Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType));
for (i = 0; i < mathFuncPtr->numArgs; i++) {
argTypes[i] = mathFuncPtr->argTypes[i];
}
if (mathFuncPtr->builtinFuncIndex == -1) {
*procPtr = (Tcl_MathProc *) NULL;
} else {
*procPtr = mathFuncPtr->proc;
*clientDataPtr = mathFuncPtr->clientData;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListMathFuncs --
*
* Produces a list of all the math functions defined in a given
* interpreter.
*
* Results:
* A pointer to a Tcl_Obj structure with a reference count of zero,
* or NULL in the case of an error (in which case a suitable error
* message will be left in the interpreter result.)
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ListMathFuncs(interp, pattern)
Tcl_Interp *interp;
CONST char *pattern;
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *resultList = Tcl_NewObj();
register Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
CONST char *name;
for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr);
if ((pattern == NULL || Tcl_StringMatch(name, pattern)) &&
/* I don't expect this to fail, but... */
Tcl_ListObjAppendElement(interp, resultList,
Tcl_NewStringObj(name,-1)) != TCL_OK) {
Tcl_DecrRefCount(resultList);
return NULL;
}
}
return resultList;
}
/*
*----------------------------------------------------------------------
*
* TclInterpReady --
*
* Check if an interpreter is ready to eval commands or scripts,
* i.e., if it was not deleted and if the nesting level is not
* too high.
*
* Results:
* The return value is TCL_OK if it the interpreter is ready,
* TCL_ERROR otherwise.
*
* Side effects:
* The interpreters object and string results are cleared.
*
*----------------------------------------------------------------------
*/
int
TclInterpReady(interp)
Tcl_Interp *interp;
{
register Interp *iPtr = (Interp *) interp;
/*
* Reset both the interpreter's string and object results and clear
* out any previous error information.
*/
Tcl_ResetResult(interp);
/*
* If the interpreter has been deleted, return an error.
*/
if (iPtr->flags & DELETED) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"attempt to call eval in deleted interpreter", -1);
Tcl_SetErrorCode(interp, "CORE", "IDELETE",
"attempt to call eval in deleted interpreter",
(char *) NULL);
return TCL_ERROR;
}
/*
* Check depth of nested calls to Tcl_Eval: if this gets too large,
* it's probably because of an infinite loop somewhere.
*/
if (((iPtr->numLevels) > iPtr->maxNestingDepth)
|| (TclpCheckStackSpace() == 0)) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"too many nested evaluations (infinite loop?)", -1);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclEvalObjvInternal --
*
* This procedure evaluates a Tcl command that has already been
* parsed into words, with one Tcl_Obj holding each word. The caller
* is responsible for managing the iPtr->numLevels.
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR. A result or error message is left in
* interp's result. If an error occurs, this procedure does
* NOT add any information to the errorInfo variable.
*
* Side effects:
* Depends on the command.
*
*----------------------------------------------------------------------
*/
int
TclEvalObjvInternal(interp, objc, objv, command, length, flags)
Tcl_Interp *interp; /* Interpreter in which to evaluate the
* command. Also used for error
* reporting. */
int objc; /* Number of words in command. */
Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
* the words that make up the command. */
CONST char *command; /* Points to the beginning of the string
* representation of the command; this
* is used for traces. If the string
* representation of the command is
* unknown, an empty string should be
* supplied. If it is NULL, no traces will
* be called. */
int length; /* Number of bytes in command; if -1, all
* characters up to the first null byte are
* used. */
int flags; /* Collection of OR-ed bits that control
* the evaluation of the script. Only
* TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
* currently supported. */
{
Command *cmdPtr;
Interp *iPtr = (Interp *) interp;
Tcl_Obj **newObjv;
int i;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int code = TCL_OK;
int traceCode = TCL_OK;
int checkTraces = 1;
Namespace *savedNsPtr = NULL;
if (TclInterpReady(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (objc == 0) {
return TCL_OK;
}
/*
* If any execution traces rename or delete the current command,
* we may need (at most) two passes here.
*/
savedVarFramePtr = iPtr->varFramePtr;
while (1) {
/* Configure evaluation context to match the requested flags */
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = NULL;
} else if ((flags & TCL_EVAL_INVOKE) && iPtr->varFramePtr) {
savedNsPtr = iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = iPtr->globalNsPtr;
}
/*
* Find the procedure to execute this command. If there isn't one,
* then see if there is a command "unknown". If so, create a new
* word array with "unknown" as the first word and the original
* command words as arguments. Then call ourselves recursively
* to execute it.
*/
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
if (cmdPtr == NULL) {
newObjv = (Tcl_Obj **) ckalloc((unsigned)
((objc + 1) * sizeof (Tcl_Obj *)));
for (i = objc-1; i >= 0; i--) {
newObjv[i+1] = objv[i];
}
newObjv[0] = Tcl_NewStringObj("::unknown", -1);
Tcl_IncrRefCount(newObjv[0]);
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
if (cmdPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid command name \"", Tcl_GetString(objv[0]), "\"",
(char *) NULL);
code = TCL_ERROR;
} else {
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objc+1, newObjv,
command, length, 0);
iPtr->numLevels--;
}
Tcl_DecrRefCount(newObjv[0]);
ckfree((char *) newObjv);
if (savedNsPtr) {
iPtr->varFramePtr->nsPtr = savedNsPtr;
}
goto done;
}
if (savedNsPtr) {
iPtr->varFramePtr->nsPtr = savedNsPtr;
}
/*
* Call trace procedures if needed.
*/
if ((checkTraces) && (command != NULL)) {
int cmdEpoch = cmdPtr->cmdEpoch;
int newEpoch;
cmdPtr->refCount++;
/*
* If the first set of traces modifies/deletes the command or
* any existing traces, then the set checkTraces to 0 and
* go through this while loop one more time.
*/
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
}
if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& (traceCode == TCL_OK)) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
}
newEpoch = cmdPtr->cmdEpoch;
TclCleanupCommand(cmdPtr);
if (cmdEpoch != newEpoch) {
/* The command has been modified in some way */
checkTraces = 0;
continue;
}
}
break;
}
#ifdef USE_DTRACE
if (TCL_DTRACE_CMD_ARGS_ENABLED()) {
char *a[10];
int i = 0;
while (i < 10) {
a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
}
TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
a[8], a[9]);
}
#endif /* USE_DTRACE */
/*
* Finally, invoke the command's Tcl_ObjCmdProc.
*/
cmdPtr->refCount++;
iPtr->cmdCount++;
if ( code == TCL_OK && traceCode == TCL_OK) {
if (TCL_DTRACE_CMD_ENTRY_ENABLED()) {
TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1,
(Tcl_Obj **)(objv + 1));
}
code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
if (TCL_DTRACE_CMD_RETURN_ENABLED()) {
TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code);
}
}
if (Tcl_AsyncReady()) {
code = Tcl_AsyncInvoke(interp, code);
}
/*
* Call 'leave' command traces
*/
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
int saveErrFlags = iPtr->flags
& (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
traceCode = TclCheckExecutionTraces (interp, command, length,
cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
if (traceCode == TCL_OK) {
iPtr->flags |= saveErrFlags;
}
}
TclCleanupCommand(cmdPtr);
/*
* If one of the trace invocation resulted in error, then
* change the result code accordingly. Note, that the
* interp->result should already be set correctly by the
* call to TraceExecutionProc.
*/
if (traceCode != TCL_OK) {
code = traceCode;
}
/*
* If the interpreter has a non-empty string result, the result
* object is either empty or stale because some procedure set
* interp->result directly. If so, move the string result to the
* result object, then reset the string result.
*/
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
#ifdef USE_DTRACE
if (TCL_DTRACE_CMD_RESULT_ENABLED()) {
Tcl_Obj *r;
r = Tcl_GetObjResult(interp);
TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r), r);
}
#endif /* USE_DTRACE */
done:
iPtr->varFramePtr = savedVarFramePtr;
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalObjv --
*
* This procedure evaluates a Tcl command that has already been
* parsed into words, with one Tcl_Obj holding each word.
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR. A result or error message is left in
* interp's result.
*
* Side effects:
* Depends on the command.
*
*----------------------------------------------------------------------
*/
int
Tcl_EvalObjv(interp, objc, objv, flags)
Tcl_Interp *interp; /* Interpreter in which to evaluate the
* command. Also used for error
* reporting. */
int objc; /* Number of words in command. */
Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
* the words that make up the command. */
int flags; /* Collection of OR-ed bits that control
* the evaluation of the script. Only
* TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE
* are currently supported. */
{
Interp *iPtr = (Interp *)interp;
Trace *tracePtr;
Tcl_DString cmdBuf;
char *cmdString = ""; /* A command string is only necessary for
* command traces or error logs; it will be
* generated to replace this default value if
* necessary. */
int cmdLen = 0; /* a non-zero value indicates that a command
* string was generated. */
int code = TCL_OK;
int i;
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) {
/*
* The command may be needed for an execution trace. Generate a
* command string.
*/
Tcl_DStringInit(&cmdBuf);
for (i = 0; i < objc; i++) {
Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
}
cmdString = Tcl_DStringValue(&cmdBuf);
cmdLen = Tcl_DStringLength(&cmdBuf);
break;
}
}
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags);
iPtr->numLevels--;
/*
* If we are again at the top level, process any unusual
* return code returned by the evaluated code.
*/
if (iPtr->numLevels == 0) {
if (code == TCL_RETURN) {
code = TclUpdateReturnInfo(iPtr);
}
if ((code != TCL_OK) && (code != TCL_ERROR)
&& !allowExceptions) {
ProcessUnexpectedResult(interp, code);
code = TCL_ERROR;
}
}
if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {
/*
* If there was an error, a command string will be needed for the
* error log: generate it now if it was not done previously.
*/
if (cmdLen == 0) {
Tcl_DStringInit(&cmdBuf);
for (i = 0; i < objc; i++) {
Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
}
cmdString = Tcl_DStringValue(&cmdBuf);
cmdLen = Tcl_DStringLength(&cmdBuf);
}
Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
}
if (cmdLen != 0) {
Tcl_DStringFree(&cmdBuf);
}
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LogCommandInfo --
*
* This procedure is invoked after an error occurs in an interpreter.
* It adds information to the "errorInfo" variable to describe the
* command that was being executed when the error occurred.
*
* Results:
* None.
*
* Side effects:
* Information about the command is added to errorInfo and the
* line number stored internally in the interpreter is set. If this
* is the first call to this procedure or Tcl_AddObjErrorInfo since
* an error occurred, then old information in errorInfo is
* deleted.
*
*----------------------------------------------------------------------
*/
void
Tcl_LogCommandInfo(interp, script, command, length)
Tcl_Interp *interp; /* Interpreter in which to log information. */
CONST char *script; /* First character in script containing
* command (must be <= command). */
CONST char *command; /* First character in command that
* generated the error. */
int length; /* Number of bytes in command (-1 means
* use all bytes up to first null byte). */
{
char buffer[200];
register CONST char *p;
char *ellipsis = "";
Interp *iPtr = (Interp *) interp;
if (iPtr->flags & ERR_ALREADY_LOGGED) {
/*
* Someone else has already logged error information for this
* command; we shouldn't add anything more.
*/
return;
}
/*
* Compute the line number where the error occurred.
*/
iPtr->errorLine = 1;
for (p = script; p != command; p++) {
if (*p == '\n') {
iPtr->errorLine++;
}
}
/*
* Create an error message to add to errorInfo, including up to a
* maximum number of characters of the command.
*/
if (length < 0) {
length = strlen(command);
}
if (length > 150) {
length = 150;
ellipsis = "...";
}
while ( (command[length] & 0xC0) == 0x80 ) {
/*
* Back up truncation point so that we don't truncate in the
* middle of a multi-byte character (in UTF-8)
*/
length--;
ellipsis = "...";
}
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
sprintf(buffer, "\n while executing\n\"%.*s%s\"",
length, command, ellipsis);
} else {
sprintf(buffer, "\n invoked from within\n\"%.*s%s\"",
length, command, ellipsis);
}
Tcl_AddObjErrorInfo(interp, buffer, -1);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalTokensStandard, EvalTokensStandard --
*
* Given an array of tokens parsed from a Tcl command (e.g., the
* tokens that make up a word or the index for an array variable)
* this procedure evaluates the tokens and concatenates their
* values to form a single result value.
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR. A result or error message is left in
* interp's result.
*
* Side effects:
* Depends on the array of tokens being evaled.
*
* TIP #280 : Keep public API, internally extended API.
*----------------------------------------------------------------------
*/
int
Tcl_EvalTokensStandard(interp, tokenPtr, count)
Tcl_Interp *interp; /* Interpreter in which to lookup
* variables, execute nested commands,
* and report errors. */
Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
* to evaluate and concatenate. */
int count; /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
{
#ifdef TCL_TIP280
return EvalTokensStandard (interp, tokenPtr, count, 1, NULL, NULL);
}
static int
EvalTokensStandard(interp, tokenPtr, count, line, clNextOuter, outerScript)
Tcl_Interp *interp; /* Interpreter in which to lookup
* variables, execute nested commands,
* and report errors. */
Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
* to evaluate and concatenate. */
int count; /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
int line; /* The line the script starts on. */
int* clNextOuter; /* Information about an outer context for */
CONST char* outerScript; /* continuation line data. This is set by
* EvalEx() to properly handle [...]-nested
* commands. The 'outerScript' refers to the
* most-outer script containing the embedded
* command, which is refered to by 'script'. The
* 'clNextOuter' refers to the current entry in
* the table of continuation lines in this
* "master script", and the character offsets are
* relative to the 'outerScript' as well.
*
* If outerScript == script, then this call is for
* words in the outer-most script/command. See
* Tcl_EvalEx() and TclEvalObjEx() for the places
* generating arguments for which this is true.
*/
{
#endif
Tcl_Obj *resultPtr, *indexPtr, *valuePtr;
char buffer[TCL_UTF_MAX];
#ifdef TCL_MEM_DEBUG
# define MAX_VAR_CHARS 5
#else
# define MAX_VAR_CHARS 30
#endif
char nameBuffer[MAX_VAR_CHARS+1];
char *varName, *index;
CONST char *p = NULL; /* Initialized to avoid compiler warning. */
int length, code;
#ifdef TCL_TIP280
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL, i, adjust;
int* clPosition = NULL;
Interp* iPtr = (Interp*) interp;
int inFile = iPtr->evalFlags & TCL_EVAL_FILE;
#endif
/*
* The only tricky thing about this procedure is that it attempts to
* avoid object creation and string copying whenever possible. For
* example, if the value is just a nested command, then use the
* command's result object directly.
*/
code = TCL_OK;
resultPtr = NULL;
Tcl_ResetResult(interp);
#ifdef TCL_TIP280
/*
* For the handling of continuation lines in literals we first check if
* this is actually a literal. For if not we can forego the additional
* processing. Otherwise we pre-allocate a small table to store the
* locations of all continuation lines we find in this literal, if
* any. The table is extended if needed.
*/
numCL = 0;
maxNumCL = 0;
isLiteral = 1;
for (i=0 ; i < count; i++) {
if ((tokenPtr[i].type != TCL_TOKEN_TEXT) &&
(tokenPtr[i].type != TCL_TOKEN_BS)) {
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
clPosition = (int*) ckalloc (maxNumCL*sizeof(int));
}
adjust = 0;
#endif
for ( ; count > 0; count--, tokenPtr++) {
valuePtr = NULL;
/*
* The switch statement below computes the next value to be
* concat to the result, as either a range of text or an
* object.
*/
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
p = tokenPtr->start;
length = tokenPtr->size;
break;
case TCL_TOKEN_BS:
length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
(int *) NULL, buffer);
p = buffer;
#ifdef TCL_TIP280
/*
* If the backslash sequence we found is in a literal, and
* represented a continuation line, we compute and store its
* location (as char offset to the beginning of the _result_
* script). We may have to extend the table of locations.
*
* Note that the continuation line information is relevant
* even if the word we are processing is not a literal, as it
* can affect nested commands. See the branch for
* TCL_TOKEN_COMMAND below, where the adjustment we are
* tracking here is taken into account. The good thing is that
* we do not need a table of everything, just the number of
* lines we have to add as correction.
*/
if ((length == 1) && (buffer[0] == ' ') &&
(tokenPtr->start[1] == '\n')) {
if (isLiteral) {
int clPos;
if (resultPtr == 0) {
clPos = 0;
} else {
Tcl_GetStringFromObj(resultPtr, &clPos);
}
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = (int*) ckrealloc ((char*)clPosition,
maxNumCL*sizeof(int));
}
clPosition[numCL] = clPos;
numCL ++;
}
adjust ++;
}
#endif
break;
case TCL_TOKEN_COMMAND: {
Interp *iPtr = (Interp *) interp;
iPtr->numLevels++;
code = TclInterpReady(interp);
if (code == TCL_OK) {
#ifndef TCL_TIP280
code = Tcl_EvalEx(interp,
tokenPtr->start+1, tokenPtr->size-2, 0);
#else
/* TIP #280: Transfer line information to nested command */
TclAdvanceContinuations (&line, &clNextOuter,
tokenPtr->start - outerScript);
code = EvalEx(interp,
tokenPtr->start+1, tokenPtr->size-2, 0,
line + adjust, clNextOuter, outerScript);
/*
* Restore flag reset by the nested eval for future
* bracketed commands and their CmdFrame setup
*/
if (inFile) {
iPtr->evalFlags |= TCL_EVAL_FILE;
}
#endif
}
iPtr->numLevels--;
if (code != TCL_OK) {
goto done;
}
valuePtr = Tcl_GetObjResult(interp);
break;
}
case TCL_TOKEN_VARIABLE:
if (tokenPtr->numComponents == 1) {
indexPtr = NULL;
index = NULL;
} else {
#ifndef TCL_TIP280
code = Tcl_EvalTokensStandard(interp, tokenPtr+2,
tokenPtr->numComponents - 1);
#else
/* TIP #280: Transfer line information to nested command */
code = EvalTokensStandard(interp, tokenPtr+2,
tokenPtr->numComponents - 1, line, NULL, NULL);
#endif
if (code != TCL_OK) {
goto done;
}
indexPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(indexPtr);
index = Tcl_GetString(indexPtr);
}
/*
* We have to make a copy of the variable name in order
* to have a null-terminated string. We can't make a
* temporary modification to the script to null-terminate
* the name, because a trace callback might potentially
* reuse the script and be affected by the null character.
*/
if (tokenPtr[1].size <= MAX_VAR_CHARS) {
varName = nameBuffer;
} else {
varName = ckalloc((unsigned) (tokenPtr[1].size + 1));
}
strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size);
varName[tokenPtr[1].size] = 0;
valuePtr = Tcl_GetVar2Ex(interp, varName, index,
TCL_LEAVE_ERR_MSG);
if (varName != nameBuffer) {
ckfree(varName);
}
if (indexPtr != NULL) {
Tcl_DecrRefCount(indexPtr);
}
if (valuePtr == NULL) {
code = TCL_ERROR;
goto done;
}
count -= tokenPtr->numComponents;
tokenPtr += tokenPtr->numComponents;
break;
default:
panic("unexpected token type in Tcl_EvalTokensStandard");
}
/*
* If valuePtr isn't NULL, the next piece of text comes from that
* object; otherwise, take length bytes starting at p.
*/
if (resultPtr == NULL) {
if (valuePtr != NULL) {
resultPtr = valuePtr;
} else {
resultPtr = Tcl_NewStringObj(p, length);
}
Tcl_IncrRefCount(resultPtr);
} else {
if (Tcl_IsShared(resultPtr)) {
Tcl_DecrRefCount(resultPtr);
resultPtr = Tcl_DuplicateObj(resultPtr);
Tcl_IncrRefCount(resultPtr);
}
if (valuePtr != NULL) {
p = Tcl_GetStringFromObj(valuePtr, &length);
}
Tcl_AppendToObj(resultPtr, p, length);
}
}
if (resultPtr != NULL) {
Tcl_SetObjResult(interp, resultPtr);
#ifdef TCL_TIP280
/*
* If the code found continuation lines (which implies that this word
* is a literal), then we store the accumulated table of locations in
* the thread-global data structure for the bytecode compiler to find
* later, assuming that the literal is a script which will be
* compiled.
*/
if (numCL) {
TclContinuationsEnter(resultPtr, numCL, clPosition);
}
/*
* Release the temp table we used to collect the locations of
* continuation lines, if any.
*/
if (maxNumCL) {
ckfree ((char*) clPosition);
}
#endif
} else {
code = TCL_ERROR;
}
done:
if (resultPtr != NULL) {
Tcl_DecrRefCount(resultPtr);
}
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalTokens --
*
* Given an array of tokens parsed from a Tcl command (e.g., the
* tokens that make up a word or the index for an array variable)
* this procedure evaluates the tokens and concatenates their
* values to form a single result value.
*
* Results:
* The return value is a pointer to a newly allocated Tcl_Obj
* containing the value of the array of tokens. The reference
* count of the returned object has been incremented. If an error
* occurs in evaluating the tokens then a NULL value is returned
* and an error message is left in interp's result.
*
* Side effects:
* A new object is allocated to hold the result.
*
*----------------------------------------------------------------------
*
* This uses a non-standard return convention; its use is now deprecated.
* It is a wrapper for the new function Tcl_EvalTokensStandard, and is not
* used in the core any longer. It is only kept for backward compatibility.
*/
Tcl_Obj *
Tcl_EvalTokens(interp, tokenPtr, count)
Tcl_Interp *interp; /* Interpreter in which to lookup
* variables, execute nested commands,
* and report errors. */
Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
* to evaluate and concatenate. */
int count; /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
{
int code;
Tcl_Obj *resPtr;
code = Tcl_EvalTokensStandard(interp, tokenPtr, count);
if (code == TCL_OK) {
resPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resPtr);
Tcl_ResetResult(interp);
return resPtr;
} else {
return NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalEx, EvalEx --
*
* This procedure evaluates a Tcl script without using the compiler
* or byte-code interpreter. It just parses the script, creates
* values for each word of each command, then calls EvalObjv
* to execute each command.
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR. A result or error message is left in
* interp's result.
*
* Side effects:
* Depends on the script.
*
* TIP #280 : Keep public API, internally extended API.
*----------------------------------------------------------------------
*/
int
Tcl_EvalEx(interp, script, numBytes, flags)
Tcl_Interp *interp; /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
CONST char *script; /* First character of script to evaluate. */
int numBytes; /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
int flags; /* Collection of OR-ed bits that control
* the evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently
* supported. */
{
#ifdef TCL_TIP280
return EvalEx (interp, script, numBytes, flags, 1, NULL, script);
}
static int
EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript)
Tcl_Interp *interp; /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
CONST char *script; /* First character of script to evaluate. */
int numBytes; /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
int flags; /* Collection of OR-ed bits that control
* the evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently
* supported. */
int line; /* The line the script starts on. */
int* clNextOuter; /* Information about an outer context for */
CONST char* outerScript; /* continuation line data. This is set only in
* EvalTokensStandard(), to properly handle
* [...]-nested commands. The 'outerScript'
* refers to the most-outer script containing the
* embedded command, which is refered to by
* 'script'. The 'clNextOuter' refers to the
* current entry in the table of continuation
* lines in this "master script", and the
* character offsets are relative to the
* 'outerScript' as well.
*
* If outerScript == script, then this call is
* for the outer-most script/command. See
* Tcl_EvalEx() and TclEvalObjEx() for places
* generating arguments for which this is true.
*/
{
#endif
Interp *iPtr = (Interp *) interp;
CONST char *p, *next;
Tcl_Parse parse;
#define NUM_STATIC_OBJS 20
Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
Tcl_Token *tokenPtr;
int code = TCL_OK;
int i, commandLength, bytesLeft, nested;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
/*
* The variables below keep track of how much state has been
* allocated while evaluating the script, so that it can be freed
* properly if an error occurs.
*/
int gotParse = 0, objectsUsed = 0;
#ifdef TCL_TIP280
/* TIP #280 Structures for tracking of command locations. */
CmdFrame eeFrame;
/*
* Pointer for the tracking of invisible continuation lines. Initialized
* only if the caller gave us a table of locations to track, via
* scriptCLLocPtr. It always refers to the table entry holding the
* location of the next invisible continuation line to look for, while
* parsing the script.
*/
int* clNext = NULL;
if (iPtr->scriptCLLocPtr) {
if (clNextOuter) {
clNext = clNextOuter;
} else {
clNext = &iPtr->scriptCLLocPtr->loc[0];
}
}
#endif
if (numBytes < 0) {
numBytes = strlen(script);
}
Tcl_ResetResult(interp);
savedVarFramePtr = iPtr->varFramePtr;
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = NULL;
}
/*
* Each iteration through the following loop parses the next
* command from the script and then executes it.
*/
objv = staticObjArray;
p = script;
bytesLeft = numBytes;
if (iPtr->evalFlags & TCL_BRACKET_TERM) {
nested = 1;
} else {
nested = 0;
}
#ifdef TCL_TIP280
/* TIP #280 Initialize tracking. Do not push on the frame stack yet. */
/*
* We may cont. counting based on a specific context (CTX), or open a new
* context, either for a sourced script, or 'eval'. For sourced files we
* always have a path object, even if nothing was specified in the interp
* itself. That makes code using it simpler as NULL checks can be left
* out. Sourced file without path in the 'scriptFile' is possible during
* Tcl initialization.
*/
if (iPtr->evalFlags & TCL_EVAL_CTX) {
/* Path information comes out of the context. */
eeFrame.type = TCL_LOCATION_SOURCE;
eeFrame.data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path;
Tcl_IncrRefCount (eeFrame.data.eval.path);
} else if (iPtr->evalFlags & TCL_EVAL_FILE) {
/* Set up for a sourced file */
eeFrame.type = TCL_LOCATION_SOURCE;
if (iPtr->scriptFile) {
/* Normalization here, to have the correct pwd. Should have
* negligible impact on performance, as the norm should have been
* done already by the 'source' invoking us, and it caches the
* result
*/
Tcl_Obj* norm = Tcl_FSGetNormalizedPath (interp, iPtr->scriptFile);
if (!norm) {
/* Error message in the interp result */
return TCL_ERROR;
}
eeFrame.data.eval.path = norm;
} else {
eeFrame.data.eval.path = Tcl_NewStringObj ("",-1);
}
Tcl_IncrRefCount (eeFrame.data.eval.path);
} else {
/* Set up for plain eval */
eeFrame.type = TCL_LOCATION_EVAL;
eeFrame.data.eval.path = NULL;
}
eeFrame.level = (iPtr->cmdFramePtr == NULL
? 1
: iPtr->cmdFramePtr->level + 1);
eeFrame.framePtr = iPtr->framePtr;
eeFrame.nextPtr = iPtr->cmdFramePtr;
eeFrame.nline = 0;
eeFrame.line = NULL;
#endif
iPtr->evalFlags = 0;
do {
if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse)
!= TCL_OK) {
code = TCL_ERROR;
goto error;
}
gotParse = 1;
if (nested && parse.term == (script + numBytes)) {
/*
* A nested script can only terminate in ']'. If
* the parsing got terminated at the end of the script,
* there was no closing ']'. Report the syntax error.
*/
code = TCL_ERROR;
goto error;
}
#ifdef TCL_TIP280
/*
* TIP #280 Track lines. The parser may have skipped text till it
* found the command we are now at. We have count the lines in this
* block, and do not forget invisible continuation lines.
*/
TclAdvanceLines (&line, p, parse.commandStart);
TclAdvanceContinuations (&line, &clNext,
parse.commandStart - outerScript);
#endif
if (parse.numWords > 0) {
#ifdef TCL_TIP280
/*
* TIP #280. Track lines within the words of the current
* command. We use a separate pointer into the table of
* continuation line locations to not lose our position for the
* per-command parsing.
*/
int wordLine = line;
CONST char* wordStart = parse.commandStart;
int* wordCLNext = clNext;
#endif
/*
* Generate an array of objects for the words of the command.
*/
if (parse.numWords <= NUM_STATIC_OBJS) {
objv = staticObjArray;
} else {
objv = (Tcl_Obj **) ckalloc((unsigned)
(parse.numWords * sizeof (Tcl_Obj *)));
}
#ifdef TCL_TIP280
eeFrame.nline = parse.numWords;
eeFrame.line = (int*) ckalloc((unsigned)
(parse.numWords * sizeof (int)));
#endif
for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
objectsUsed < parse.numWords;
objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
#ifndef TCL_TIP280
code = Tcl_EvalTokensStandard(interp, tokenPtr+1,
tokenPtr->numComponents);
#else
/*
* TIP #280. Track lines to current word. Save the
* information on a per-word basis, signaling dynamic words as
* needed. Make the information available to the recursively
* called evaluator as well, including the type of context
* (source vs. eval).
*/
TclAdvanceLines (&wordLine, wordStart, tokenPtr->start);
TclAdvanceContinuations (&wordLine, &wordCLNext,
tokenPtr->start - outerScript);
wordStart = tokenPtr->start;
eeFrame.line [objectsUsed] = (TclWordKnownAtCompileTime (tokenPtr)
? wordLine
: -1);
if (eeFrame.type == TCL_LOCATION_SOURCE) {
iPtr->evalFlags |= TCL_EVAL_FILE;
}
code = EvalTokensStandard(interp, tokenPtr+1,
tokenPtr->numComponents, wordLine,
wordCLNext, outerScript);
iPtr->evalFlags = 0;
#endif
if (code == TCL_OK) {
objv[objectsUsed] = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objv[objectsUsed]);
#ifdef TCL_TIP280
if (wordCLNext) {
TclContinuationsEnterDerived (objv[objectsUsed],
wordStart - outerScript, wordCLNext);
}
#endif
} else {
goto error;
}
}
/*
* Execute the command and free the objects for its words.
*
* TIP #280: Remember the command itself for 'info frame'. We
* shorten the visible command by one char to exclude the
* termination character, if necessary. Here is where we put our
* frame on the stack of frames too. _After_ the nested commands
* have been executed.
*/
#ifdef TCL_TIP280
eeFrame.cmd.str.cmd = parse.commandStart;
eeFrame.cmd.str.len = parse.commandSize;
if (parse.term == parse.commandStart + parse.commandSize - 1) {
eeFrame.cmd.str.len --;
}
TclArgumentEnter (interp, objv, objectsUsed, &eeFrame);
iPtr->cmdFramePtr = &eeFrame;
#endif
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objectsUsed, objv,
parse.commandStart, parse.commandSize, 0);
iPtr->numLevels--;
#ifdef TCL_TIP280
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
TclArgumentRelease (interp, objv, objectsUsed);
ckfree ((char*) eeFrame.line);
eeFrame.line = NULL;
eeFrame.nline = 0;
#endif
if (code != TCL_OK) {
goto error;
}
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
objectsUsed = 0;
if (objv != staticObjArray) {
ckfree((char *) objv);
objv = staticObjArray;
}
}
/*
* Advance to the next command in the script.
*
* TIP #280 Track Lines. Now we track how many lines were in the
* executed command.
*/
next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
#ifdef TCL_TIP280
TclAdvanceLines (&line, parse.commandStart, p);
#endif
Tcl_FreeParse(&parse);
gotParse = 0;
if (nested && (*parse.term == ']')) {
/*
* We get here in the special case where the TCL_BRACKET_TERM
* flag was set in the interpreter and the latest parsed command
* was terminated by the matching close-bracket we seek.
* Return immediately.
*/
iPtr->termOffset = (p - 1) - script;
iPtr->varFramePtr = savedVarFramePtr;
#ifndef TCL_TIP280
return TCL_OK;
#else
code = TCL_OK;
goto cleanup_return;
#endif
}
} while (bytesLeft > 0);
if (nested) {
/*
* This nested script did not terminate in ']', it is an error.
*/
code = TCL_ERROR;
goto error;
}
iPtr->termOffset = p - script;
iPtr->varFramePtr = savedVarFramePtr;
#ifndef TCL_TIP280
return TCL_OK;
#else
code = TCL_OK;
goto cleanup_return;
#endif
error:
/*
* Generate various pieces of error information, such as the line
* number where the error occurred and information to add to the
* errorInfo variable. Then free resources that had been allocated
* to the command.
*/
if (iPtr->numLevels == 0) {
if (code == TCL_RETURN) {
code = TclUpdateReturnInfo(iPtr);
}
if ((code != TCL_OK) && (code != TCL_ERROR)
&& !allowExceptions) {
ProcessUnexpectedResult(interp, code);
code = TCL_ERROR;
}
}
if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
commandLength = parse.commandSize;
if (parse.term == parse.commandStart + commandLength - 1) {
/*
* The terminator character (such as ; or ]) of the command where
* the error occurred is the last character in the parsed command.
* Reduce the length by one so that the error message doesn't
* include the terminator character.
*/
commandLength -= 1;
}
Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength);
}
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
if (gotParse) {
Tcl_FreeParse(&parse);
}
if (objv != staticObjArray) {
ckfree((char *) objv);
}
iPtr->varFramePtr = savedVarFramePtr;
/*
* All that's left to do before returning is to set iPtr->termOffset
* to point past the end of the script we just evaluated.
*/
next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
if (!nested) {
iPtr->termOffset = p - script;
#ifndef TCL_TIP280
return code;
#else
goto cleanup_return;
#endif
}
/*
* When we are nested (the TCL_BRACKET_TERM flag was set in the
* interpreter), we must find the matching close-bracket to
* end the script we are evaluating.
*
* When our return code is TCL_CONTINUE or TCL_RETURN, we want
* to correctly set iPtr->termOffset to point to that matching
* close-bracket so our caller can move to the part of the
* string beyond the script we were asked to evaluate.
* So we try to parse past the rest of the commands.
*/
next = NULL;
while (bytesLeft && (*parse.term != ']')) {
if (TCL_OK != Tcl_ParseCommand(NULL, p, bytesLeft, 1, &parse)) {
/*
* Syntax error. Set the termOffset to the beginning of
* the last command parsed.
*/
if (next == NULL) {
iPtr->termOffset = (parse.commandStart - 1) - script;
} else {
iPtr->termOffset = (next - 1) - script;
}
#ifndef TCL_TIP280
return code;
#else
goto cleanup_return;
#endif
}
next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
next = parse.commandStart;
Tcl_FreeParse(&parse);
}
if (bytesLeft) {
/*
* parse.term points to the close-bracket.
*/
iPtr->termOffset = parse.term - script;
} else if (parse.term == script + numBytes) {
/*
* There was no close-bracket. Syntax error.
*/
iPtr->termOffset = parse.term - script;
Tcl_SetObjResult(interp,
Tcl_NewStringObj("missing close-bracket", -1));
#ifndef TCL_TIP280
return TCL_ERROR;
#else
code = TCL_ERROR;
goto cleanup_return;
#endif
} else if (*parse.term != ']') {
/*
* There was no close-bracket. Syntax error.
*/
iPtr->termOffset = (parse.term + 1) - script;
Tcl_SetObjResult(interp,
Tcl_NewStringObj("missing close-bracket", -1));
#ifndef TCL_TIP280
return TCL_ERROR;
#else
code = TCL_ERROR;
goto cleanup_return;
#endif
} else {
/*
* parse.term points to the close-bracket.
*/
iPtr->termOffset = parse.term - script;
}
#ifdef TCL_TIP280
cleanup_return:
/* TIP #280. Release the local CmdFrame, and its contents. */
if (eeFrame.line != NULL) {
ckfree ((char*) eeFrame.line);
}
if (eeFrame.type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (eeFrame.data.eval.path);
}
#endif
return code;
}
#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
*
* TclAdvanceLines --
*
* This procedure is a helper which counts the number of lines
* in a block of text and advances an external counter.
*
* Results:
* None.
*
* Side effects:
* The specified counter is advanced per the number of lines found.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclAdvanceLines (line,start,end)
int* line;
CONST char* start;
CONST char* end;
{
CONST char* p;
for (p = start; p < end; p++) {
if (*p == '\n') {
(*line) ++;
}
}
}
/*
*----------------------------------------------------------------------
*
* TclAdvanceContinuations --
*
* This procedure is a helper which counts the number of continuation
* lines (CL) in a block of text using a table of CL locations and
* advances an external counter, and the pointer into the table.
*
* Results:
* None.
*
* Side effects:
* The specified counter is advanced per the number of continuation lines
* found.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclAdvanceContinuations (line,clNextPtrPtr,loc)
int* line;
int** clNextPtrPtr;
int loc;
{
/*
* Track the invisible continuation lines embedded in a script, if
* any. Here they are just spaces (already). They were removed by
* EvalTokensStandard() via TclParseBackslash().
*
* *clNextPtrPtr <=> We have continuation lines to track.
* **clNextPtrPtr >= 0 <=> We are not beyond the last possible location.
* loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line.
*/
while (*clNextPtrPtr && (**clNextPtrPtr >= 0) && (loc >= **clNextPtrPtr)) {
/*
* We just stepped over an invisible continuation line. Adjust the
* line counter and step to the table entry holding the location of
* the next continuation line to track.
*/
(*line) ++;
(*clNextPtrPtr) ++;
}
}
/*
*----------------------------------------------------------------------
* Note: The whole data structure access for argument location tracking is
* hidden behind these three functions. The only parts open are the lineLAPtr
* field in the Interp structure. The CFWord definition is internal to here.
* Should make it easier to redo the data structures if we find something more
* space/time efficient.
*/
/*
*----------------------------------------------------------------------
*
* TclArgumentEnter --
*
* This procedure is a helper for the TIP #280 uplevel extension.
* It enters location references for the arguments of a command to be
* invoked. Only the first entry has the actual data, further entries
* simply count the usage up.
*
* Results:
* None.
*
* Side effects:
* May allocate memory.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclArgumentEnter(interp,objv,objc,cfPtr)
Tcl_Interp* interp;
Tcl_Obj** objv;
int objc;
CmdFrame* cfPtr;
{
Interp* iPtr = (Interp*) interp;
int new, i;
Tcl_HashEntry* hPtr;
CFWord* cfwPtr;
for (i=1; i < objc; i++) {
/*
* Ignore argument words without line information (= dynamic). If
* they are variables they may have location information associated
* with that, either through globally recorded 'set' invokations, or
* literals in bytecode. Eitehr way there is no need to record
* something here.
*/
if (cfPtr->line [i] < 0) continue;
hPtr = Tcl_CreateHashEntry (iPtr->lineLAPtr, (char*) objv[i], &new);
if (new) {
/*
* The word is not on the stack yet, remember the current location
* and initialize references.
*/
cfwPtr = (CFWord*) ckalloc (sizeof (CFWord));
cfwPtr->framePtr = cfPtr;
cfwPtr->word = i;
cfwPtr->refCount = 1;
Tcl_SetHashValue (hPtr, cfwPtr);
} else {
/*
* The word is already on the stack, its current location is not
* relevant. Just remember the reference to prevent early removal.
*/
cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
cfwPtr->refCount ++;
}
}
}
/*
*----------------------------------------------------------------------
*
* TclArgumentRelease --
*
* This procedure is a helper for the TIP #280 uplevel extension.
* It removes the location references for the arguments of a command
* just done. Usage is counted down, the data is removed only when
* no user is left over.
*
* Results:
* None.
*
* Side effects:
* May release memory.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclArgumentRelease(interp,objv,objc)
Tcl_Interp* interp;
Tcl_Obj** objv;
int objc;
{
Interp* iPtr = (Interp*) interp;
Tcl_HashEntry* hPtr;
CFWord* cfwPtr;
int i;
for (i=1; i < objc; i++) {
hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) objv[i]);
if (!hPtr) { continue; }
cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
cfwPtr->refCount --;
if (cfwPtr->refCount > 0) { continue; }
ckfree ((char*) cfwPtr);
Tcl_DeleteHashEntry (hPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclArgumentBCEnter --
*
* This procedure is a helper for the TIP #280 uplevel extension.
* It enters location references for the literal arguments of commands
* in bytecode about to be executed. Only the first entry has the actual
* data, further entries simply count the usage up.
*
* Results:
* None.
*
* Side effects:
* May allocate memory.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclArgumentBCEnter(interp, objv, objc, codePtr, cfPtr, pc)
Tcl_Interp* interp;
Tcl_Obj* objv[];
int objc;
void* codePtr;
CmdFrame* cfPtr;
int pc;
{
Interp* iPtr = (Interp*) interp;
Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
if (hePtr) {
ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc);
if (hePtr) {
int word;
int cmd = (int) Tcl_GetHashValue(hePtr);
ECL* ePtr = &eclPtr->loc[cmd];
/*
* A few truths ...
* (1) ePtr->nline == objc
* (2) (ePtr->line[word] < 0) => !literal, for all words
* (3) (word == 0) => !literal
*
* Item (2) is why we can use objv to get the literals, and do not
* have to save them at compile time.
*/
for (word = 1; word < objc; word++) {
if (ePtr->line[word] >= 0) {
int isnew;
Tcl_HashEntry* hPtr =
Tcl_CreateHashEntry (iPtr->lineLABCPtr,
(char*) objv[word], &isnew);
CFWordBC* cfwPtr = (CFWordBC*) ckalloc (sizeof (CFWordBC));
cfwPtr->framePtr = cfPtr;
cfwPtr->pc = pc;
cfwPtr->word = word;
if (isnew) {
/*
* The word is not on the stack yet, remember the
* current location and initialize references.
*/
cfwPtr->prevPtr = NULL;
} else {
/*
* The object is already on the stack, however it may
* have a different location now (literal sharing may
* map multiple location to a single Tcl_Obj*. Save
* the old information in the new structure.
*/
cfwPtr->prevPtr = (CFWordBC*) Tcl_GetHashValue(hPtr);
}
Tcl_SetHashValue (hPtr, cfwPtr);
}
} /* for */
} /* if */
} /* if */
}
/*
*----------------------------------------------------------------------
*
* TclArgumentBCRelease --
*
* This procedure is a helper for the TIP #280 uplevel extension.
* It removes the location references for the literal arguments of
* commands in bytecode just done. Usage is counted down, the data
* is removed only when no user is left over.
*
* Results:
* None.
*
* Side effects:
* May release memory.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclArgumentBCRelease(interp, objv, objc, codePtr, pc)
Tcl_Interp* interp;
Tcl_Obj* objv[];
int objc;
void* codePtr;
int pc;
{
Interp* iPtr = (Interp*) interp;
Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
if (hePtr) {
ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc);
if (hePtr) {
int cmd = (int) Tcl_GetHashValue(hePtr);
ECL* ePtr = &eclPtr->loc[cmd];
int word;
/*
* Iterate in reverse order, to properly match our pop to the push
* in TclArgumentBCEnter().
*/
for (word = objc-1; word >= 1; word--) {
if (ePtr->line[word] >= 0) {
Tcl_HashEntry* hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr,
(char *) objv[word]);
if (hPtr) {
CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
if (cfwPtr->prevPtr) {
Tcl_SetHashValue(hPtr, cfwPtr->prevPtr);
} else {
Tcl_DeleteHashEntry(hPtr);
}
ckfree((char *) cfwPtr);
}
}
}
}
}
}
/*
*----------------------------------------------------------------------
*
* TclArgumentGet --
*
* This procedure is a helper for the TIP #280 uplevel extension.
* It find the location references for a Tcl_Obj, if any.
*
* Results:
* None.
*
* Side effects:
* Writes found location information into the result arguments.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclArgumentGet(interp,obj,cfPtrPtr,wordPtr)
Tcl_Interp* interp;
Tcl_Obj* obj;
CmdFrame** cfPtrPtr;
int* wordPtr;
{
Interp* iPtr = (Interp*) interp;
Tcl_HashEntry* hPtr;
CmdFrame* framePtr;
/*
* An object which either has no string rep guaranteed to have been
* generated dynamically: bail out, this cannot have a usable absolute
* location. _Do not touch_ the information the set up by the caller. It
* knows better than us.
*/
if (!obj->bytes) {
return;
}
/*
* First look for location information recorded in the argument
* stack. That is nearest.
*/
hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) obj);
if (hPtr) {
CFWord* cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
*wordPtr = cfwPtr->word;
*cfPtrPtr = cfwPtr->framePtr;
return;
}
/*
* Check if the Tcl_Obj has location information as a bytecode literal, in
* that stack.
*/
hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj);
if (hPtr) {
CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
framePtr = cfwPtr->framePtr;
framePtr->data.tebc.pc = (char*) ((ByteCode*)
framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc;
*cfPtrPtr = cfwPtr->framePtr;
*wordPtr = cfwPtr->word;
return;
}
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_Eval --
*
* Execute a Tcl command in a string. This procedure executes the
* script directly, rather than compiling it to bytecodes. Before
* the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was
* the main procedure used for executing Tcl commands, but nowadays
* it isn't used much.
*
* Results:
* The return value is one of the return codes defined in tcl.h
* (such as TCL_OK), and interp's result contains a value
* to supplement the return code. The value of the result
* will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
* you must copy it or lose it!
*
* Side effects:
* Can be almost arbitrary, depending on the commands in the script.
*
*----------------------------------------------------------------------
*/
int
Tcl_Eval(interp, string)
Tcl_Interp *interp; /* Token for command interpreter (returned
* by previous call to Tcl_CreateInterp). */
CONST char *string; /* Pointer to TCL command to execute. */
{
int code = Tcl_EvalEx(interp, string, -1, 0);
/*
* For backwards compatibility with old C code that predates the
* object system in Tcl 8.0, we have to mirror the object result
* back into the string result (some callers may expect it there).
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalObj, Tcl_GlobalEvalObj --
*
* These functions are deprecated but we keep them around for backwards
* compatibility reasons.
*
* Results:
* See the functions they call.
*
* Side effects:
* See the functions they call.
*
*----------------------------------------------------------------------
*/
#undef Tcl_EvalObj
int
Tcl_EvalObj(interp, objPtr)
Tcl_Interp * interp;
Tcl_Obj * objPtr;
{
return Tcl_EvalObjEx(interp, objPtr, 0);
}
#undef Tcl_GlobalEvalObj
int
Tcl_GlobalEvalObj(interp, objPtr)
Tcl_Interp * interp;
Tcl_Obj * objPtr;
{
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalObjEx, TclEvalObjEx --
*
* Execute Tcl commands stored in a Tcl object. These commands are
* compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
* is specified.
*
* Results:
* The return value is one of the return codes defined in tcl.h
* (such as TCL_OK), and the interpreter's result contains a value
* to supplement the return code.
*
* Side effects:
* The object is converted, if necessary, to a ByteCode object that
* holds the bytecode instructions for the commands. Executing the
* commands will almost certainly have side effects that depend
* on those commands.
*
* Just as in Tcl_Eval, interp->termOffset is set to the offset of the
* last character executed in the objPtr's string.
*
* TIP #280 : Keep public API, internally extended API.
*----------------------------------------------------------------------
*/
int
Tcl_EvalObjEx(interp, objPtr, flags)
Tcl_Interp *interp; /* Token for command interpreter
* (returned by a previous call to
* Tcl_CreateInterp). */
register Tcl_Obj *objPtr; /* Pointer to object containing
* commands to execute. */
int flags; /* Collection of OR-ed bits that
* control the evaluation of the
* script. Supported values are
* TCL_EVAL_GLOBAL and
* TCL_EVAL_DIRECT. */
{
#ifdef TCL_TIP280
return TclEvalObjEx (interp, objPtr, flags, NULL, 0);
}
int
TclEvalObjEx(interp, objPtr, flags, invoker, word)
Tcl_Interp *interp; /* Token for command interpreter
* (returned by a previous call to
* Tcl_CreateInterp). */
register Tcl_Obj *objPtr; /* Pointer to object containing
* commands to execute. */
int flags; /* Collection of OR-ed bits that
* control the evaluation of the
* script. Supported values are
* TCL_EVAL_GLOBAL and
* TCL_EVAL_DIRECT. */
CONST CmdFrame* invoker; /* Frame of the command doing the eval */
int word; /* Index of the word which is in objPtr */
{
#endif
register Interp *iPtr = (Interp *) interp;
char *script;
int numSrcBytes;
int result;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
Tcl_IncrRefCount(objPtr);
if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) {
/*
* We're not supposed to use the compiler or byte-code interpreter.
* Let Tcl_EvalEx evaluate the command directly (and probably
* more slowly).
*
* Pure List Optimization (no string representation). In this
* case, we can safely use Tcl_EvalObjv instead and get an
* appreciable improvement in execution speed. This is because it
* allows us to avoid a setFromAny step that would just pack
* everything into a string and back out again.
*
* USE_EVAL_DIRECT is a special flag used for testing purpose only
* (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
*/
if (!(iPtr->flags & USE_EVAL_DIRECT) &&
(objPtr->typePtr == &tclListType) && /* is a list... */
(objPtr->bytes == NULL) /* ...without a string rep */) {
register List *listRepPtr =
(List *) objPtr->internalRep.twoPtrValue.ptr1;
int i, objc = listRepPtr->elemCount;
#define TEOE_PREALLOC 10
Tcl_Obj *staticObjv[TEOE_PREALLOC], **objv = staticObjv;
#ifdef TCL_TIP280
/* TIP #280 Structures for tracking lines.
* As we know that this is dynamic execution we ignore the
* invoker, even if known.
*/
CmdFrame eoFrame;
eoFrame.type = TCL_LOCATION_EVAL_LIST;
eoFrame.level = (iPtr->cmdFramePtr == NULL ?
1 :
iPtr->cmdFramePtr->level + 1);
eoFrame.framePtr = iPtr->framePtr;
eoFrame.nextPtr = iPtr->cmdFramePtr;
eoFrame.nline = 0;
eoFrame.line = NULL;
/* NOTE: Getting the string rep of the list to eval to fill the
* command information required by 'info frame' implies that
* further calls for the same list would not be optimized, as it
* would not be 'pure' anymore. It would also be a waste of time
* as most of the time this information is not needed at all. What
* we do instead is to keep the list obj itself around and have
* 'info frame' sort it out.
*/
eoFrame.cmd.listPtr = objPtr;
Tcl_IncrRefCount (eoFrame.cmd.listPtr);
eoFrame.data.eval.path = NULL;
#endif
if (objc > TEOE_PREALLOC) {
objv = (Tcl_Obj **) ckalloc(objc*sizeof(Tcl_Obj *));
}
#undef TEOE_PREALLOC
/*
* Copy the list elements here, to avoid a segfault if
* objPtr loses its List internal rep [Bug 1119369].
*
* TIP #280 We do _not_ compute all the line numbers for the words
* in the command. For the eval of a pure list the most sensible
* choice is to put all words on line 1. Given that we neither
* need memory for them nor compute anything. 'line' is left
* NULL. The two places using this information (TclInfoFrame, and
* TclInitCompileEnv), are special-cased to use the proper line
* number directly instead of accessing the 'line' array.
*/
for (i=0; i < objc; i++) {
objv[i] = listRepPtr->elements[i];
Tcl_IncrRefCount(objv[i]);
}
#ifdef TCL_TIP280
iPtr->cmdFramePtr = &eoFrame;
#endif
result = Tcl_EvalObjv(interp, objc, objv, flags);
#ifdef TCL_TIP280
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
Tcl_DecrRefCount (eoFrame.cmd.listPtr);
#endif
for (i=0; i < objc; i++) {
TclDecrRefCount(objv[i]);
}
if (objv != staticObjv) {
ckfree((char *) objv);
}
#ifdef TCL_TIP280
ckfree ((char*) eoFrame.line);
eoFrame.line = NULL;
eoFrame.nline = 0;
#endif
} else {
#ifndef TCL_TIP280
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
#else
/*
* TIP #280. Propagate context as much as we can. Especially if
* the script to evaluate is a single literal it makes sense to
* look if our context is one with absolute line numbers we can
* then track into the literal itself too.
*
* See also tclCompile.c, TclInitCompileEnv, for the equivalent
* code in the bytecode compiler.
*/
/*
* Now we check if we have data about invisible continuation lines
* for the script, and make it available to the direct script
* parser and evaluator we are about to call, if so.
*
* It may be possible that the script Tcl_Obj* can be free'd while
* the evaluator is using it, leading to the release of the
* associated ContLineLoc structure as well. To ensure that the
* latter doesn't happen we set a lock on it. We release this lock
* later in this function, after the evaluator is done. The
* relevant "lineCLPtr" hashtable is managed in the file
* "tclObj.c".
*
* Another important action is to save (and later restore) the
* continuation line information of the caller, in case we are
* executing nested commands in the eval/direct path.
*/
ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr;
ContLineLoc* clLocPtr = TclContinuationsGet (objPtr);
if (clLocPtr) {
iPtr->scriptCLLocPtr = clLocPtr;
Tcl_Preserve (iPtr->scriptCLLocPtr);
} else {
iPtr->scriptCLLocPtr = NULL;
}
if (invoker == NULL) {
/* No context, force opening of our own */
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
} else {
/* We have an invoker, describing the command asking for the
* evaluation of a subordinate script. This script may
* originate in a literal word, or from a variable, etc. Using
* the line array we now check if we have good line
* information for the relevant word. The type of context is
* relevant as well. In a non-'source' context we don't have
* to try tracking lines.
*
* First see if the word exists and is a literal. If not we go
* through the easy dynamic branch. No need to perform more
* complex invokations.
*/
CmdFrame ctx = *invoker;
int pc = 0;
if (invoker->type == TCL_LOCATION_BC) {
/* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc (&ctx);
pc = 1;
}
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
if ((ctx.nline <= word) ||
(ctx.line[word] < 0) ||
(ctx.type != TCL_LOCATION_SOURCE)) {
/* Dynamic script, or dynamic context, force our own
* context */
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
} else {
/* Absolute context available to reuse. */
iPtr->invokeCmdFramePtr = &ctx;
iPtr->evalFlags |= TCL_EVAL_CTX;
result = EvalEx(interp, script, numSrcBytes, flags,
ctx.line [word], NULL, script);
}
if (pc && (ctx.type == TCL_LOCATION_SOURCE)) {
/* Death of SrcInfo reference. */
Tcl_DecrRefCount(ctx.data.eval.path);
}
}
/*
* Now release the lock on the continuation line information, if
* any, and restore the caller's settings.
*/
if (iPtr->scriptCLLocPtr) {
Tcl_Release (iPtr->scriptCLLocPtr);
}
iPtr->scriptCLLocPtr = saveCLLocPtr;
#endif
}
} else {
/*
* Let the compiler/engine subsystem do the evaluation.
*
* TIP #280 The invoker provides us with the context for the
* script. We transfer this to the byte code compiler.
*/
savedVarFramePtr = iPtr->varFramePtr;
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = NULL;
}
#ifndef TCL_TIP280
result = TclCompEvalObj(interp, objPtr);
#else
result = TclCompEvalObj(interp, objPtr, invoker, word);
#endif
/*
* If we are again at the top level, process any unusual
* return code returned by the evaluated code.
*/
if (iPtr->numLevels == 0) {
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
}
if ((result != TCL_OK) && (result != TCL_ERROR)
&& !allowExceptions) {
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
/*
* If an error was created here, record information about
* what was being executed when the error occurred. Remove
* the extra \n added by tclMain.c in the command sent to
* Tcl_LogCommandInfo [Bug 833150].
*/
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, --numSrcBytes);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
}
}
iPtr->evalFlags = 0;
iPtr->varFramePtr = savedVarFramePtr;
}
TclDecrRefCount(objPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* ProcessUnexpectedResult --
*
* Procedure called by Tcl_EvalObj to set the interpreter's result
* value to an appropriate error message when the code it evaluates
* returns an unexpected result code (not TCL_OK and not TCL_ERROR) to
* the topmost evaluation level.
*
* Results:
* None.
*
* Side effects:
* The interpreter result is set to an error message appropriate to
* the result code.
*
*----------------------------------------------------------------------
*/
static void
ProcessUnexpectedResult(interp, returnCode)
Tcl_Interp *interp; /* The interpreter in which the unexpected
* result code was returned. */
int returnCode; /* The unexpected result code. */
{
Tcl_ResetResult(interp);
if (returnCode == TCL_BREAK) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"invoked \"break\" outside of a loop", -1);
} else if (returnCode == TCL_CONTINUE) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"invoked \"continue\" outside of a loop", -1);
} else {
char buf[30 + TCL_INTEGER_SPACE];
sprintf(buf, "command returned bad code: %d", returnCode);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
*
* Procedures to evaluate an expression and return its value in a
* particular form.
*
* Results:
* Each of the procedures below returns a standard Tcl result. If an
* error occurs then an error message is left in the interp's result.
* Otherwise the value of the expression, in the appropriate form,
* is stored at *ptr. If the expression had a result that was
* incompatible with the desired form then an error is returned.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_ExprLong(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
CONST char *string; /* Expression to evaluate. */
long *ptr; /* Where to store result. */
{
register Tcl_Obj *exprPtr;
Tcl_Obj *resultPtr;
int length = strlen(string);
int result = TCL_OK;
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store an integer based on the expression result.
*/
if (resultPtr->typePtr == &tclIntType) {
*ptr = resultPtr->internalRep.longValue;
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = (long) resultPtr->internalRep.doubleValue;
} else if (resultPtr->typePtr == &tclWideIntType) {
#ifndef TCL_WIDE_INT_IS_LONG
/*
* See Tcl_GetIntFromObj for conversion comments.
*/
Tcl_WideInt w = resultPtr->internalRep.wideValue;
if ((w >= -(Tcl_WideInt)(ULONG_MAX))
&& (w <= (Tcl_WideInt)(ULONG_MAX))) {
*ptr = Tcl_WideAsLong(w);
} else {
Tcl_SetResult(interp,
"integer value too large to represent as non-long integer",
TCL_STATIC);
result = TCL_ERROR;
}
#else
*ptr = resultPtr->internalRep.longValue;
#endif
} else {
Tcl_SetResult(interp,
"expression didn't have numeric value", TCL_STATIC);
result = TCL_ERROR;
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
} else {
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
} else {
/*
* An empty string. Just set the result integer to 0.
*/
*ptr = 0;
}
return result;
}
int
Tcl_ExprDouble(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
CONST char *string; /* Expression to evaluate. */
double *ptr; /* Where to store result. */
{
register Tcl_Obj *exprPtr;
Tcl_Obj *resultPtr;
int length = strlen(string);
int result = TCL_OK;
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store a double based on the expression result.
*/
if (resultPtr->typePtr == &tclIntType) {
*ptr = (double) resultPtr->internalRep.longValue;
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = resultPtr->internalRep.doubleValue;
} else if (resultPtr->typePtr == &tclWideIntType) {
#ifndef TCL_WIDE_INT_IS_LONG
/*
* See Tcl_GetIntFromObj for conversion comments.
*/
Tcl_WideInt w = resultPtr->internalRep.wideValue;
if ((w >= -(Tcl_WideInt)(ULONG_MAX))
&& (w <= (Tcl_WideInt)(ULONG_MAX))) {
*ptr = (double) Tcl_WideAsLong(w);
} else {
Tcl_SetResult(interp,
"integer value too large to represent as non-long integer",
TCL_STATIC);
result = TCL_ERROR;
}
#else
*ptr = (double) resultPtr->internalRep.longValue;
#endif
} else {
Tcl_SetResult(interp,
"expression didn't have numeric value", TCL_STATIC);
result = TCL_ERROR;
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
} else {
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
} else {
/*
* An empty string. Just set the result double to 0.0.
*/
*ptr = 0.0;
}
return result;
}
int
Tcl_ExprBoolean(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
CONST char *string; /* Expression to evaluate. */
int *ptr; /* Where to store 0/1 result. */
{
register Tcl_Obj *exprPtr;
Tcl_Obj *resultPtr;
int length = strlen(string);
int result = TCL_OK;
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store a boolean based on the expression result.
*/
if (resultPtr->typePtr == &tclIntType) {
*ptr = (resultPtr->internalRep.longValue != 0);
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = (resultPtr->internalRep.doubleValue != 0.0);
} else if (resultPtr->typePtr == &tclWideIntType) {
#ifndef TCL_WIDE_INT_IS_LONG
*ptr = (resultPtr->internalRep.wideValue != 0);
#else
*ptr = (resultPtr->internalRep.longValue != 0);
#endif
} else {
result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
if (result != TCL_OK) {
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
} else {
/*
* An empty string. Just set the result boolean to 0 (false).
*/
*ptr = 0;
}
return result;
}
/*
*--------------------------------------------------------------
*
* Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
*
* Procedures to evaluate an expression in an object and return its
* value in a particular form.
*
* Results:
* Each of the procedures below returns a standard Tcl result
* object. If an error occurs then an error message is left in the
* interpreter's result. Otherwise the value of the expression, in the
* appropriate form, is stored at *ptr. If the expression had a result
* that was incompatible with the desired form then an error is
* returned.
*
* Side effects:
* None.
*
*--------------------------------------------------------------
*/
int
Tcl_ExprLongObj(interp, objPtr, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
register Tcl_Obj *objPtr; /* Expression to evaluate. */
long *ptr; /* Where to store long result. */
{
Tcl_Obj *resultPtr;
int result;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result == TCL_OK) {
if (resultPtr->typePtr == &tclIntType) {
*ptr = resultPtr->internalRep.longValue;
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = (long) resultPtr->internalRep.doubleValue;
} else {
result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
if (result != TCL_OK) {
return result;
}
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
return result;
}
int
Tcl_ExprDoubleObj(interp, objPtr, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
register Tcl_Obj *objPtr; /* Expression to evaluate. */
double *ptr; /* Where to store double result. */
{
Tcl_Obj *resultPtr;
int result;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result == TCL_OK) {
if (resultPtr->typePtr == &tclIntType) {
*ptr = (double) resultPtr->internalRep.longValue;
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = resultPtr->internalRep.doubleValue;
} else {
result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
if (result != TCL_OK) {
return result;
}
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
return result;
}
int
Tcl_ExprBooleanObj(interp, objPtr, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
register Tcl_Obj *objPtr; /* Expression to evaluate. */
int *ptr; /* Where to store 0/1 result. */
{
Tcl_Obj *resultPtr;
int result;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result == TCL_OK) {
if (resultPtr->typePtr == &tclIntType) {
*ptr = (resultPtr->internalRep.longValue != 0);
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = (resultPtr->internalRep.doubleValue != 0.0);
} else {
result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclInvoke --
*
* Invokes a Tcl command, given an argv/argc, from either the
* exposed or the hidden sets of commands in the given interpreter.
* NOTE: The command is invoked in the current stack frame of
* the interpreter, thus it can modify local variables.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the command does.
*
*----------------------------------------------------------------------
*/
int
TclInvoke(interp, argc, argv, flags)
Tcl_Interp *interp; /* Where to invoke the command. */
int argc; /* Count of args. */
register CONST char **argv; /* The arg strings; argv[0] is the name of
* the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN and
* TCL_INVOKE_NO_UNKNOWN. */
{
register Tcl_Obj *objPtr;
register int i;
int length, result;
/*
* This procedure generates an objv array for object arguments that hold
* the argv strings. It starts out with stack-allocated space but uses
* dynamically-allocated storage if needed.
*/
#define NUM_ARGS 20
Tcl_Obj *(objStorage[NUM_ARGS]);
register Tcl_Obj **objv = objStorage;
/*
* Create the object argument array "objv". Make sure objv is large
* enough to hold the objc arguments plus 1 extra for the zero
* end-of-objv word.
*/
if ((argc + 1) > NUM_ARGS) {
objv = (Tcl_Obj **)
ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
}
for (i = 0; i < argc; i++) {
length = strlen(argv[i]);
objv[i] = Tcl_NewStringObj(argv[i], length);
Tcl_IncrRefCount(objv[i]);
}
objv[argc] = 0;
/*
* Use TclObjInterpProc to actually invoke the command.
*/
result = TclObjInvoke(interp, argc, objv, flags);
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
/*
* Decrement the ref counts on the objv elements since we are done
* with them.
*/
for (i = 0; i < argc; i++) {
objPtr = objv[i];
Tcl_DecrRefCount(objPtr);
}
/*
* Free the objv array if malloc'ed storage was used.
*/
if (objv != objStorage) {
ckfree((char *) objv);
}
return result;
#undef NUM_ARGS
}
/*
*----------------------------------------------------------------------
*
* TclGlobalInvoke --
*
* Invokes a Tcl command, given an argv/argc, from either the
* exposed or hidden sets of commands in the given interpreter.
* NOTE: The command is invoked in the global stack frame of
* the interpreter, thus it cannot see any current state on
* the stack for that interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the command does.
*
*----------------------------------------------------------------------
*/
int
TclGlobalInvoke(interp, argc, argv, flags)
Tcl_Interp *interp; /* Where to invoke the command. */
int argc; /* Count of args. */
register CONST char **argv; /* The arg strings; argv[0] is the name of
* the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN and
* TCL_INVOKE_NO_UNKNOWN. */
{
register Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr;
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = NULL;
result = TclInvoke(interp, argc, argv, flags);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
/*
*----------------------------------------------------------------------
*
* TclObjInvokeGlobal --
*
* Object version: Invokes a Tcl command, given an objv/objc, from
* either the exposed or hidden set of commands in the given
* interpreter.
* NOTE: The command is invoked in the global stack frame of the
* interpreter, thus it cannot see any current state on the
* stack of that interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the command does.
*
*----------------------------------------------------------------------
*/
int
TclObjInvokeGlobal(interp, objc, objv, flags)
Tcl_Interp *interp; /* Interpreter in which command is to be
* invoked. */
int objc; /* Count of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
* name of the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN,
* TCL_INVOKE_NO_UNKNOWN, or
* TCL_INVOKE_NO_TRACEBACK. */
{
register Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr;
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = NULL;
result = TclObjInvoke(interp, objc, objv, flags);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
/*
*----------------------------------------------------------------------
*
* TclObjInvoke --
*
* Invokes a Tcl command, given an objv/objc, from either the
* exposed or the hidden sets of commands in the given interpreter.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* Whatever the command does.
*
*----------------------------------------------------------------------
*/
int
TclObjInvoke(interp, objc, objv, flags)
Tcl_Interp *interp; /* Interpreter in which command is to be
* invoked. */
int objc; /* Count of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
* name of the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN,
* TCL_INVOKE_NO_UNKNOWN, or
* TCL_INVOKE_NO_TRACEBACK. */
{
register Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
char *cmdName; /* Name of the command from objv[0]. */
register Tcl_HashEntry *hPtr;
Tcl_Command cmd;
Command *cmdPtr;
int localObjc; /* Used to invoke "unknown" if the */
Tcl_Obj **localObjv = NULL; /* command is not found. */
register int i;
int result;
if (interp == (Tcl_Interp *) NULL) {
return TCL_ERROR;
}
if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"illegal argument vector", -1);
return TCL_ERROR;
}
cmdName = Tcl_GetString(objv[0]);
if (flags & TCL_INVOKE_HIDDEN) {
/*
* We never invoke "unknown" for hidden commands.
*/
hPtr = NULL;
hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr;
if (hTblPtr != NULL) {
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
}
if (hPtr == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid hidden command name \"", cmdName, "\"",
(char *) NULL);
return TCL_ERROR;
}
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
} else {
cmdPtr = NULL;
cmd = Tcl_FindCommand(interp, cmdName,
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
if (cmd != (Tcl_Command) NULL) {
cmdPtr = (Command *) cmd;
}
if (cmdPtr == NULL) {
if (!(flags & TCL_INVOKE_NO_UNKNOWN)) {
cmd = Tcl_FindCommand(interp, "unknown",
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
if (cmd != (Tcl_Command) NULL) {
cmdPtr = (Command *) cmd;
}
if (cmdPtr != NULL) {
localObjc = (objc + 1);
localObjv = (Tcl_Obj **)
ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc));
localObjv[0] = Tcl_NewStringObj("unknown", -1);
Tcl_IncrRefCount(localObjv[0]);
for (i = 0; i < objc; i++) {
localObjv[i+1] = objv[i];
}
objc = localObjc;
objv = localObjv;
}
}
/*
* Check again if we found the command. If not, "unknown" is
* not present and we cannot help, or the caller said not to
* call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN).
*/
if (cmdPtr == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid command name \"", cmdName, "\"",
(char *) NULL);
return TCL_ERROR;
}
}
}
/*
* Invoke the command procedure. First reset the interpreter's string
* and object results to their default empty values since they could
* have gotten changed by earlier invocations.
*/
Tcl_ResetResult(interp);
iPtr->cmdCount++;
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
/*
* If an error occurred, record information about what was being
* executed when the error occurred.
*/
if ((result == TCL_ERROR)
&& ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
&& ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
Tcl_Obj *msg;
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
msg = Tcl_NewStringObj("\n while invoking\n\"", -1);
} else {
msg = Tcl_NewStringObj("\n invoked from within\n\"", -1);
}
Tcl_IncrRefCount(msg);
for (i = 0; i < objc; i++) {
CONST char *bytes;
int length;
Tcl_AppendObjToObj(msg, objv[i]);
bytes = Tcl_GetStringFromObj(msg, &length);
if (length > 100) {
/*
* Back up truncation point so that we don't truncate
* in the middle of a multi-byte character.
*/
length = 100;
while ( (bytes[length] & 0xC0) == 0x80 ) {
length--;
}
Tcl_SetObjLength(msg, length);
Tcl_AppendToObj(msg, "...", -1);
break;
}
if (i != (objc - 1)) {
Tcl_AppendToObj(msg, " ", -1);
}
}
Tcl_AppendToObj(msg, "\"", -1);
Tcl_AddObjErrorInfo(interp, Tcl_GetString(msg), -1);
Tcl_DecrRefCount(msg);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
/*
* Free any locally allocated storage used to call "unknown".
*/
if (localObjv != (Tcl_Obj **) NULL) {
Tcl_DecrRefCount(localObjv[0]);
ckfree((char *) localObjv);
}
return result;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_ExprString --
*
* Evaluate an expression in a string and return its value in string
* form.
*
* Results:
* A standard Tcl result. If the result is TCL_OK, then the interp's
* result is set to the string value of the expression. If the result
* is TCL_ERROR, then the interp's result contains an error message.
*
* Side effects:
* A Tcl object is allocated to hold a copy of the expression string.
* This expression object is passed to Tcl_ExprObj and then
* deallocated.
*
*---------------------------------------------------------------------------
*/
int
Tcl_ExprString(interp, string)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
CONST char *string; /* Expression to evaluate. */
{
register Tcl_Obj *exprPtr;
Tcl_Obj *resultPtr;
int length = strlen(string);
char buf[TCL_DOUBLE_SPACE];
int result = TCL_OK;
if (length > 0) {
TclNewObj(exprPtr);
TclInitStringRep(exprPtr, string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Set the interpreter's string result from the result object.
*/
if (resultPtr->typePtr == &tclIntType) {
sprintf(buf, "%ld", resultPtr->internalRep.longValue);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (resultPtr->typePtr == &tclDoubleType) {
Tcl_PrintDouble((Tcl_Interp *) NULL,
resultPtr->internalRep.doubleValue, buf);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else {
/*
* Set interpreter's string result from the result object.
*/
Tcl_SetResult(interp, TclGetString(resultPtr),
TCL_VOLATILE);
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
} else {
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
} else {
/*
* An empty string. Just set the interpreter's result to 0.
*/
Tcl_SetResult(interp, "0", TCL_VOLATILE);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateObjTrace --
*
* Arrange for a procedure to be called to trace command execution.
*
* Results:
* The return value is a token for the trace, which may be passed
* to Tcl_DeleteTrace to eliminate the trace.
*
* Side effects:
* From now on, proc will be called just before a command procedure
* is called to execute a Tcl command. Calls to proc will have the
* following form:
*
* void proc( ClientData clientData,
* Tcl_Interp* interp,
* int level,
* CONST char* command,
* Tcl_Command commandInfo,
* int objc,
* Tcl_Obj *CONST objv[] );
*
* The 'clientData' and 'interp' arguments to 'proc' will be the
* same as the arguments to Tcl_CreateObjTrace. The 'level'
* argument gives the nesting depth of command interpretation within
* the interpreter. The 'command' argument is the ASCII text of
* the command being evaluated -- before any substitutions are
* performed. The 'commandInfo' argument gives a handle to the
* command procedure that will be evaluated. The 'objc' and 'objv'
* parameters give the parameter vector that will be passed to the
* command procedure. proc does not return a value.
*
* It is permissible for 'proc' to call Tcl_SetCommandTokenInfo
* to change the command procedure or client data for the command
* being evaluated, and these changes will take effect with the
* current evaluation.
*
* The 'level' argument specifies the maximum nesting level of calls
* to be traced. If the execution depth of the interpreter exceeds
* 'level', the trace callback is not executed.
*
* The 'flags' argument is either zero or the value,
* TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION
* flag is not present, the bytecode compiler will not generate inline
* code for Tcl's built-in commands. This behavior will have a significant
* impact on performance, but will ensure that all command evaluations are
* traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the
* bytecode compiler will have its normal behavior of compiling in-line
* code for some of Tcl's built-in commands. In this case, the tracing
* will be imprecise -- in-line code will not be traced -- but run-time
* performance will be improved. The latter behavior is desired for
* many applications such as profiling of run time.
*
* When the trace is deleted, the 'delProc' procedure will be invoked,
* passing it the original client data.
*
*----------------------------------------------------------------------
*/
Tcl_Trace
Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc )
Tcl_Interp* interp; /* Tcl interpreter */
int level; /* Maximum nesting level */
int flags; /* Flags, see above */
Tcl_CmdObjTraceProc* proc; /* Trace callback */
ClientData clientData; /* Client data for the callback */
Tcl_CmdObjTraceDeleteProc* delProc;
/* Procedure to call when trace is deleted */
{
register Trace *tracePtr;
register Interp *iPtr = (Interp *) interp;
/* Test if this trace allows inline compilation of commands */
if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) {
if (iPtr->tracesForbiddingInline == 0) {
/*
* When the first trace forbidding inline compilation is
* created, invalidate existing compiled code for this
* interpreter and arrange (by setting the
* DONT_COMPILE_CMDS_INLINE flag) that when compiling new
* code, no commands will be compiled inline (i.e., into
* an inline sequence of instructions). We do this because
* commands that were compiled inline will never result in
* a command trace being called.
*/
iPtr->compileEpoch++;
iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
}
iPtr->tracesForbiddingInline++;
}
tracePtr = (Trace *) ckalloc(sizeof(Trace));
tracePtr->level = level;
tracePtr->proc = proc;
tracePtr->clientData = clientData;
tracePtr->delProc = delProc;
tracePtr->nextPtr = iPtr->tracePtr;
tracePtr->flags = flags;
iPtr->tracePtr = tracePtr;
return (Tcl_Trace) tracePtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateTrace --
*
* Arrange for a procedure to be called to trace command execution.
*
* Results:
* The return value is a token for the trace, which may be passed
* to Tcl_DeleteTrace to eliminate the trace.
*
* Side effects:
* From now on, proc will be called just before a command procedure
* is called to execute a Tcl command. Calls to proc will have the
* following form:
*
* void
* proc(clientData, interp, level, command, cmdProc, cmdClientData,
* argc, argv)
* ClientData clientData;
* Tcl_Interp *interp;
* int level;
* char *command;
* int (*cmdProc)();
* ClientData cmdClientData;
* int argc;
* char **argv;
* {
* }
*
* The clientData and interp arguments to proc will be the same
* as the corresponding arguments to this procedure. Level gives
* the nesting level of command interpretation for this interpreter
* (0 corresponds to top level). Command gives the ASCII text of
* the raw command, cmdProc and cmdClientData give the procedure that
* will be called to process the command and the ClientData value it
* will receive, and argc and argv give the arguments to the
* command, after any argument parsing and substitution. Proc
* does not return a value.
*
*----------------------------------------------------------------------
*/
Tcl_Trace
Tcl_CreateTrace(interp, level, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which to create trace. */
int level; /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
* command. */
ClientData clientData; /* Arbitrary value word to pass to proc. */
{
StringTraceData* data;
data = (StringTraceData*) ckalloc( sizeof( *data ));
data->clientData = clientData;
data->proc = proc;
return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc,
(ClientData) data, StringTraceDeleteProc );
}
/*
*----------------------------------------------------------------------
*
* StringTraceProc --
*
* Invoke a string-based trace procedure from an object-based
* callback.
*
* Results:
* None.
*
* Side effects:
* Whatever the string-based trace procedure does.
*
*----------------------------------------------------------------------
*/
static int
StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv )
ClientData clientData;
Tcl_Interp* interp;
int level;
CONST char* command;
Tcl_Command commandInfo;
int objc;
Tcl_Obj *CONST *objv;
{
StringTraceData* data = (StringTraceData*) clientData;
Command* cmdPtr = (Command*) commandInfo;
CONST char** argv; /* Args to pass to string trace proc */
int i;
/*
* This is a bit messy because we have to emulate the old trace
* interface, which uses strings for everything.
*/
argv = (CONST char **) ckalloc((unsigned) ( (objc + 1)
* sizeof(CONST char *) ));
for (i = 0; i < objc; i++) {
argv[i] = Tcl_GetString(objv[i]);
}
argv[objc] = 0;
/*
* Invoke the command procedure. Note that we cast away const-ness
* on two parameters for compatibility with legacy code; the code
* MUST NOT modify either command or argv.
*/
( data->proc )( data->clientData, interp, level,
(char*) command, cmdPtr->proc, cmdPtr->clientData,
objc, argv );
ckfree( (char*) argv );
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringTraceDeleteProc --
*
* Clean up memory when a string-based trace is deleted.
*
* Results:
* None.
*
* Side effects:
* Allocated memory is returned to the system.
*
*----------------------------------------------------------------------
*/
static void
StringTraceDeleteProc( clientData )
ClientData clientData;
{
ckfree( (char*) clientData );
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteTrace --
*
* Remove a trace.
*
* Results:
* None.
*
* Side effects:
* From now on there will be no more calls to the procedure given
* in trace.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteTrace(interp, trace)
Tcl_Interp *interp; /* Interpreter that contains trace. */
Tcl_Trace trace; /* Token for trace (returned previously by
* Tcl_CreateTrace). */
{
Interp *iPtr = (Interp *) interp;
Trace *prevPtr, *tracePtr = (Trace *) trace;
register Trace **tracePtr2 = &(iPtr->tracePtr);
ActiveInterpTrace *activePtr;
/*
* Locate the trace entry in the interpreter's trace list,
* and remove it from the list.
*/
prevPtr = NULL;
while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) {
prevPtr = *tracePtr2;
tracePtr2 = &((*tracePtr2)->nextPtr);
}
if (*tracePtr2 == NULL) {
return;
}
(*tracePtr2) = (*tracePtr2)->nextPtr;
/*
* The code below makes it possible to delete traces while traces
* are active: it makes sure that the deleted trace won't be
* processed by TclCheckInterpTraces.
*/
for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
if (activePtr->reverseScan) {
activePtr->nextTracePtr = prevPtr;
} else {
activePtr->nextTracePtr = tracePtr->nextPtr;
}
}
}
/*
* If the trace forbids bytecode compilation, change the interpreter's
* state. If bytecode compilation is now permitted, flag the fact and
* advance the compilation epoch so that procs will be recompiled to
* take advantage of it.
*/
if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) {
iPtr->tracesForbiddingInline--;
if (iPtr->tracesForbiddingInline == 0) {
iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
iPtr->compileEpoch++;
}
}
/*
* Execute any delete callback.
*/
if (tracePtr->delProc != NULL) {
(tracePtr->delProc)(tracePtr->clientData);
}
/* Delete the trace object */
Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AddErrorInfo --
*
* Add information to the "errorInfo" variable that describes the
* current error.
*
* Results:
* None.
*
* Side effects:
* The contents of message are added to the "errorInfo" variable.
* If Tcl_Eval has been called since the current value of errorInfo
* was set, errorInfo is cleared before adding the new message.
* If we are just starting to log an error, errorInfo is initialized
* from the error message in the interpreter's result.
*
*----------------------------------------------------------------------
*/
void
Tcl_AddErrorInfo(interp, message)
Tcl_Interp *interp; /* Interpreter to which error information
* pertains. */
CONST char *message; /* Message to record. */
{
Tcl_AddObjErrorInfo(interp, message, -1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AddObjErrorInfo --
*
* Add information to the "errorInfo" variable that describes the
* current error. This routine differs from Tcl_AddErrorInfo by
* taking a byte pointer and length.
*
* Results:
* None.
*
* Side effects:
* "length" bytes from "message" are added to the "errorInfo" variable.
* If "length" is negative, use bytes up to the first NULL byte.
* If Tcl_EvalObj has been called since the current value of errorInfo
* was set, errorInfo is cleared before adding the new message.
* If we are just starting to log an error, errorInfo is initialized
* from the error message in the interpreter's result.
*
*----------------------------------------------------------------------
*/
void
Tcl_AddObjErrorInfo(interp, message, length)
Tcl_Interp *interp; /* Interpreter to which error information
* pertains. */
CONST char *message; /* Points to the first byte of an array of
* bytes of the message. */
int length; /* The number of bytes in the message.
* If < 0, then append all bytes up to a
* NULL byte. */
{
register Interp *iPtr = (Interp *) interp;
Tcl_Obj *objPtr;
/*
* If we are just starting to log an error, errorInfo is initialized
* from the error message in the interpreter's result.
*/
if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
iPtr->flags |= ERR_IN_PROGRESS;
if (iPtr->result[0] == 0) {
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
iPtr->objResultPtr, TCL_GLOBAL_ONLY);
} else { /* use the string result */
objPtr = Tcl_NewStringObj(interp->result, -1);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
}
/*
* If the errorCode variable wasn't set by the code that generated
* the error, set it to "NONE".
*/
if (!(iPtr->flags & ERROR_CODE_SET)) {
objPtr = Tcl_NewStringObj("NONE", -1);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
}
}
/*
* Now append "message" to the end of errorInfo.
*/
if (length != 0) {
objPtr = Tcl_NewStringObj(message, length);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
objPtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
Tcl_DecrRefCount(objPtr); /* free msg object appended above */
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_VarEvalVA --
*
* Given a variable number of string arguments, concatenate them
* all together and execute the result as a Tcl command.
*
* Results:
* A standard Tcl return result. An error message or other result may
* be left in the interp's result.
*
* Side effects:
* Depends on what was done by the command.
*
*---------------------------------------------------------------------------
*/
int
Tcl_VarEvalVA (interp, argList)
Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
va_list argList; /* Variable argument list. */
{
Tcl_DString buf;
char *string;
int result;
/*
* Copy the strings one after the other into a single larger
* string. Use stack-allocated space for small commands, but if
* the command gets too large than call ckalloc to create the
* space.
*/
Tcl_DStringInit(&buf);
while (1) {
string = va_arg(argList, char *);
if (string == NULL) {
break;
}
Tcl_DStringAppend(&buf, string, -1);
}
result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
Tcl_DStringFree(&buf);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_VarEval --
*
* Given a variable number of string arguments, concatenate them
* all together and execute the result as a Tcl command.
*
* Results:
* A standard Tcl return result. An error message or other
* result may be left in interp->result.
*
* Side effects:
* Depends on what was done by the command.
*
*----------------------------------------------------------------------
*/
/* VARARGS2 */ /* ARGSUSED */
int
Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
Tcl_Interp *interp;
va_list argList;
int result;
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
result = Tcl_VarEvalVA(interp, argList);
va_end(argList);
return result;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_GlobalEval --
*
* Evaluate a command at global level in an interpreter.
*
* Results:
* A standard Tcl result is returned, and the interp's result is
* modified accordingly.
*
* Side effects:
* The command string is executed in interp, and the execution
* is carried out in the variable context of global level (no
* procedures active), just as if an "uplevel #0" command were
* being executed.
*
---------------------------------------------------------------------------
*/
int
Tcl_GlobalEval(interp, command)
Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
CONST char *command; /* Command to evaluate. */
{
register Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr;
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = NULL;
result = Tcl_Eval(interp, command);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetRecursionLimit --
*
* Set the maximum number of recursive calls that may be active
* for an interpreter at once.
*
* Results:
* The return value is the old limit on nesting for interp.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetRecursionLimit(interp, depth)
Tcl_Interp *interp; /* Interpreter whose nesting limit
* is to be set. */
int depth; /* New value for maximimum depth. */
{
Interp *iPtr = (Interp *) interp;
int old;
old = iPtr->maxNestingDepth;
if (depth > 0) {
iPtr->maxNestingDepth = depth;
}
return old;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AllowExceptions --
*
* Sets a flag in an interpreter so that exceptions can occur
* in the next call to Tcl_Eval without them being turned into
* errors.
*
* Results:
* None.
*
* Side effects:
* The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
* evalFlags structure. See the reference documentation for
* more details.
*
*----------------------------------------------------------------------
*/
void
Tcl_AllowExceptions(interp)
Tcl_Interp *interp; /* Interpreter in which to set flag. */
{
Interp *iPtr = (Interp *) interp;
iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetVersion
*
* Get the Tcl major, minor, and patchlevel version numbers and
* the release type. A patch is a release type TCL_FINAL_RELEASE
* with a patchLevel > 0.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_GetVersion(majorV, minorV, patchLevelV, type)
int *majorV;
int *minorV;
int *patchLevelV;
int *type;
{
if (majorV != NULL) {
*majorV = TCL_MAJOR_VERSION;
}
if (minorV != NULL) {
*minorV = TCL_MINOR_VERSION;
}
if (patchLevelV != NULL) {
*patchLevelV = TCL_RELEASE_SERIAL;
}
if (type != NULL) {
*type = TCL_RELEASE_LEVEL;
}
}
#ifdef USE_DTRACE
/*
*----------------------------------------------------------------------
*
* DTraceObjCmd --
*
* This function is invoked to process the "::tcl::dtrace" Tcl command.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* The 'tcl-probe' DTrace probe is triggered (if it is enabled).
*
*----------------------------------------------------------------------
*/
static int
DTraceObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *CONST objv[]) /* Argument objects. */
{
if (TCL_DTRACE_TCL_PROBE_ENABLED()) {
char *a[10];
int i = 0;
while (i++ < 10) {
a[i-1] = i < objc ? TclGetString(objv[i]) : NULL;
}
TCL_DTRACE_TCL_PROBE(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
a[8], a[9]);
}
return TCL_OK;
}
TCL_DTRACE_DEBUG_LOG()
#endif /* USE_DTRACE */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclProc.c 0000644 0036047 0045461 00000164523 11737050674 014120 0 ustar dgp 771div /*
* tclProc.c --
*
* This file contains routines that implement Tcl procedures,
* including the "proc" and "uplevel" commands.
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 2007 Daniel A. Steffen
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
* Prototypes for static functions in this file
*/
static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr));
static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
static int ProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp,
Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr,
CONST char *description, CONST char *procName,
Proc **procPtrPtr));
static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
char *procName, int nameLen, int returnCode));
static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
/*
* The ProcBodyObjType type
*/
Tcl_ObjType tclProcBodyType = {
"procbody", /* name for this type */
ProcBodyFree, /* FreeInternalRep procedure */
ProcBodyDup, /* DupInternalRep procedure */
ProcBodyUpdateString, /* UpdateString procedure */
ProcBodySetFromAny /* SetFromAny procedure */
};
/*
*----------------------------------------------------------------------
*
* Tcl_ProcObjCmd --
*
* This object-based procedure is invoked to process the "proc" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* A new procedure gets created.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ProcObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
Proc *procPtr;
char *fullName;
CONST char *procName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
Tcl_DString ds;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "name args body");
return TCL_ERROR;
}
/*
* Determine the namespace where the procedure should reside. Unless
* the command name includes namespace qualifiers, this will be the
* current namespace.
*/
fullName = TclGetString(objv[1]);
TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL,
0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't create procedure \"", fullName,
"\": unknown namespace", (char *) NULL);
return TCL_ERROR;
}
if (procName == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't create procedure \"", fullName,
"\": bad procedure name", (char *) NULL);
return TCL_ERROR;
}
if ((nsPtr != iPtr->globalNsPtr)
&& (procName != NULL) && (procName[0] == ':')) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't create procedure \"", procName,
"\" in non-global namespace with name starting with \":\"",
(char *) NULL);
return TCL_ERROR;
}
/*
* Create the data structure to represent the procedure.
*/
if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
&procPtr) != TCL_OK) {
return TCL_ERROR;
}
/*
* Now create a command for the procedure. This will initially be in
* the current namespace unless the procedure's name included namespace
* qualifiers. To create the new command in the right namespace, we
* generate a fully qualified name for it.
*/
Tcl_DStringInit(&ds);
if (nsPtr != iPtr->globalNsPtr) {
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
Tcl_DStringAppend(&ds, "::", 2);
}
Tcl_DStringAppend(&ds, procName, -1);
Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc,
(ClientData) procPtr, TclProcDeleteProc);
cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
Tcl_DStringFree(&ds);
/*
* Now initialize the new procedure's cmdPtr field. This will be used
* later when the procedure is called to determine what namespace the
* procedure will run in. This will be different than the current
* namespace if the proc was renamed into a different namespace.
*/
procPtr->cmdPtr = (Command *) cmd;
#ifdef TCL_TIP280
/* TIP #280 Remember the line the procedure body is starting on. In a
* Byte code context we ask the engine to provide us with the necessary
* information. This is for the initialization of the byte code compiler
* when the body is used for the first time.
*/
if (iPtr->cmdFramePtr) {
CmdFrame context = *iPtr->cmdFramePtr;
if (context.type == TCL_LOCATION_BC) {
TclGetSrcInfoForPc (&context);
/* May get path in context */
} else if (context.type == TCL_LOCATION_SOURCE) {
/* context now holds another reference */
Tcl_IncrRefCount (context.data.eval.path);
}
/* type == TCL_LOCATION_PREBC implies that 'line' is NULL here! We
* cannot assume that 'line' is valid here, we have to check. If the
* outer context is an eval (bc, prebc, eval) we do not save any
* information. Counting relative to the beginning of the proc body is
* more sensible than counting relative to the outer eval block.
*/
if ((context.type == TCL_LOCATION_SOURCE) &&
context.line &&
(context.nline >= 4) &&
(context.line [3] >= 0)) {
int isNew;
Tcl_HashEntry* hePtr;
CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame));
cfPtr->level = -1;
cfPtr->type = context.type;
cfPtr->line = (int*) ckalloc (sizeof (int));
cfPtr->line [0] = context.line [3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
cfPtr->nextPtr = NULL;
if (context.type == TCL_LOCATION_SOURCE) {
cfPtr->data.eval.path = context.data.eval.path;
/* Transfer of reference. The reference going away (release of
* the context) is replaced by the reference in the
* constructed cmdframe */
} else {
cfPtr->type = TCL_LOCATION_EVAL;
cfPtr->data.eval.path = NULL;
}
cfPtr->cmd.str.cmd = NULL;
cfPtr->cmd.str.len = 0;
hePtr = Tcl_CreateHashEntry (iPtr->linePBodyPtr, (char*) procPtr,
&isNew);
if (!isNew) {
/*
* Get the old command frame and release it. See also
* TclProcCleanupProc in this file. Currently it seems as if
* only the procbodytest::proc command of the testsuite is
* able to trigger this situation.
*/
CmdFrame* cfOldPtr = (CmdFrame *) Tcl_GetHashValue(hePtr);
if (cfOldPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfOldPtr->data.eval.path);
cfOldPtr->data.eval.path = NULL;
}
ckfree((char *) cfOldPtr->line);
cfOldPtr->line = NULL;
ckfree((char *) cfOldPtr);
}
Tcl_SetHashValue (hePtr, cfPtr);
}
}
#endif
/*
* Optimize for noop procs: if the body is not precompiled (like a TclPro
* procbody), and the argument list is just "args" and the body is empty,
* define a compileProc to compile a noop.
*
* Notes:
* - cannot be done for any argument list without having different
* compiled/not-compiled behaviour in the "wrong argument #" case,
* or making this code much more complicated. In any case, it doesn't
* seem to make a lot of sense to verify the number of arguments we
* are about to ignore ...
* - could be enhanced to handle also non-empty bodies that contain
* only comments; however, parsing the body will slow down the
* compilation of all procs whose argument list is just _args_ */
if (objv[3]->typePtr == &tclProcBodyType) {
goto done;
}
procArgs = Tcl_GetString(objv[2]);
while (*procArgs == ' ') {
procArgs++;
}
if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
procArgs +=4;
while(*procArgs != '\0') {
if (*procArgs != ' ') {
goto done;
}
procArgs++;
}
/*
* The argument list is just "args"; check the body
*/
procBody = Tcl_GetString(objv[3]);
while (*procBody != '\0') {
if (!isspace(UCHAR(*procBody))) {
goto done;
}
procBody++;
}
/*
* The body is just spaces: link the compileProc
*/
((Command *) cmd)->compileProc = TclCompileNoOp;
}
done:
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCreateProc --
*
* Creates the data associated with a Tcl procedure definition.
* This procedure knows how to handle two types of body objects:
* strings and procbody. Strings are the traditional (and common) value
* for bodies, procbody are values created by extensions that have
* loaded a previously compiled script.
*
* Results:
* Returns TCL_OK on success, along with a pointer to a Tcl
* procedure definition in procPtrPtr. This definition should
* be freed by calling TclCleanupProc() when it is no longer
* needed. Returns TCL_ERROR if anything goes wrong.
*
* Side effects:
* If anything goes wrong, this procedure returns an error
* message in the interpreter.
*
*----------------------------------------------------------------------
*/
int
TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
Tcl_Interp *interp; /* interpreter containing proc */
Namespace *nsPtr; /* namespace containing this proc */
CONST char *procName; /* unqualified name of this proc */
Tcl_Obj *argsPtr; /* description of arguments */
Tcl_Obj *bodyPtr; /* command body */
Proc **procPtrPtr; /* returns: pointer to proc data */
{
Interp *iPtr = (Interp*)interp;
CONST char **argArray = NULL;
register Proc *procPtr;
int i, length, result, numArgs;
CONST char *args, *bytes, *p;
register CompiledLocal *localPtr = NULL;
Tcl_Obj *defPtr;
int precompiled = 0;
if (bodyPtr->typePtr == &tclProcBodyType) {
/*
* Because the body is a TclProProcBody, the actual body is already
* compiled, and it is not shared with anyone else, so it's OK not to
* unshare it (as a matter of fact, it is bad to unshare it, because
* there may be no source code).
*
* We don't create and initialize a Proc structure for the procedure;
* rather, we use what is in the body object. Note that
* we initialize its cmdPtr field below after we've created the command
* for the procedure. We increment the ref count of the Proc struct
* since the command (soon to be created) will be holding a reference
* to it.
*/
procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr;
procPtr->iPtr = iPtr;
procPtr->refCount++;
precompiled = 1;
} else {
/*
* If the procedure's body object is shared because its string value is
* identical to, e.g., the body of another procedure, we must create a
* private copy for this procedure to use. Such sharing of procedure
* bodies is rare but can cause problems. A procedure body is compiled
* in a context that includes the number of compiler-allocated "slots"
* for local variables. Each formal parameter is given a local variable
* slot (the "procPtr->numCompiledLocals = numArgs" assignment
* below). This means that the same code can not be shared by two
* procedures that have a different number of arguments, even if their
* bodies are identical. Note that we don't use Tcl_DuplicateObj since
* we would not want any bytecode internal representation.
*/
if (Tcl_IsShared(bodyPtr)) {
#ifdef TCL_TIP280
Tcl_Obj* sharedBodyPtr = bodyPtr;
#endif
bytes = Tcl_GetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
#ifdef TCL_TIP280
/*
* TIP #280.
* Ensure that the continuation line data for the original body is
* not lost and applies to the new body as well.
*/
TclContinuationsCopy (bodyPtr, sharedBodyPtr);
#endif
}
/*
* Create and initialize a Proc structure for the procedure. Note that
* we initialize its cmdPtr field below after we've created the command
* for the procedure. We increment the ref count of the procedure's
* body object since there will be a reference to it in the Proc
* structure.
*/
Tcl_IncrRefCount(bodyPtr);
procPtr = (Proc *) ckalloc(sizeof(Proc));
procPtr->iPtr = iPtr;
procPtr->refCount = 1;
procPtr->bodyPtr = bodyPtr;
procPtr->numArgs = 0; /* actual argument count is set below. */
procPtr->numCompiledLocals = 0;
procPtr->firstLocalPtr = NULL;
procPtr->lastLocalPtr = NULL;
}
/*
* Break up the argument list into argument specifiers, then process
* each argument specifier.
* If the body is precompiled, processing is limited to checking that
* the the parsed argument is consistent with the one stored in the
* Proc.
* THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS.
*/
args = Tcl_GetStringFromObj(argsPtr, &length);
result = Tcl_SplitList(interp, args, &numArgs, &argArray);
if (result != TCL_OK) {
goto procError;
}
if (precompiled) {
if (numArgs > procPtr->numArgs) {
char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];
sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d",
numArgs, procPtr->numArgs);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"procedure \"", procName,
buf, (char *) NULL);
goto procError;
}
localPtr = procPtr->firstLocalPtr;
} else {
procPtr->numArgs = numArgs;
procPtr->numCompiledLocals = numArgs;
}
for (i = 0; i < numArgs; i++) {
int fieldCount, nameLength, valueLength;
CONST char **fieldValues;
/*
* Now divide the specifier up into name and default.
*/
result = Tcl_SplitList(interp, argArray[i], &fieldCount,
&fieldValues);
if (result != TCL_OK) {
goto procError;
}
if (fieldCount > 2) {
ckfree((char *) fieldValues);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"too many fields in argument specifier \"",
argArray[i], "\"", (char *) NULL);
goto procError;
}
if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
ckfree((char *) fieldValues);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"procedure \"", procName,
"\" has argument with no name", (char *) NULL);
goto procError;
}
nameLength = strlen(fieldValues[0]);
if (fieldCount == 2) {
valueLength = strlen(fieldValues[1]);
} else {
valueLength = 0;
}
/*
* Check that the formal parameter name is a scalar.
*/
p = fieldValues[0];
while (*p != '\0') {
if (*p == '(') {
CONST char *q = p;
do {
q++;
} while (*q != '\0');
q--;
if (*q == ')') { /* we have an array element */
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"procedure \"", procName,
"\" has formal parameter \"", fieldValues[0],
"\" that is an array element",
(char *) NULL);
ckfree((char *) fieldValues);
goto procError;
}
} else if ((*p == ':') && (*(p+1) == ':')) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"procedure \"", procName,
"\" has formal parameter \"", fieldValues[0],
"\" that is not a simple name",
(char *) NULL);
ckfree((char *) fieldValues);
goto procError;
}
p++;
}
if (precompiled) {
/*
* Compare the parsed argument with the stored one.
* For the flags, we and out VAR_UNDEFINED to support bridging
* precompiled <= 8.3 code in 8.4 where this is now used as an
* optimization indicator. Yes, this is a hack. -- hobbs
*/
if ((localPtr->nameLength != nameLength)
|| (strcmp(localPtr->name, fieldValues[0]))
|| (localPtr->frameIndex != i)
|| ((localPtr->flags & ~VAR_UNDEFINED)
!= (VAR_SCALAR | VAR_ARGUMENT))
|| ((localPtr->defValuePtr == NULL)
&& (fieldCount == 2))
|| ((localPtr->defValuePtr != NULL)
&& (fieldCount != 2))) {
char buf[80 + TCL_INTEGER_SPACE];
sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body",
i);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"procedure \"", procName,
buf, (char *) NULL);
ckfree((char *) fieldValues);
goto procError;
}
/*
* compare the default value if any
*/
if (localPtr->defValuePtr != NULL) {
int tmpLength;
char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
&tmpLength);
if ((valueLength != tmpLength)
|| (strncmp(fieldValues[1], tmpPtr,
(size_t) tmpLength))) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"procedure \"", procName,
"\": formal parameter \"",
fieldValues[0],
"\" has default value inconsistent with precompiled body",
(char *) NULL);
ckfree((char *) fieldValues);
goto procError;
}
}
localPtr = localPtr->nextPtr;
} else {
/*
* Allocate an entry in the runtime procedure frame's array of
* local variables for the argument.
*/
localPtr = (CompiledLocal *) ckalloc((unsigned)
(sizeof(CompiledLocal) - sizeof(localPtr->name)
+ nameLength+1));
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
localPtr->nameLength = nameLength;
localPtr->frameIndex = i;
localPtr->flags = VAR_SCALAR | VAR_ARGUMENT;
localPtr->resolveInfo = NULL;
if (fieldCount == 2) {
localPtr->defValuePtr =
Tcl_NewStringObj(fieldValues[1], valueLength);
Tcl_IncrRefCount(localPtr->defValuePtr);
} else {
localPtr->defValuePtr = NULL;
}
memcpy(localPtr->name, fieldValues[0], nameLength + 1);
}
ckfree((char *) fieldValues);
}
/*
* Now initialize the new procedure's cmdPtr field. This will be used
* later when the procedure is called to determine what namespace the
* procedure will run in. This will be different than the current
* namespace if the proc was renamed into a different namespace.
*/
*procPtrPtr = procPtr;
ckfree((char *) argArray);
return TCL_OK;
procError:
if (precompiled) {
procPtr->refCount--;
} else {
Tcl_DecrRefCount(bodyPtr);
while (procPtr->firstLocalPtr != NULL) {
localPtr = procPtr->firstLocalPtr;
procPtr->firstLocalPtr = localPtr->nextPtr;
defPtr = localPtr->defValuePtr;
if (defPtr != NULL) {
Tcl_DecrRefCount(defPtr);
}
ckfree((char *) localPtr);
}
ckfree((char *) procPtr);
}
if (argArray != NULL) {
ckfree((char *) argArray);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclGetFrame --
*
* Given a description of a procedure frame, such as the first
* argument to an "uplevel" or "upvar" command, locate the
* call frame for the appropriate level of procedure.
*
* Results:
* The return value is -1 if an error occurred in finding the frame
* (in this case an error message is left in the interp's result).
* 1 is returned if string was either a number or a number preceded
* by "#" and it specified a valid frame. 0 is returned if string
* isn't one of the two things above (in this case, the lookup
* acts as if string were "1"). The variable pointed to by
* framePtrPtr is filled in with the address of the desired frame
* (unless an error occurs, in which case it isn't modified).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclGetFrame(interp, string, framePtrPtr)
Tcl_Interp *interp; /* Interpreter in which to find frame. */
CONST char *string; /* String describing frame. */
CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
* if global frame indicated). */
{
register Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
CallFrame *framePtr;
/*
* Parse string to figure out which level number to go to.
*/
result = 1;
curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
if (*string == '#') {
if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
return -1;
}
if (level < 0) {
levelError:
Tcl_AppendResult(interp, "bad level \"", string, "\"",
(char *) NULL);
return -1;
}
} else if (isdigit(UCHAR(*string))) { /* INTL: digit */
if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
return -1;
}
level = curLevel - level;
} else {
level = curLevel - 1;
result = 0;
}
/*
* Figure out which frame to use, and modify the interpreter so
* its variables come from that frame.
*/
if (level == 0) {
framePtr = NULL;
} else {
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
framePtr = framePtr->callerVarPtr) {
if (framePtr->level == level) {
break;
}
}
if (framePtr == NULL) {
goto levelError;
}
}
*framePtrPtr = framePtr;
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UplevelObjCmd --
*
* This object procedure is invoked to process the "uplevel" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_UplevelObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
char *optLevel;
int result;
CallFrame *savedVarFramePtr, *framePtr;
if (objc < 2) {
uplevelSyntax:
Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
return TCL_ERROR;
}
/*
* Find the level to use for executing the command.
*/
optLevel = TclGetString(objv[1]);
result = TclGetFrame(interp, optLevel, &framePtr);
if (result == -1) {
return TCL_ERROR;
}
objc -= (result+1);
if (objc == 0) {
goto uplevelSyntax;
}
objv += (result+1);
/*
* Modify the interpreter state to execute in the given frame.
*/
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = framePtr;
/*
* Execute the residual arguments as a command.
*/
if (objc == 1) {
#ifdef TCL_TIP280
/* TIP #280. Make argument location available to eval'd script */
CmdFrame* invoker = NULL;
int word = 0;
TclArgumentGet (interp, objv[0], &invoker, &word);
result = TclEvalObjEx(interp, objv[0], TCL_EVAL_DIRECT, invoker, word);
#else
result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
#endif
} else {
/*
* More than one argument: concatenate them together with spaces
* between, then evaluate the result. Tcl_EvalObjEx will delete
* the object when it decrements its refcount after eval'ing it.
*/
Tcl_Obj *objPtr;
objPtr = Tcl_ConcatObj(objc, objv);
result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
}
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
/*
* Restore the variable frame, and return.
*/
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
/*
*----------------------------------------------------------------------
*
* TclFindProc --
*
* Given the name of a procedure, return a pointer to the
* record describing the procedure. The procedure will be
* looked up using the usual rules: first in the current
* namespace and then in the global namespace.
*
* Results:
* NULL is returned if the name doesn't correspond to any
* procedure. Otherwise, the return value is a pointer to
* the procedure's record. If the name is found but refers
* to an imported command that points to a "real" procedure
* defined in another namespace, a pointer to that "real"
* procedure's structure is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Proc *
TclFindProc(iPtr, procName)
Interp *iPtr; /* Interpreter in which to look. */
CONST char *procName; /* Name of desired procedure. */
{
Tcl_Command cmd;
Tcl_Command origCmd;
Command *cmdPtr;
cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName,
(Tcl_Namespace *) NULL, /*flags*/ 0);
if (cmd == (Tcl_Command) NULL) {
return NULL;
}
cmdPtr = (Command *) cmd;
origCmd = TclGetOriginalCommand(cmd);
if (origCmd != NULL) {
cmdPtr = (Command *) origCmd;
}
if (cmdPtr->proc != TclProcInterpProc) {
return NULL;
}
return (Proc *) cmdPtr->clientData;
}
/*
*----------------------------------------------------------------------
*
* TclIsProc --
*
* Tells whether a command is a Tcl procedure or not.
*
* Results:
* If the given command is actually a Tcl procedure, the
* return value is the address of the record describing
* the procedure. Otherwise the return value is 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Proc *
TclIsProc(cmdPtr)
Command *cmdPtr; /* Command to test. */
{
Tcl_Command origCmd;
origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (origCmd != NULL) {
cmdPtr = (Command *) origCmd;
}
if (cmdPtr->proc == TclProcInterpProc) {
return (Proc *) cmdPtr->clientData;
}
return (Proc *) 0;
}
/*
*----------------------------------------------------------------------
*
* TclProcInterpProc --
*
* When a Tcl procedure gets invoked with an argc/argv array of
* strings, this routine gets invoked to interpret the procedure.
*
* Results:
* A standard Tcl result value, usually TCL_OK.
*
* Side effects:
* Depends on the commands in the procedure.
*
*----------------------------------------------------------------------
*/
int
TclProcInterpProc(clientData, interp, argc, argv)
ClientData clientData; /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp; /* Interpreter in which procedure was
* invoked. */
int argc; /* Count of number of arguments to this
* procedure. */
register CONST char **argv; /* Argument values. */
{
register Tcl_Obj *objPtr;
register int i;
int result;
/*
* This procedure generates an objv array for object arguments that hold
* the argv strings. It starts out with stack-allocated space but uses
* dynamically-allocated storage if needed.
*/
#define NUM_ARGS 20
Tcl_Obj *(objStorage[NUM_ARGS]);
register Tcl_Obj **objv = objStorage;
/*
* Create the object argument array "objv". Make sure objv is large
* enough to hold the objc arguments plus 1 extra for the zero
* end-of-objv word.
*/
if ((argc + 1) > NUM_ARGS) {
objv = (Tcl_Obj **)
ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
}
for (i = 0; i < argc; i++) {
objv[i] = Tcl_NewStringObj(argv[i], -1);
Tcl_IncrRefCount(objv[i]);
}
objv[argc] = 0;
/*
* Use TclObjInterpProc to actually interpret the procedure.
*/
result = TclObjInterpProc(clientData, interp, argc, objv);
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
/*
* Decrement the ref counts on the objv elements since we are done
* with them.
*/
for (i = 0; i < argc; i++) {
objPtr = objv[i];
TclDecrRefCount(objPtr);
}
/*
* Free the objv array if malloc'ed storage was used.
*/
if (objv != objStorage) {
ckfree((char *) objv);
}
return result;
#undef NUM_ARGS
}
/*
*----------------------------------------------------------------------
*
* TclObjInterpProc --
*
* When a Tcl procedure gets invoked during bytecode evaluation, this
* object-based routine gets invoked to interpret the procedure.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* Depends on the commands in the procedure.
*
*----------------------------------------------------------------------
*/
int
TclObjInterpProc(clientData, interp, objc, objv)
ClientData clientData; /* Record describing procedure to be
* interpreted. */
register Tcl_Interp *interp; /* Interpreter in which procedure was
* invoked. */
int objc; /* Count of number of arguments to this
* procedure. */
Tcl_Obj *CONST objv[]; /* Argument value objects. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = (Proc *) clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame frame;
register CallFrame *framePtr = &frame;
register Var *varPtr;
register CompiledLocal *localPtr;
char *procName;
int nameLen, localCt, numArgs, argCt, i, result;
/*
* This procedure generates an array "compiledLocals" that holds the
* storage for local variables. It starts out with stack-allocated space
* but uses dynamically-allocated storage if needed.
*/
#define NUM_LOCALS 20
Var localStorage[NUM_LOCALS];
Var *compiledLocals = localStorage;
/*
* Get the procedure's name.
*/
procName = Tcl_GetStringFromObj(objv[0], &nameLen);
/*
* If necessary, compile the procedure's body. The compiler will
* allocate frame slots for the procedure's non-argument local
* variables. Note that compiling the body might increase
* procPtr->numCompiledLocals if new local variables are found
* while compiling.
*/
result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
"body of proc", procName, &procPtr);
if (result != TCL_OK) {
return result;
}
/*
* Create the "compiledLocals" array. Make sure it is large enough to
* hold all the procedure's compiled local variables, including its
* formal parameters.
*/
localCt = procPtr->numCompiledLocals;
if (localCt > NUM_LOCALS) {
compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var));
}
/*
* Set up and push a new call frame for the new procedure invocation.
* This call frame will execute in the proc's namespace, which might
* be different than the current namespace. The proc's namespace is
* that of its command, which can change if the command is renamed
* from one namespace to another.
*/
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1);
if (result != TCL_OK) {
return result;
}
framePtr->objc = objc;
framePtr->objv = objv; /* ref counts for args are incremented below */
/*
* Initialize and resolve compiled variable references.
*/
framePtr->procPtr = procPtr;
framePtr->numCompiledLocals = localCt;
framePtr->compiledLocals = compiledLocals;
TclInitCompiledLocals(interp, framePtr, nsPtr);
/*
* Match and assign the call's actual parameters to the procedure's
* formal arguments. The formal arguments are described by the first
* numArgs entries in both the Proc structure's local variable list and
* the call frame's local variable array.
*/
numArgs = procPtr->numArgs;
varPtr = framePtr->compiledLocals;
localPtr = procPtr->firstLocalPtr;
argCt = objc;
for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) {
if (!TclIsVarArgument(localPtr)) {
panic("TclObjInterpProc: local variable %s is not argument but should be",
localPtr->name);
return TCL_ERROR;
}
if (TclIsVarTemporary(localPtr)) {
panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i);
return TCL_ERROR;
}
/*
* Handle the special case of the last formal being "args". When
* it occurs, assign it a list consisting of all the remaining
* actual arguments.
*/
if ((i == numArgs) && ((localPtr->name[0] == 'a')
&& (strcmp(localPtr->name, "args") == 0))) {
Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
varPtr->value.objPtr = listPtr;
Tcl_IncrRefCount(listPtr); /* local var is a reference */
TclClearVarUndefined(varPtr);
argCt = 0;
break; /* done processing args */
} else if (argCt > 0) {
Tcl_Obj *objPtr = objv[i];
varPtr->value.objPtr = objPtr;
TclClearVarUndefined(varPtr);
Tcl_IncrRefCount(objPtr); /* since the local variable now has
* another reference to object. */
} else if (localPtr->defValuePtr != NULL) {
Tcl_Obj *objPtr = localPtr->defValuePtr;
varPtr->value.objPtr = objPtr;
TclClearVarUndefined(varPtr);
Tcl_IncrRefCount(objPtr); /* since the local variable now has
* another reference to object. */
} else {
goto incorrectArgs;
}
varPtr++;
localPtr = localPtr->nextPtr;
}
if (argCt > 0) {
Tcl_Obj *objResult;
int len, flags;
incorrectArgs:
/*
* Build up equivalent to Tcl_WrongNumArgs message for proc
*/
Tcl_ResetResult(interp);
objResult = Tcl_GetObjResult(interp);
Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1);
/*
* Quote the proc name if it contains spaces (Bug 942757).
*/
len = Tcl_ScanCountedElement(procName, nameLen, &flags);
if (len != nameLen) {
char *procName1 = ckalloc((unsigned) len + 1);
len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags);
Tcl_AppendToObj(objResult, procName1, len);
ckfree(procName1);
} else {
Tcl_AppendToObj(objResult, procName, len);
}
localPtr = procPtr->firstLocalPtr;
for (i = 1; i <= numArgs; i++) {
if (localPtr->defValuePtr != NULL) {
Tcl_AppendStringsToObj(objResult,
" ?", localPtr->name, "?", (char *) NULL);
} else {
Tcl_AppendStringsToObj(objResult,
" ", localPtr->name, (char *) NULL);
}
localPtr = localPtr->nextPtr;
}
Tcl_AppendStringsToObj(objResult, "\"", (char *) NULL);
result = TCL_ERROR;
goto procDone;
}
/*
* Invoke the commands in the procedure's body.
*/
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 1) {
fprintf(stdout, "Calling proc ");
for (i = 0; i < objc; i++) {
TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
fflush(stdout);
}
#endif /*TCL_COMPILE_DEBUG*/
#ifdef USE_DTRACE
if (TCL_DTRACE_PROC_ARGS_ENABLED()) {
char *a[10];
int i = 0;
while (i < 10) {
a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
}
TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
a[8], a[9]);
}
#endif /* USE_DTRACE */
iPtr->returnCode = TCL_OK;
procPtr->refCount++;
if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
TCL_DTRACE_PROC_ENTRY(TclGetString(objv[0]), objc - 1,
(Tcl_Obj **)(objv + 1));
}
#ifndef TCL_TIP280
result = TclCompEvalObj(interp, procPtr->bodyPtr);
#else
/* TIP #280: No need to set the invoking context here. The body has
* already been compiled, so the part of CompEvalObj using it is bypassed.
*/
result = TclCompEvalObj(interp, procPtr->bodyPtr, NULL, 0);
#endif
if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
TCL_DTRACE_PROC_RETURN(TclGetString(objv[0]), result);
}
procPtr->refCount--;
if (procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
if (result != TCL_OK) {
result = ProcessProcResultCode(interp, procName, nameLen, result);
}
#ifdef USE_DTRACE
if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
Tcl_Obj *r;
r = Tcl_GetObjResult(interp);
TCL_DTRACE_PROC_RESULT(TclGetString(objv[0]), result,
TclGetString(r), r);
}
#endif /* USE_DTRACE */
/*
* Pop and free the call frame for this procedure invocation, then
* free the compiledLocals array if malloc'ed storage was used.
*/
procDone:
Tcl_PopCallFrame(interp);
if (compiledLocals != localStorage) {
ckfree((char *) compiledLocals);
}
return result;
#undef NUM_LOCALS
}
/*
*----------------------------------------------------------------------
*
* TclProcCompileProc --
*
* Called just before a procedure is executed to compile the
* body to byte codes. If the type of the body is not
* "byte code" or if the compile conditions have changed
* (namespace context, epoch counters, etc.) then the body
* is recompiled. Otherwise, this procedure does nothing.
*
* Results:
* None.
*
* Side effects:
* May change the internal representation of the body object
* to compiled code.
*
*----------------------------------------------------------------------
*/
int
TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
Tcl_Interp *interp; /* Interpreter containing procedure. */
Proc *procPtr; /* Data associated with procedure. */
Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr,
* but could be any code fragment compiled
* in the context of this procedure.) */
Namespace *nsPtr; /* Namespace containing procedure. */
CONST char *description; /* string describing this body of code. */
CONST char *procName; /* Name of this procedure. */
{
return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr,
description, procName, NULL);
}
static int
ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
procName, procPtrPtr)
Tcl_Interp *interp; /* Interpreter containing procedure. */
Proc *procPtr; /* Data associated with procedure. */
Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr,
* but could be any code fragment compiled
* in the context of this procedure.) */
Namespace *nsPtr; /* Namespace containing procedure. */
CONST char *description; /* string describing this body of code. */
CONST char *procName; /* Name of this procedure. */
Proc **procPtrPtr; /* points to storage where a replacement
* (Proc *) value may be written, when
* appropriate */
{
Interp *iPtr = (Interp*)interp;
int i, result;
Tcl_CallFrame frame;
ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
CompiledLocal *localPtr;
/*
* If necessary, compile the procedure's body. The compiler will
* allocate frame slots for the procedure's non-argument local
* variables. If the ByteCode already exists, make sure it hasn't been
* invalidated by someone redefining a core command (this might make the
* compiled code wrong). Also, if the code was compiled in/for a
* different interpreter, we recompile it. Note that compiling the body
* might increase procPtr->numCompiledLocals if new local variables are
* found while compiling.
*
* Precompiled procedure bodies, however, are immutable and therefore
* they are not recompiled, even if things have changed.
*/
if (bodyPtr->typePtr == &tclByteCodeType) {
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)) {
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
Tcl_AppendResult(interp,
"a precompiled script jumped interps", NULL);
return TCL_ERROR;
}
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = nsPtr;
} else {
(*tclByteCodeType.freeIntRepProc)(bodyPtr);
bodyPtr->typePtr = (Tcl_ObjType *) NULL;
}
}
}
if (bodyPtr->typePtr != &tclByteCodeType) {
int numChars;
char *ellipsis;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile >= 1) {
/*
* Display a line summarizing the top level command we
* are about to compile.
*/
numChars = strlen(procName);
ellipsis = "";
if (numChars > 50) {
numChars = 50;
ellipsis = "...";
}
fprintf(stdout, "Compiling %s \"%.*s%s\"\n",
description, numChars, procName, ellipsis);
}
#endif
/*
* Plug the current procPtr into the interpreter and coerce
* the code body to byte codes. The interpreter needs to
* know which proc it's compiling so that it can access its
* list of compiled locals.
*
* TRICKY NOTE: Be careful to push a call frame with the
* proper namespace context, so that the byte codes are
* compiled in the appropriate class context.
*/
if (procPtrPtr != NULL && procPtr->refCount > 1) {
Tcl_Command token;
Tcl_CmdInfo info;
Proc *new = (Proc *) ckalloc(sizeof(Proc));
new->iPtr = procPtr->iPtr;
new->refCount = 1;
new->cmdPtr = procPtr->cmdPtr;
token = (Tcl_Command) new->cmdPtr;
new->bodyPtr = Tcl_DuplicateObj(bodyPtr);
bodyPtr = new->bodyPtr;
Tcl_IncrRefCount(bodyPtr);
new->numArgs = procPtr->numArgs;
new->numCompiledLocals = new->numArgs;
new->firstLocalPtr = NULL;
new->lastLocalPtr = NULL;
localPtr = procPtr->firstLocalPtr;
for (i = 0; i < new->numArgs; i++, localPtr = localPtr->nextPtr) {
CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned)
(sizeof(CompiledLocal) -sizeof(localPtr->name)
+ localPtr->nameLength + 1));
if (new->firstLocalPtr == NULL) {
new->firstLocalPtr = new->lastLocalPtr = copy;
} else {
new->lastLocalPtr->nextPtr = copy;
new->lastLocalPtr = copy;
}
copy->nextPtr = NULL;
copy->nameLength = localPtr->nameLength;
copy->frameIndex = localPtr->frameIndex;
copy->flags = localPtr->flags;
copy->defValuePtr = localPtr->defValuePtr;
if (copy->defValuePtr) {
Tcl_IncrRefCount(copy->defValuePtr);
}
copy->resolveInfo = localPtr->resolveInfo;
memcpy(copy->name, localPtr->name, localPtr->nameLength + 1);
}
/* Reset the ClientData */
Tcl_GetCommandInfoFromToken(token, &info);
if (info.objClientData == (ClientData) procPtr) {
info.objClientData = (ClientData) new;
}
if (info.clientData == (ClientData) procPtr) {
info.clientData = (ClientData) new;
}
if (info.deleteData == (ClientData) procPtr) {
info.deleteData = (ClientData) new;
}
Tcl_SetCommandInfoFromToken(token, &info);
procPtr->refCount--;
*procPtrPtr = procPtr = new;
}
iPtr->compiledProcPtr = procPtr;
result = Tcl_PushCallFrame(interp, &frame,
(Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0);
if (result == TCL_OK) {
#ifdef TCL_TIP280
/* TIP #280. We get the invoking context from the cmdFrame
* which was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
*/
Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
/* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
*/
iPtr->invokeWord = 0;
iPtr->invokeCmdFramePtr = (hePtr
? (CmdFrame*) Tcl_GetHashValue (hePtr)
: NULL);
#endif
result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
#ifdef TCL_TIP280
iPtr->invokeCmdFramePtr = NULL;
#endif
Tcl_PopCallFrame(interp);
}
if (result != TCL_OK) {
if (result == TCL_ERROR) {
char buf[100 + TCL_INTEGER_SPACE];
numChars = strlen(procName);
ellipsis = "";
if (numChars > 50) {
numChars = 50;
ellipsis = "...";
}
while ( (procName[numChars] & 0xC0) == 0x80 ) {
/*
* Back up truncation point so that we don't truncate
* in the middle of a multi-byte character (in UTF-8)
*/
numChars--;
ellipsis = "...";
}
sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)",
description, numChars, procName, ellipsis,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, buf, -1);
}
return result;
}
} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
/*
* The resolver epoch has changed, but we only need to invalidate
* the resolver cache.
*/
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
localPtr = localPtr->nextPtr) {
localPtr->flags &= ~(VAR_RESOLVED);
if (localPtr->resolveInfo) {
if (localPtr->resolveInfo->deleteProc) {
localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
} else {
ckfree((char*)localPtr->resolveInfo);
}
localPtr->resolveInfo = NULL;
}
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ProcessProcResultCode --
*
* Procedure called by TclObjInterpProc to process a return code other
* than TCL_OK returned by a Tcl procedure.
*
* Results:
* Depending on the argument return code, the result returned is
* another return code and the interpreter's result is set to a value
* to supplement that return code.
*
* Side effects:
* If the result returned is TCL_ERROR, traceback information about
* the procedure just executed is appended to the interpreter's
* "errorInfo" variable.
*
*----------------------------------------------------------------------
*/
static int
ProcessProcResultCode(interp, procName, nameLen, returnCode)
Tcl_Interp *interp; /* The interpreter in which the procedure
* was called and returned returnCode. */
char *procName; /* Name of the procedure. Used for error
* messages and trace information. */
int nameLen; /* Number of bytes in procedure's name. */
int returnCode; /* The unexpected result code. */
{
Interp *iPtr = (Interp *) interp;
char msg[100 + TCL_INTEGER_SPACE];
char *ellipsis = "";
if (returnCode == TCL_OK) {
return TCL_OK;
}
if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
return returnCode;
}
if (returnCode == TCL_RETURN) {
return TclUpdateReturnInfo(iPtr);
}
if (returnCode != TCL_ERROR) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK)
? "invoked \"break\" outside of a loop"
: "invoked \"continue\" outside of a loop"), -1);
}
if (nameLen > 60) {
nameLen = 60;
ellipsis = "...";
}
while ( (procName[nameLen] & 0xC0) == 0x80 ) {
/*
* Back up truncation point so that we don't truncate in the
* middle of a multi-byte character (in UTF-8)
*/
nameLen--;
ellipsis = "...";
}
sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", nameLen, procName,
ellipsis, iPtr->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclProcDeleteProc --
*
* This procedure is invoked just before a command procedure is
* removed from an interpreter. Its job is to release all the
* resources allocated to the procedure.
*
* Results:
* None.
*
* Side effects:
* Memory gets freed, unless the procedure is actively being
* executed. In this case the cleanup is delayed until the
* last call to the current procedure completes.
*
*----------------------------------------------------------------------
*/
void
TclProcDeleteProc(clientData)
ClientData clientData; /* Procedure to be deleted. */
{
Proc *procPtr = (Proc *) clientData;
procPtr->refCount--;
if (procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclProcCleanupProc --
*
* This procedure does all the real work of freeing up a Proc
* structure. It's called only when the structure's reference
* count becomes zero.
*
* Results:
* None.
*
* Side effects:
* Memory gets freed.
*
*----------------------------------------------------------------------
*/
void
TclProcCleanupProc(procPtr)
register Proc *procPtr; /* Procedure to be deleted. */
{
register CompiledLocal *localPtr;
Tcl_Obj *bodyPtr = procPtr->bodyPtr;
Tcl_Obj *defPtr;
Tcl_ResolvedVarInfo *resVarInfo;
#ifdef TCL_TIP280
Tcl_HashEntry* hePtr = NULL;
CmdFrame* cfPtr = NULL;
Interp* iPtr = procPtr->iPtr;
#endif
if (bodyPtr != NULL) {
Tcl_DecrRefCount(bodyPtr);
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
CompiledLocal *nextPtr = localPtr->nextPtr;
resVarInfo = localPtr->resolveInfo;
if (resVarInfo) {
if (resVarInfo->deleteProc) {
(*resVarInfo->deleteProc)(resVarInfo);
} else {
ckfree((char *) resVarInfo);
}
}
if (localPtr->defValuePtr != NULL) {
defPtr = localPtr->defValuePtr;
Tcl_DecrRefCount(defPtr);
}
ckfree((char *) localPtr);
localPtr = nextPtr;
}
ckfree((char *) procPtr);
#ifdef TCL_TIP280
/* TIP #280. Release the location data associated with this Proc
* structure, if any. The interpreter may not exist (For example for
* procbody structurues created by tbcload.
*/
if (!iPtr) return;
hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
if (!hePtr) return;
cfPtr = (CmdFrame*) Tcl_GetHashValue (hePtr);
if (cfPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (cfPtr->data.eval.path);
cfPtr->data.eval.path = NULL;
}
ckfree ((char*) cfPtr->line); cfPtr->line = NULL;
ckfree ((char*) cfPtr);
Tcl_DeleteHashEntry (hePtr);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclUpdateReturnInfo --
*
* This procedure is called when procedures return, and at other
* points where the TCL_RETURN code is used. It examines fields
* such as iPtr->returnCode and iPtr->errorCode and modifies
* the real return status accordingly.
*
* Results:
* The return value is the true completion code to use for
* the procedure, instead of TCL_RETURN.
*
* Side effects:
* The errorInfo and errorCode variables may get modified.
*
*----------------------------------------------------------------------
*/
int
TclUpdateReturnInfo(iPtr)
Interp *iPtr; /* Interpreter for which TCL_RETURN
* exception is being processed. */
{
int code;
char *errorCode;
Tcl_Obj *objPtr;
code = iPtr->returnCode;
iPtr->returnCode = TCL_OK;
if (code == TCL_ERROR) {
errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
objPtr = Tcl_NewStringObj(errorCode, -1);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
NULL, objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
iPtr->flags |= ERROR_CODE_SET;
if (iPtr->errorInfo != NULL) {
objPtr = Tcl_NewStringObj(iPtr->errorInfo, -1);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
NULL, objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
iPtr->flags |= ERR_IN_PROGRESS;
}
}
return code;
}
/*
*----------------------------------------------------------------------
*
* TclGetInterpProc --
*
* Returns a pointer to the TclProcInterpProc procedure; this is different
* from the value obtained from the TclProcInterpProc reference on systems
* like Windows where import and export versions of a procedure exported
* by a DLL exist.
*
* Results:
* Returns the internal address of the TclProcInterpProc procedure.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
TclCmdProcType
TclGetInterpProc()
{
return (TclCmdProcType) TclProcInterpProc;
}
/*
*----------------------------------------------------------------------
*
* TclGetObjInterpProc --
*
* Returns a pointer to the TclObjInterpProc procedure; this is different
* from the value obtained from the TclObjInterpProc reference on systems
* like Windows where import and export versions of a procedure exported
* by a DLL exist.
*
* Results:
* Returns the internal address of the TclObjInterpProc procedure.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
TclObjCmdProcType
TclGetObjInterpProc()
{
return (TclObjCmdProcType) TclObjInterpProc;
}
/*
*----------------------------------------------------------------------
*
* TclNewProcBodyObj --
*
* Creates a new object, of type "procbody", whose internal
* representation is the given Proc struct.
* The newly created object's reference count is 0.
*
* Results:
* Returns a pointer to a newly allocated Tcl_Obj, 0 on error.
*
* Side effects:
* The reference count in the ByteCode attached to the Proc is bumped up
* by one, since the internal rep stores a pointer to it.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclNewProcBodyObj(procPtr)
Proc *procPtr; /* the Proc struct to store as the internal
* representation. */
{
Tcl_Obj *objPtr;
if (!procPtr) {
return (Tcl_Obj *) NULL;
}
objPtr = Tcl_NewStringObj("", 0);
if (objPtr) {
objPtr->typePtr = &tclProcBodyType;
objPtr->internalRep.otherValuePtr = (VOID *) procPtr;
procPtr->refCount++;
}
return objPtr;
}
/*
*----------------------------------------------------------------------
*
* ProcBodyDup --
*
* Tcl_ObjType's Dup function for the proc body object.
* Bumps the reference count on the Proc stored in the internal
* representation.
*
* Results:
* None.
*
* Side effects:
* Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
*
*----------------------------------------------------------------------
*/
static void ProcBodyDup(srcPtr, dupPtr)
Tcl_Obj *srcPtr; /* object to copy */
Tcl_Obj *dupPtr; /* target object for the duplication */
{
Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr;
dupPtr->typePtr = &tclProcBodyType;
dupPtr->internalRep.otherValuePtr = (VOID *) procPtr;
procPtr->refCount++;
}
/*
*----------------------------------------------------------------------
*
* ProcBodyFree --
*
* Tcl_ObjType's Free function for the proc body object.
* The reference count on its Proc struct is decreased by 1; if the count
* reaches 0, the proc is freed.
*
* Results:
* None.
*
* Side effects:
* If the reference count on the Proc struct reaches 0, the struct is freed.
*
*----------------------------------------------------------------------
*/
static void
ProcBodyFree(objPtr)
Tcl_Obj *objPtr; /* the object to clean up */
{
Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr;
procPtr->refCount--;
if (procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
}
/*
*----------------------------------------------------------------------
*
* ProcBodySetFromAny --
*
* Tcl_ObjType's SetFromAny function for the proc body object.
* Calls panic.
*
* Results:
* Theoretically returns a TCL result code.
*
* Side effects:
* Calls panic, since we can't set the value of the object from a string
* representation (or any other internal ones).
*
*----------------------------------------------------------------------
*/
static int
ProcBodySetFromAny(interp, objPtr)
Tcl_Interp *interp; /* current interpreter */
Tcl_Obj *objPtr; /* object pointer */
{
panic("called ProcBodySetFromAny");
/*
* this to keep compilers happy.
*/
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ProcBodyUpdateString --
*
* Tcl_ObjType's UpdateString function for the proc body object.
* Calls panic.
*
* Results:
* None.
*
* Side effects:
* Calls panic, since we this type has no string representation.
*
*----------------------------------------------------------------------
*/
static void
ProcBodyUpdateString(objPtr)
Tcl_Obj *objPtr; /* the object to update */
{
panic("called ProcBodyUpdateString");
}
/*
*----------------------------------------------------------------------
*
* TclCompileNoOp --
*
* Procedure called to compile noOp's
*
* Results:
* The return value is TCL_OK, indicating successful compilation.
*
* Side effects:
* Instructions are added to envPtr to execute a noOp at runtime.
*
*----------------------------------------------------------------------
*/
static int
TclCompileNoOp(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int i, code;
int savedStackDepth = envPtr->currStackDepth;
tokenPtr = parsePtr->tokenPtr;
for(i = 1; i < parsePtr->numWords; i++) {
tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
envPtr->currStackDepth = savedStackDepth;
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
code = TclCompileTokens(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
TclEmitOpcode(INST_POP, envPtr);
}
}
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclParse.c 0000644 0036047 0045461 00000155260 11737050674 014265 0 ustar dgp 771div /*
* tclParse.c --
*
* This file contains procedures that parse Tcl scripts. They
* do so in a general-purpose fashion that can be used for many
* different purposes, including compilation, direct execution,
* code analysis, etc.
*
* Copyright (c) 1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 Ajuba Solutions.
* Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* The following table provides parsing information about each possible
* 8-bit character. The table is designed to be referenced with either
* signed or unsigned characters, so it has 384 entries. The first 128
* entries correspond to negative character values, the next 256 correspond
* to positive character values. The last 128 entries are identical to the
* first 128. The table is always indexed with a 128-byte offset (the 128th
* entry corresponds to a character value of 0).
*
* The macro CHAR_TYPE is used to index into the table and return
* information about its character argument. The following return
* values are defined.
*
* TYPE_NORMAL - All characters that don't have special significance
* to the Tcl parser.
* TYPE_SPACE - The character is a whitespace character other
* than newline.
* TYPE_COMMAND_END - Character is newline or semicolon.
* TYPE_SUBS - Character begins a substitution or has other
* special meaning in ParseTokens: backslash, dollar
* sign, or open bracket.
* TYPE_QUOTE - Character is a double quote.
* TYPE_CLOSE_PAREN - Character is a right parenthesis.
* TYPE_CLOSE_BRACK - Character is a right square bracket.
* TYPE_BRACE - Character is a curly brace (either left or right).
*/
#define TYPE_NORMAL 0
#define TYPE_SPACE 0x1
#define TYPE_COMMAND_END 0x2
#define TYPE_SUBS 0x4
#define TYPE_QUOTE 0x8
#define TYPE_CLOSE_PAREN 0x10
#define TYPE_CLOSE_BRACK 0x20
#define TYPE_BRACE 0x40
#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)]
static CONST char charTypeTable[] = {
/*
* Negative character values, from -128 to -1:
*/
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
/*
* Positive character values, from 0-127:
*/
TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_SPACE, TYPE_COMMAND_END, TYPE_SPACE,
TYPE_SPACE, TYPE_SPACE, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_SPACE, TYPE_NORMAL, TYPE_QUOTE, TYPE_NORMAL,
TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_CLOSE_PAREN, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_COMMAND_END,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_SUBS,
TYPE_SUBS, TYPE_CLOSE_BRACK, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_BRACE,
TYPE_NORMAL, TYPE_BRACE, TYPE_NORMAL, TYPE_NORMAL,
/*
* Large unsigned character values, from 128-255:
*/
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
};
/*
* Prototypes for local procedures defined in this file:
*/
static int CommandComplete _ANSI_ARGS_((CONST char *script,
int numBytes));
static int ParseComment _ANSI_ARGS_((CONST char *src, int numBytes,
Tcl_Parse *parsePtr));
static int ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes,
int mask, Tcl_Parse *parsePtr));
/*
*----------------------------------------------------------------------
*
* Tcl_ParseCommand --
*
* Given a string, this procedure parses the first Tcl command
* in the string and returns information about the structure of
* the command.
*
* Results:
* The return value is TCL_OK if the command was parsed
* successfully and TCL_ERROR otherwise. If an error occurs
* and interp isn't NULL then an error message is left in
* its result. On a successful return, parsePtr is filled in
* with information about the command that was parsed.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the command, then additional space is
* malloc-ed. If the procedure returns TCL_OK then the caller must
* eventually invoke Tcl_FreeParse to release any additional space
* that was allocated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
CONST char *string; /* First character of string containing
* one or more Tcl commands. */
register int numBytes; /* Total number of bytes in string. If < 0,
* the script consists of all bytes up to
* the first null character. */
int nested; /* Non-zero means this is a nested command:
* close bracket should be considered
* a command terminator. If zero, then close
* bracket has no special meaning. */
register Tcl_Parse *parsePtr;
/* Structure to fill in with information
* about the parsed command; any previous
* information in the structure is
* ignored. */
{
register CONST char *src; /* Points to current character
* in the command. */
char type; /* Result returned by CHAR_TYPE(*src). */
Tcl_Token *tokenPtr; /* Pointer to token being filled in. */
int wordIndex; /* Index of word token for current word. */
int terminators; /* CHAR_TYPE bits that indicate the end
* of a command. */
CONST char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
int scanned;
if ((string == NULL) && (numBytes!=0)) {
if (interp != NULL) {
Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC);
}
return TCL_ERROR;
}
if (numBytes < 0) {
numBytes = strlen(string);
}
parsePtr->commentStart = NULL;
parsePtr->commentSize = 0;
parsePtr->commandStart = NULL;
parsePtr->commandSize = 0;
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
parsePtr->end = string + numBytes;
parsePtr->term = parsePtr->end;
parsePtr->interp = interp;
parsePtr->incomplete = 0;
parsePtr->errorType = TCL_PARSE_SUCCESS;
if (nested != 0) {
terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
} else {
terminators = TYPE_COMMAND_END;
}
/*
* Parse any leading space and comments before the first word of the
* command.
*/
scanned = ParseComment(string, numBytes, parsePtr);
src = (string + scanned); numBytes -= scanned;
if (numBytes == 0) {
if (nested) {
parsePtr->incomplete = nested;
}
}
/*
* The following loop parses the words of the command, one word
* in each iteration through the loop.
*/
parsePtr->commandStart = src;
while (1) {
/*
* Create the token for the word.
*/
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
wordIndex = parsePtr->numTokens;
tokenPtr = &parsePtr->tokenPtr[wordIndex];
tokenPtr->type = TCL_TOKEN_WORD;
/*
* Skip white space before the word. Also skip a backslash-newline
* sequence: it should be treated just like white space.
*/
scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
src += scanned; numBytes -= scanned;
if (numBytes == 0) {
parsePtr->term = src;
break;
}
if ((type & terminators) != 0) {
parsePtr->term = src;
src++;
break;
}
tokenPtr->start = src;
parsePtr->numTokens++;
parsePtr->numWords++;
/*
* At this point the word can have one of three forms: something
* enclosed in quotes, something enclosed in braces, or an
* unquoted word (anything else).
*/
if (*src == '"') {
if (Tcl_ParseQuotedString(interp, src, numBytes,
parsePtr, 1, &termPtr) != TCL_OK) {
goto error;
}
src = termPtr; numBytes = parsePtr->end - src;
} else if (*src == '{') {
if (Tcl_ParseBraces(interp, src, numBytes,
parsePtr, 1, &termPtr) != TCL_OK) {
goto error;
}
src = termPtr; numBytes = parsePtr->end - src;
} else {
/*
* This is an unquoted word. Call ParseTokens and let it do
* all of the work.
*/
if (ParseTokens(src, numBytes, TYPE_SPACE|terminators,
parsePtr) != TCL_OK) {
goto error;
}
src = parsePtr->term; numBytes = parsePtr->end - src;
}
/*
* Finish filling in the token for the word and check for the
* special case of a word consisting of a single range of
* literal text.
*/
tokenPtr = &parsePtr->tokenPtr[wordIndex];
tokenPtr->size = src - tokenPtr->start;
tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
if ((tokenPtr->numComponents == 1)
&& (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
}
/*
* Do two additional checks: (a) make sure we're really at the
* end of a word (there might have been garbage left after a
* quoted or braced word), and (b) check for the end of the
* command.
*/
scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
if (scanned) {
src += scanned; numBytes -= scanned;
continue;
}
if (numBytes == 0) {
parsePtr->term = src;
break;
}
if ((type & terminators) != 0) {
parsePtr->term = src;
src++;
break;
}
if (src[-1] == '"') {
if (interp != NULL) {
Tcl_SetResult(interp, "extra characters after close-quote",
TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
} else {
if (interp != NULL) {
Tcl_SetResult(interp, "extra characters after close-brace",
TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
}
parsePtr->term = src;
goto error;
}
parsePtr->commandSize = src - parsePtr->commandStart;
return TCL_OK;
error:
Tcl_FreeParse(parsePtr);
if (parsePtr->commandStart == NULL) {
parsePtr->commandStart = string;
}
parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclParseWhiteSpace --
*
* Scans up to numBytes bytes starting at src, consuming white
* space as defined by Tcl's parsing rules.
*
* Results:
* Returns the number of bytes recognized as white space. Records
* at parsePtr, information about the parse. Records at typePtr
* the character type of the non-whitespace character that terminated
* the scan.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclParseWhiteSpace(src, numBytes, parsePtr, typePtr)
CONST char *src; /* First character to parse. */
register int numBytes; /* Max number of bytes to scan. */
Tcl_Parse *parsePtr; /* Information about parse in progress.
* Updated if parsing indicates
* an incomplete command. */
char *typePtr; /* Points to location to store character
* type of character that ends run
* of whitespace */
{
register char type = TYPE_NORMAL;
register CONST char *p = src;
while (1) {
while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) {
numBytes--; p++;
}
if (numBytes && (type & TYPE_SUBS)) {
if (*p != '\\') {
break;
}
if (--numBytes == 0) {
break;
}
if (p[1] != '\n') {
break;
}
p+=2;
if (--numBytes == 0) {
parsePtr->incomplete = 1;
break;
}
continue;
}
break;
}
*typePtr = type;
return (p - src);
}
/*
*----------------------------------------------------------------------
*
* TclParseHex --
*
* Scans a hexadecimal number as a Tcl_UniChar value.
* (e.g., for parsing \x and \u escape sequences).
* At most numBytes bytes are scanned.
*
* Results:
* The numeric value is stored in *resultPtr.
* Returns the number of bytes consumed.
*
* Notes:
* Relies on the following properties of the ASCII
* character set, with which UTF-8 is compatible:
*
* The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z'
* occupy consecutive code points, and '0' < 'A' < 'a'.
*
*----------------------------------------------------------------------
*/
int
TclParseHex(src, numBytes, resultPtr)
CONST char *src; /* First character to parse. */
int numBytes; /* Max number of byes to scan */
Tcl_UniChar *resultPtr; /* Points to storage provided by
* caller where the Tcl_UniChar
* resulting from the conversion is
* to be written. */
{
Tcl_UniChar result = 0;
register CONST char *p = src;
while (numBytes--) {
unsigned char digit = UCHAR(*p);
if (!isxdigit(digit))
break;
++p;
result <<= 4;
if (digit >= 'a') {
result |= (10 + digit - 'a');
} else if (digit >= 'A') {
result |= (10 + digit - 'A');
} else {
result |= (digit - '0');
}
}
*resultPtr = result;
return (p - src);
}
/*
*----------------------------------------------------------------------
*
* TclParseBackslash --
*
* Scans up to numBytes bytes starting at src, consuming a
* backslash sequence as defined by Tcl's parsing rules.
*
* Results:
* Records at readPtr the number of bytes making up the backslash
* sequence. Records at dst the UTF-8 encoded equivalent of
* that backslash sequence. Returns the number of bytes written
* to dst, at most TCL_UTF_MAX. Either readPtr or dst may be
* NULL, if the results are not needed, but the return value is
* the same either way.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclParseBackslash(src, numBytes, readPtr, dst)
CONST char * src; /* Points to the backslash character of a
* a backslash sequence */
int numBytes; /* Max number of bytes to scan */
int *readPtr; /* NULL, or points to storage where the
* number of bytes scanned should be written. */
char *dst; /* NULL, or points to buffer where the UTF-8
* encoding of the backslash sequence is to be
* written. At most TCL_UTF_MAX bytes will be
* written there. */
{
register CONST char *p = src+1;
Tcl_UniChar result;
int count;
char buf[TCL_UTF_MAX];
if (numBytes == 0) {
if (readPtr != NULL) {
*readPtr = 0;
}
return 0;
}
if (dst == NULL) {
dst = buf;
}
if (numBytes == 1) {
/* Can only scan the backslash. Return it. */
result = '\\';
count = 1;
goto done;
}
count = 2;
switch (*p) {
/*
* Note: in the conversions below, use absolute values (e.g.,
* 0xa) rather than symbolic values (e.g. \n) that get converted
* by the compiler. It's possible that compilers on some
* platforms will do the symbolic conversions differently, which
* could result in non-portable Tcl scripts.
*/
case 'a':
result = 0x7;
break;
case 'b':
result = 0x8;
break;
case 'f':
result = 0xc;
break;
case 'n':
result = 0xa;
break;
case 'r':
result = 0xd;
break;
case 't':
result = 0x9;
break;
case 'v':
result = 0xb;
break;
case 'x':
count += TclParseHex(p+1, numBytes-2, &result);
if (count == 2) {
/* No hexadigits -> This is just "x". */
result = 'x';
} else {
/* Keep only the last byte (2 hex digits) */
result = (unsigned char) result;
}
break;
case 'u':
count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result);
if (count == 2) {
/* No hexadigits -> This is just "u". */
result = 'u';
}
break;
case '\n':
count--;
do {
p++; count++;
} while ((count < numBytes) && ((*p == ' ') || (*p == '\t')));
result = ' ';
break;
case 0:
result = '\\';
count = 1;
break;
default:
/*
* Check for an octal number \oo?o?
*/
if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */
result = (unsigned char)(*p - '0');
p++;
if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */
|| (UCHAR(*p) >= '8')) {
break;
}
count = 3;
result = (unsigned char)((result << 3) + (*p - '0'));
p++;
if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */
|| (UCHAR(*p) >= '8')) {
break;
}
count = 4;
result = (unsigned char)((result << 3) + (*p - '0'));
break;
}
/*
* We have to convert here in case the user has put a
* backslash in front of a multi-byte utf-8 character.
* While this means nothing special, we shouldn't break up
* a correct utf-8 character. [Bug #217987] test subst-3.2
*/
if (Tcl_UtfCharComplete(p, numBytes - 1)) {
count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */
} else {
char utfBytes[TCL_UTF_MAX];
memcpy(utfBytes, p, (size_t) (numBytes - 1));
utfBytes[numBytes - 1] = '\0';
count = Tcl_UtfToUniChar(utfBytes, &result) + 1;
}
break;
}
done:
if (readPtr != NULL) {
*readPtr = count;
}
return Tcl_UniCharToUtf((int) result, dst);
}
/*
*----------------------------------------------------------------------
*
* ParseComment --
*
* Scans up to numBytes bytes starting at src, consuming a
* Tcl comment as defined by Tcl's parsing rules.
*
* Results:
* Records in parsePtr information about the parse. Returns the
* number of bytes consumed.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ParseComment(src, numBytes, parsePtr)
CONST char *src; /* First character to parse. */
register int numBytes; /* Max number of bytes to scan. */
Tcl_Parse *parsePtr; /* Information about parse in progress.
* Updated if parsing indicates
* an incomplete command. */
{
register CONST char *p = src;
while (numBytes) {
char type;
int scanned;
do {
scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
p += scanned; numBytes -= scanned;
} while (numBytes && (*p == '\n') && (p++,numBytes--));
if ((numBytes == 0) || (*p != '#')) {
break;
}
if (parsePtr->commentStart == NULL) {
parsePtr->commentStart = p;
}
while (numBytes) {
if (*p == '\\') {
scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
if (scanned) {
p += scanned; numBytes -= scanned;
} else {
/*
* General backslash substitution in comments isn't
* part of the formal spec, but test parse-15.47
* and history indicate that it has been the de facto
* rule. Don't change it now.
*/
TclParseBackslash(p, numBytes, &scanned, NULL);
p += scanned; numBytes -= scanned;
}
} else {
p++; numBytes--;
if (p[-1] == '\n') {
break;
}
}
}
parsePtr->commentSize = p - parsePtr->commentStart;
}
return (p - src);
}
/*
*----------------------------------------------------------------------
*
* ParseTokens --
*
* This procedure forms the heart of the Tcl parser. It parses one
* or more tokens from a string, up to a termination point
* specified by the caller. This procedure is used to parse
* unquoted command words (those not in quotes or braces), words in
* quotes, and array indices for variables. No more than numBytes
* bytes will be scanned.
*
* Results:
* Tokens are added to parsePtr and parsePtr->term is filled in
* with the address of the character that terminated the parse (the
* first one whose CHAR_TYPE matched mask or the character at
* parsePtr->end). The return value is TCL_OK if the parse
* completed successfully and TCL_ERROR otherwise. If a parse
* error occurs and parsePtr->interp isn't NULL, then an error
* message is left in the interpreter's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ParseTokens(src, numBytes, mask, parsePtr)
register CONST char *src; /* First character to parse. */
register int numBytes; /* Max number of bytes to scan. */
int mask; /* Specifies when to stop parsing. The
* parse stops at the first unquoted
* character whose CHAR_TYPE contains
* any of the bits in mask. */
Tcl_Parse *parsePtr; /* Information about parse in progress.
* Updated with additional tokens and
* termination information. */
{
char type;
int originalTokens, varToken;
Tcl_Token *tokenPtr;
Tcl_Parse nested;
/*
* Each iteration through the following loop adds one token of
* type TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or
* TCL_TOKEN_VARIABLE to parsePtr. For TCL_TOKEN_VARIABLE tokens,
* additional tokens are added for the parsed variable name.
*/
originalTokens = parsePtr->numTokens;
while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) {
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->start = src;
tokenPtr->numComponents = 0;
if ((type & TYPE_SUBS) == 0) {
/*
* This is a simple range of characters. Scan to find the end
* of the range.
*/
while ((++src, --numBytes)
&& !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) {
/* empty loop */
}
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->size = src - tokenPtr->start;
parsePtr->numTokens++;
} else if (*src == '$') {
/*
* This is a variable reference. Call Tcl_ParseVarName to do
* all the dirty work of parsing the name.
*/
varToken = parsePtr->numTokens;
if (Tcl_ParseVarName(parsePtr->interp, src, numBytes,
parsePtr, 1) != TCL_OK) {
return TCL_ERROR;
}
src += parsePtr->tokenPtr[varToken].size;
numBytes -= parsePtr->tokenPtr[varToken].size;
} else if (*src == '[') {
/*
* Command substitution. Call Tcl_ParseCommand recursively
* (and repeatedly) to parse the nested command(s), then
* throw away the parse information.
*/
src++; numBytes--;
while (1) {
if (Tcl_ParseCommand(parsePtr->interp, src,
numBytes, 1, &nested) != TCL_OK) {
parsePtr->errorType = nested.errorType;
parsePtr->term = nested.term;
parsePtr->incomplete = nested.incomplete;
return TCL_ERROR;
}
src = nested.commandStart + nested.commandSize;
numBytes = parsePtr->end - src;
/*
* This is equivalent to Tcl_FreeParse(&nested), but
* presumably inlined here for sake of runtime optimization
*/
if (nested.tokenPtr != nested.staticTokens) {
ckfree((char *) nested.tokenPtr);
}
/*
* Check for the closing ']' that ends the command
* substitution. It must have been the last character of
* the parsed command.
*/
if ((nested.term < parsePtr->end) && (*nested.term == ']')
&& !nested.incomplete) {
break;
}
if (numBytes == 0) {
if (parsePtr->interp != NULL) {
Tcl_SetResult(parsePtr->interp,
"missing close-bracket", TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
parsePtr->term = tokenPtr->start;
parsePtr->incomplete = 1;
return TCL_ERROR;
}
}
tokenPtr->type = TCL_TOKEN_COMMAND;
tokenPtr->size = src - tokenPtr->start;
parsePtr->numTokens++;
} else if (*src == '\\') {
/*
* Backslash substitution.
*/
TclParseBackslash(src, numBytes, &tokenPtr->size, NULL);
if (tokenPtr->size == 1) {
/* Just a backslash, due to end of string */
tokenPtr->type = TCL_TOKEN_TEXT;
parsePtr->numTokens++;
src++; numBytes--;
continue;
}
if (src[1] == '\n') {
if (numBytes == 2) {
parsePtr->incomplete = 1;
}
/*
* Note: backslash-newline is special in that it is
* treated the same as a space character would be. This
* means that it could terminate the token.
*/
if (mask & TYPE_SPACE) {
if (parsePtr->numTokens == originalTokens) {
goto finishToken;
}
break;
}
}
tokenPtr->type = TCL_TOKEN_BS;
parsePtr->numTokens++;
src += tokenPtr->size;
numBytes -= tokenPtr->size;
} else if (*src == 0) {
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->size = 1;
parsePtr->numTokens++;
src++; numBytes--;
} else {
panic("ParseTokens encountered unknown character");
}
}
if (parsePtr->numTokens == originalTokens) {
/*
* There was nothing in this range of text. Add an empty token
* for the empty range, so that there is always at least one
* token added.
*/
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->start = src;
tokenPtr->numComponents = 0;
finishToken:
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->size = 0;
parsePtr->numTokens++;
}
parsePtr->term = src;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FreeParse --
*
* This procedure is invoked to free any dynamic storage that may
* have been allocated by a previous call to Tcl_ParseCommand.
*
* Results:
* None.
*
* Side effects:
* If there is any dynamically allocated memory in *parsePtr,
* it is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_FreeParse(parsePtr)
Tcl_Parse *parsePtr; /* Structure that was filled in by a
* previous call to Tcl_ParseCommand. */
{
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
ckfree((char *) parsePtr->tokenPtr);
parsePtr->tokenPtr = parsePtr->staticTokens;
}
}
/*
*----------------------------------------------------------------------
*
* TclExpandTokenArray --
*
* This procedure is invoked when the current space for tokens in
* a Tcl_Parse structure fills up; it allocates memory to grow the
* token array
*
* Results:
* None.
*
* Side effects:
* Memory is allocated for a new larger token array; the memory
* for the old array is freed, if it had been dynamically allocated.
*
*----------------------------------------------------------------------
*/
void
TclExpandTokenArray(parsePtr)
Tcl_Parse *parsePtr; /* Parse structure whose token space
* has overflowed. */
{
int newCount;
Tcl_Token *newPtr;
#define MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token))
if (parsePtr->tokensAvailable == MAX_TOKENS) {
Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", MAX_TOKENS);
}
newCount = parsePtr->tokensAvailable*2;
if (newCount > MAX_TOKENS) {
newCount = MAX_TOKENS;
}
newPtr = (Tcl_Token *) ckalloc((unsigned) (newCount * sizeof(Tcl_Token)));
memcpy((VOID *) newPtr, (VOID *) parsePtr->tokenPtr,
(size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token)));
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
ckfree((char *) parsePtr->tokenPtr);
}
parsePtr->tokenPtr = newPtr;
parsePtr->tokensAvailable = newCount;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ParseVarName --
*
* Given a string starting with a $ sign, parse off a variable
* name and return information about the parse. No more than
* numBytes bytes will be scanned.
*
* Results:
* The return value is TCL_OK if the command was parsed
* successfully and TCL_ERROR otherwise. If an error occurs and
* interp isn't NULL then an error message is left in its result.
* On a successful return, tokenPtr and numTokens fields of
* parsePtr are filled in with information about the variable name
* that was parsed. The "size" field of the first new token gives
* the total number of bytes in the variable name. Other fields in
* parsePtr are undefined.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the command, then additional space is
* malloc-ed. If the procedure returns TCL_OK then the caller must
* eventually invoke Tcl_FreeParse to release any additional space
* that was allocated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ParseVarName(interp, string, numBytes, parsePtr, append)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
CONST char *string; /* String containing variable name. First
* character must be "$". */
register int numBytes; /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr; /* Structure to fill in with information
* about the variable name. */
int append; /* Non-zero means append tokens to existing
* information in parsePtr; zero means ignore
* existing tokens in parsePtr and reinitialize
* it. */
{
Tcl_Token *tokenPtr;
register CONST char *src;
unsigned char c;
int varIndex, offset;
Tcl_UniChar ch;
unsigned array;
if ((numBytes == 0) || (string == NULL)) {
return TCL_ERROR;
}
if (numBytes < 0) {
numBytes = strlen(string);
}
if (!append) {
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->errorType = TCL_PARSE_SUCCESS;
parsePtr->incomplete = 0;
}
/*
* Generate one token for the variable, an additional token for the
* name, plus any number of additional tokens for the index, if
* there is one.
*/
src = string;
if ((parsePtr->numTokens + 2) > parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->type = TCL_TOKEN_VARIABLE;
tokenPtr->start = src;
varIndex = parsePtr->numTokens;
parsePtr->numTokens++;
tokenPtr++;
src++; numBytes--;
if (numBytes == 0) {
goto justADollarSign;
}
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src;
tokenPtr->numComponents = 0;
/*
* The name of the variable can have three forms:
* 1. The $ sign is followed by an open curly brace. Then
* the variable name is everything up to the next close
* curly brace, and the variable is a scalar variable.
* 2. The $ sign is not followed by an open curly brace. Then
* the variable name is everything up to the next
* character that isn't a letter, digit, or underscore.
* :: sequences are also considered part of the variable
* name, in order to support namespaces. If the following
* character is an open parenthesis, then the information
* between parentheses is the array element name.
* 3. The $ sign is followed by something that isn't a letter,
* digit, or underscore: in this case, there is no variable
* name and the token is just "$".
*/
if (*src == '{') {
src++; numBytes--;
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src;
tokenPtr->numComponents = 0;
while (numBytes && (*src != '}')) {
numBytes--; src++;
}
if (numBytes == 0) {
if (parsePtr->interp != NULL) {
Tcl_SetResult(parsePtr->interp,
"missing close-brace for variable name", TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
parsePtr->term = tokenPtr->start-1;
parsePtr->incomplete = 1;
goto error;
}
tokenPtr->size = src - tokenPtr->start;
tokenPtr[-1].size = src - tokenPtr[-1].start;
parsePtr->numTokens++;
src++;
} else {
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src;
tokenPtr->numComponents = 0;
while (numBytes) {
if (Tcl_UtfCharComplete(src, numBytes)) {
offset = Tcl_UtfToUniChar(src, &ch);
} else {
char utfBytes[TCL_UTF_MAX];
memcpy(utfBytes, src, (size_t) numBytes);
utfBytes[numBytes] = '\0';
offset = Tcl_UtfToUniChar(utfBytes, &ch);
}
c = UCHAR(ch);
if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */
src += offset; numBytes -= offset;
continue;
}
if ((c == ':') && (numBytes != 1) && (src[1] == ':')) {
src += 2; numBytes -= 2;
while (numBytes && (*src == ':')) {
src++; numBytes--;
}
continue;
}
break;
}
/*
* Support for empty array names here.
*/
array = (numBytes && (*src == '('));
tokenPtr->size = src - tokenPtr->start;
if ((tokenPtr->size == 0) && !array) {
goto justADollarSign;
}
parsePtr->numTokens++;
if (array) {
/*
* This is a reference to an array element. Call
* ParseTokens recursively to parse the element name,
* since it could contain any number of substitutions.
*/
if (ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, parsePtr)
!= TCL_OK) {
goto error;
}
if ((parsePtr->term == (src + numBytes))
|| (*parsePtr->term != ')')) {
if (parsePtr->interp != NULL) {
Tcl_SetResult(parsePtr->interp, "missing )",
TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
parsePtr->term = src;
parsePtr->incomplete = 1;
goto error;
}
src = parsePtr->term + 1;
}
}
tokenPtr = &parsePtr->tokenPtr[varIndex];
tokenPtr->size = src - tokenPtr->start;
tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1);
return TCL_OK;
/*
* The dollar sign isn't followed by a variable name.
* replace the TCL_TOKEN_VARIABLE token with a
* TCL_TOKEN_TEXT token for the dollar sign.
*/
justADollarSign:
tokenPtr = &parsePtr->tokenPtr[varIndex];
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->size = 1;
tokenPtr->numComponents = 0;
return TCL_OK;
error:
Tcl_FreeParse(parsePtr);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ParseVar --
*
* Given a string starting with a $ sign, parse off a variable
* name and return its value.
*
* Results:
* The return value is the contents of the variable given by
* the leading characters of string. If termPtr isn't NULL,
* *termPtr gets filled in with the address of the character
* just after the last one in the variable specifier. If the
* variable doesn't exist, then the return value is NULL and
* an error message will be left in interp's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_ParseVar(interp, string, termPtr)
Tcl_Interp *interp; /* Context for looking up variable. */
register CONST char *string; /* String containing variable name.
* First character must be "$". */
CONST char **termPtr; /* If non-NULL, points to word to fill
* in with character just after last
* one in the variable specifier. */
{
Tcl_Parse parse;
register Tcl_Obj *objPtr;
int code;
if (Tcl_ParseVarName(interp, string, -1, &parse, 0) != TCL_OK) {
return NULL;
}
if (termPtr != NULL) {
*termPtr = string + parse.tokenPtr->size;
}
if (parse.numTokens == 1) {
/*
* There isn't a variable name after all: the $ is just a $.
*/
return "$";
}
code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, parse.numTokens);
if (code != TCL_OK) {
return NULL;
}
objPtr = Tcl_GetObjResult(interp);
/*
* At this point we should have an object containing the value of
* a variable. Just return the string from that object.
*
* This should have returned the object for the user to manage, but
* instead we have some weak reference to the string value in the
* object, which is why we make sure the object exists after resetting
* the result. This isn't ideal, but it's the best we can do with the
* current documented interface. -- hobbs
*/
if (!Tcl_IsShared(objPtr)) {
Tcl_IncrRefCount(objPtr);
}
Tcl_ResetResult(interp);
return TclGetString(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ParseBraces --
*
* Given a string in braces such as a Tcl command argument or a string
* value in a Tcl expression, this procedure parses the string and
* returns information about the parse. No more than numBytes bytes
* will be scanned.
*
* Results:
* The return value is TCL_OK if the string was parsed successfully and
* TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
* an error message is left in its result. On a successful return,
* tokenPtr and numTokens fields of parsePtr are filled in with
* information about the string that was parsed. Other fields in
* parsePtr are undefined. termPtr is set to point to the character
* just after the last one in the braced string.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the command, then additional space is
* malloc-ed. If the procedure returns TCL_OK then the caller must
* eventually invoke Tcl_FreeParse to release any additional space
* that was allocated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
CONST char *string; /* String containing the string in braces.
* The first character must be '{'. */
register int numBytes; /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to
* the first null character. */
register Tcl_Parse *parsePtr;
/* Structure to fill in with information
* about the string. */
int append; /* Non-zero means append tokens to existing
* information in parsePtr; zero means
* ignore existing tokens in parsePtr and
* reinitialize it. */
CONST char **termPtr; /* If non-NULL, points to word in which to
* store a pointer to the character just
* after the terminating '}' if the parse
* was successful. */
{
Tcl_Token *tokenPtr;
register CONST char *src;
int startIndex, level, length;
if ((numBytes == 0) || (string == NULL)) {
return TCL_ERROR;
}
if (numBytes < 0) {
numBytes = strlen(string);
}
if (!append) {
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->errorType = TCL_PARSE_SUCCESS;
}
src = string;
startIndex = parsePtr->numTokens;
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[startIndex];
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src+1;
tokenPtr->numComponents = 0;
level = 1;
while (1) {
while (++src, --numBytes) {
if (CHAR_TYPE(*src) != TYPE_NORMAL) {
break;
}
}
if (numBytes == 0) {
register int openBrace = 0;
parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
parsePtr->term = string;
parsePtr->incomplete = 1;
if (parsePtr->interp == NULL) {
/*
* Skip straight to the exit code since we have no
* interpreter to put error message in.
*/
goto error;
}
Tcl_SetResult(parsePtr->interp, "missing close-brace", TCL_STATIC);
/*
* Guess if the problem is due to comments by searching
* the source string for a possible open brace within the
* context of a comment. Since we aren't performing a
* full Tcl parse, just look for an open brace preceded
* by a '#' on the same line.
*/
while (--src > string) {
switch (*src) {
case '{':
openBrace = 1;
break;
case '\n':
openBrace = 0;
break;
case '#' :
if (openBrace && (isspace(UCHAR(src[-1])))) {
Tcl_AppendResult(parsePtr->interp,
": possible unbalanced brace in comment",
(char *) NULL);
goto error;
}
break;
}
}
error:
Tcl_FreeParse(parsePtr);
return TCL_ERROR;
}
switch (*src) {
case '{':
level++;
break;
case '}':
if (--level == 0) {
/*
* Decide if we need to finish emitting a
* partially-finished token. There are 3 cases:
* {abc \newline xyz} or {xyz}
* - finish emitting "xyz" token
* {abc \newline}
* - don't emit token after \newline
* {} - finish emitting zero-sized token
*
* The last case ensures that there is a token
* (even if empty) that describes the braced string.
*/
if ((src != tokenPtr->start)
|| (parsePtr->numTokens == startIndex)) {
tokenPtr->size = (src - tokenPtr->start);
parsePtr->numTokens++;
}
if (termPtr != NULL) {
*termPtr = src+1;
}
return TCL_OK;
}
break;
case '\\':
TclParseBackslash(src, numBytes, &length, NULL);
if ((length > 1) && (src[1] == '\n')) {
/*
* A backslash-newline sequence must be collapsed, even
* inside braces, so we have to split the word into
* multiple tokens so that the backslash-newline can be
* represented explicitly.
*/
if (numBytes == 2) {
parsePtr->incomplete = 1;
}
tokenPtr->size = (src - tokenPtr->start);
if (tokenPtr->size != 0) {
parsePtr->numTokens++;
}
if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->type = TCL_TOKEN_BS;
tokenPtr->start = src;
tokenPtr->size = length;
tokenPtr->numComponents = 0;
parsePtr->numTokens++;
src += length - 1;
numBytes -= length - 1;
tokenPtr++;
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src + 1;
tokenPtr->numComponents = 0;
} else {
src += length - 1;
numBytes -= length - 1;
}
break;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ParseQuotedString --
*
* Given a double-quoted string such as a quoted Tcl command argument
* or a quoted value in a Tcl expression, this procedure parses the
* string and returns information about the parse. No more than
* numBytes bytes will be scanned.
*
* Results:
* The return value is TCL_OK if the string was parsed successfully and
* TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
* an error message is left in its result. On a successful return,
* tokenPtr and numTokens fields of parsePtr are filled in with
* information about the string that was parsed. Other fields in
* parsePtr are undefined. termPtr is set to point to the character
* just after the quoted string's terminating close-quote.
*
* Side effects:
* If there is insufficient space in parsePtr to hold all the
* information about the command, then additional space is
* malloc-ed. If the procedure returns TCL_OK then the caller must
* eventually invoke Tcl_FreeParse to release any additional space
* that was allocated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
CONST char *string; /* String containing the quoted string.
* The first character must be '"'. */
register int numBytes; /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to
* the first null character. */
register Tcl_Parse *parsePtr;
/* Structure to fill in with information
* about the string. */
int append; /* Non-zero means append tokens to existing
* information in parsePtr; zero means
* ignore existing tokens in parsePtr and
* reinitialize it. */
CONST char **termPtr; /* If non-NULL, points to word in which to
* store a pointer to the character just
* after the quoted string's terminating
* close-quote if the parse succeeds. */
{
if ((numBytes == 0) || (string == NULL)) {
return TCL_ERROR;
}
if (numBytes < 0) {
numBytes = strlen(string);
}
if (!append) {
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->errorType = TCL_PARSE_SUCCESS;
}
if (ParseTokens(string+1, numBytes-1, TYPE_QUOTE, parsePtr) != TCL_OK) {
goto error;
}
if (*parsePtr->term != '"') {
if (parsePtr->interp != NULL) {
Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
parsePtr->term = string;
parsePtr->incomplete = 1;
goto error;
}
if (termPtr != NULL) {
*termPtr = (parsePtr->term + 1);
}
return TCL_OK;
error:
Tcl_FreeParse(parsePtr);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* CommandComplete --
*
* This procedure is shared by TclCommandComplete and
* Tcl_ObjCommandcoComplete; it does all the real work of seeing
* whether a script is complete
*
* Results:
* 1 is returned if the script is complete, 0 if there are open
* delimiters such as " or (. 1 is also returned if there is a
* parse error in the script other than unmatched delimiters.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CommandComplete(script, numBytes)
CONST char *script; /* Script to check. */
int numBytes; /* Number of bytes in script. */
{
Tcl_Parse parse;
CONST char *p, *end;
int result;
p = script;
end = p + numBytes;
while (Tcl_ParseCommand((Tcl_Interp *) NULL, p, end - p, 0, &parse)
== TCL_OK) {
p = parse.commandStart + parse.commandSize;
if (p >= end) {
break;
}
Tcl_FreeParse(&parse);
}
if (parse.incomplete) {
result = 0;
} else {
result = 1;
}
Tcl_FreeParse(&parse);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CommandComplete --
*
* Given a partial or complete Tcl script, this procedure
* determines whether the script is complete in the sense
* of having matched braces and quotes and brackets.
*
* Results:
* 1 is returned if the script is complete, 0 otherwise.
* 1 is also returned if there is a parse error in the script
* other than unmatched delimiters.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_CommandComplete(script)
CONST char *script; /* Script to check. */
{
return CommandComplete(script, (int) strlen(script));
}
/*
*----------------------------------------------------------------------
*
* TclObjCommandComplete --
*
* Given a partial or complete Tcl command in a Tcl object, this
* procedure determines whether the command is complete in the sense of
* having matched braces and quotes and brackets.
*
* Results:
* 1 is returned if the command is complete, 0 otherwise.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclObjCommandComplete(objPtr)
Tcl_Obj *objPtr; /* Points to object holding script
* to check. */
{
CONST char *script;
int length;
script = Tcl_GetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
/*
*----------------------------------------------------------------------
*
* TclIsLocalScalar --
*
* Check to see if a given string is a legal scalar variable
* name with no namespace qualifiers or substitutions.
*
* Results:
* Returns 1 if the variable is a local scalar.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclIsLocalScalar(src, len)
CONST char *src;
int len;
{
CONST char *p;
CONST char *lastChar = src + (len - 1);
for (p = src; p <= lastChar; p++) {
if ((CHAR_TYPE(*p) != TYPE_NORMAL) &&
(CHAR_TYPE(*p) != TYPE_COMMAND_END)) {
/*
* TCL_COMMAND_END is returned for the last character
* of the string. By this point we know it isn't
* an array or namespace reference.
*/
return 0;
}
if (*p == '(') {
if (*lastChar == ')') { /* we have an array element */
return 0;
}
} else if (*p == ':') {
if ((p != lastChar) && *(p+1) == ':') { /* qualified name */
return 0;
}
}
}
return 1;
}
tcl8.4.20/generic/tclRegexp.h 0000644 0036047 0045461 00000003103 11737050674 014436 0 ustar dgp 771div /*
* tclRegexp.h --
*
* This file contains definitions used internally by Henry
* Spencer's regular expression code.
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _TCLREGEXP
#define _TCLREGEXP
#include "regex.h"
#ifdef BUILD_tcl
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLEXPORT
#endif
/*
* The TclRegexp structure encapsulates a compiled regex_t,
* the flags that were used to compile it, and an array of pointers
* that are used to indicate subexpressions after a call to Tcl_RegExpExec.
* Note that the string and objPtr are mutually exclusive. These values
* are needed by Tcl_RegExpRange in order to return pointers into the
* original string.
*/
typedef struct TclRegexp {
int flags; /* Regexp compile flags. */
regex_t re; /* Compiled re, includes number of
* subexpressions. */
CONST char *string; /* Last string passed to Tcl_RegExpExec. */
Tcl_Obj *objPtr; /* Last object passed to Tcl_RegExpExecObj. */
regmatch_t *matches; /* Array of indices into the Tcl_UniChar
* representation of the last string matched
* with this regexp to indicate the location
* of subexpressions. */
rm_detail_t details; /* Detailed information on match (currently
* used only for REG_EXPECT). */
int refCount; /* Count of number of references to this
* compiled regexp. */
} TclRegexp;
#endif /* _TCLREGEXP */
tcl8.4.20/generic/tclObj.c 0000644 0036047 0045461 00000317411 11737050674 013723 0 ustar dgp 771div /*
* tclObj.c --
*
* This file contains Tcl object-related procedures that are used by
* many Tcl commands.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
* Copyright (c) 2001 by ActiveState Corporation.
* Copyright (c) 2007 Daniel A. Steffen
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclCompile.h"
#include "tclPort.h"
/*
* Table of all object types.
*/
static Tcl_HashTable typeTable;
static int typeTableInitialized = 0; /* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(tableMutex)
/*
* Head of the list of free Tcl_Obj structs we maintain.
*/
Tcl_Obj *tclFreeObjList = NULL;
/*
* The object allocator is single threaded. This mutex is referenced
* by the TclNewObj macro, however, so must be visible.
*/
#ifdef TCL_THREADS
Tcl_Mutex tclObjMutex;
#endif
/*
* Pointer to a heap-allocated string of length zero that the Tcl core uses
* as the value of an empty string representation for an object. This value
* is shared by all new objects allocated by Tcl_NewObj.
*/
char tclEmptyString = '\0';
char *tclEmptyStringRep = &tclEmptyString;
#ifdef TCL_TIP280
/*
* All static variables used in this file are collected into a single
* instance of the following structure. For multi-threaded implementations,
* there is one instance of this structure for each thread.
*
* Notice that different structures with the same name appear in other
* files. The structure defined below is used in this file only.
*/
typedef struct ThreadSpecificData {
Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj generated
* by a call to the function EvalTokensStandard()
* from a literal text where bs+nl sequences
* occured in it, if any. I.e. this table keeps
* track of invisible/stripped continuation
* lines. Its keys are Tcl_Obj pointers, the
* values are ContLineLoc pointers. See the file
* tclCompile.h for the definition of this
* structure, and for references to all related
* places in the core.
*/
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
static void ContLineLocFree _ANSI_ARGS_((char* clientData));
static void TclThreadFinalizeObjects _ANSI_ARGS_((ClientData clientData));
static ThreadSpecificData* TclGetContinuationTable _ANSI_ARGS_(());
#endif
/*
* Prototypes for procedures defined later in this file:
*/
static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static int SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj *objPtr));
static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
#ifndef TCL_WIDE_INT_IS_LONG
static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr));
#endif
/*
* Prototypes for the array hash key methods.
*/
static Tcl_HashEntry * AllocObjEntry _ANSI_ARGS_((
Tcl_HashTable *tablePtr, VOID *keyPtr));
static int CompareObjKeys _ANSI_ARGS_((
VOID *keyPtr, Tcl_HashEntry *hPtr));
static void FreeObjEntry _ANSI_ARGS_((
Tcl_HashEntry *hPtr));
static unsigned int HashObjKey _ANSI_ARGS_((
Tcl_HashTable *tablePtr,
VOID *keyPtr));
/*
* Prototypes for the CommandName object type.
*/
static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
Tcl_Obj *copyPtr));
static void FreeCmdNameInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
/*
* The structures below defines the Tcl object types defined in this file by
* means of procedures that can be invoked by generic object code. See also
* tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
* implementations.
*/
Tcl_ObjType tclBooleanType = {
"boolean", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
UpdateStringOfBoolean, /* updateStringProc */
SetBooleanFromAny /* setFromAnyProc */
};
Tcl_ObjType tclDoubleType = {
"double", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
UpdateStringOfDouble, /* updateStringProc */
SetDoubleFromAny /* setFromAnyProc */
};
Tcl_ObjType tclIntType = {
"int", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
Tcl_ObjType tclWideIntType = {
"wideInt", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
#ifdef TCL_WIDE_INT_IS_LONG
UpdateStringOfInt, /* updateStringProc */
#else /* !TCL_WIDE_INT_IS_LONG */
UpdateStringOfWideInt, /* updateStringProc */
#endif
SetWideIntFromAny /* setFromAnyProc */
};
/*
* The structure below defines the Tcl obj hash key type.
*/
Tcl_HashKeyType tclObjHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
HashObjKey, /* hashKeyProc */
CompareObjKeys, /* compareKeysProc */
AllocObjEntry, /* allocEntryProc */
FreeObjEntry /* freeEntryProc */
};
/*
* The structure below defines the command name Tcl object type by means of
* procedures that can be invoked by generic object code. Objects of this
* type cache the Command pointer that results from looking up command names
* in the command hashtable. Such objects appear as the zeroth ("command
* name") argument in a Tcl command.
*
* NOTE: the ResolvedCmdName that gets cached is stored in the
* twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused.
* You might think you could use the simpler otherValuePtr field to
* store the single ResolvedCmdName pointer, but DO NOT DO THIS. It
* seems that some extensions use the second internal pointer field
* of the twoPtrValue field for their own purposes.
*/
static Tcl_ObjType tclCmdNameType = {
"cmdName", /* name */
FreeCmdNameInternalRep, /* freeIntRepProc */
DupCmdNameInternalRep, /* dupIntRepProc */
(Tcl_UpdateStringProc *) NULL, /* updateStringProc */
SetCmdNameFromAny /* setFromAnyProc */
};
/*
* Structure containing a cached pointer to a command that is the result
* of resolving the command's name in some namespace. It is the internal
* representation for a cmdName object. It contains the pointer along
* with some information that is used to check the pointer's validity.
*/
typedef struct ResolvedCmdName {
Command *cmdPtr; /* A cached Command pointer. */
Namespace *refNsPtr; /* Points to the namespace containing the
* reference (not the namespace that
* contains the referenced command). */
long refNsId; /* refNsPtr's unique namespace id. Used to
* verify that refNsPtr is still valid
* (e.g., it's possible that the cmd's
* containing namespace was deleted and a
* new one created at the same address). */
int refNsCmdEpoch; /* Value of the referencing namespace's
* cmdRefEpoch when the pointer was cached.
* Before using the cached pointer, we check
* if the namespace's epoch was incremented;
* if so, this cached pointer is invalid. */
int cmdEpoch; /* Value of the command's cmdEpoch when this
* pointer was cached. Before using the
* cached pointer, we check if the cmd's
* epoch was incremented; if so, the cmd was
* renamed, deleted, hidden, or exposed, and
* so the pointer is invalid. */
int refCount; /* Reference count: 1 for each cmdName
* object that has a pointer to this
* ResolvedCmdName structure as its internal
* rep. This structure can be freed when
* refCount becomes zero. */
} ResolvedCmdName;
/*
*-------------------------------------------------------------------------
*
* TclInitObjectSubsystem --
*
* This procedure is invoked to perform once-only initialization of
* the type table. It also registers the object types defined in
* this file.
*
* Results:
* None.
*
* Side effects:
* Initializes the table of defined object types "typeTable" with
* builtin object types defined in this file.
*
*-------------------------------------------------------------------------
*/
void
TclInitObjSubsystem()
{
Tcl_MutexLock(&tableMutex);
typeTableInitialized = 1;
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&tableMutex);
Tcl_RegisterObjType(&tclBooleanType);
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
Tcl_RegisterObjType(&tclEndOffsetType);
Tcl_RegisterObjType(&tclIntType);
Tcl_RegisterObjType(&tclWideIntType);
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclProcBodyType);
Tcl_RegisterObjType(&tclArraySearchType);
Tcl_RegisterObjType(&tclIndexType);
Tcl_RegisterObjType(&tclNsNameType);
Tcl_RegisterObjType(&tclCmdNameType);
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
tclObjsAlloced = 0;
tclObjsFreed = 0;
{
int i;
for (i = 0; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
tclObjsShared[i] = 0;
}
}
Tcl_MutexUnlock(&tclObjMutex);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeObjects --
*
* This procedure is called by Tcl_Finalize to clean up all
* registered Tcl_ObjType's and to reset the tclFreeObjList.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeObjects()
{
Tcl_MutexLock(&tableMutex);
if (typeTableInitialized) {
Tcl_DeleteHashTable(&typeTable);
typeTableInitialized = 0;
}
Tcl_MutexUnlock(&tableMutex);
/*
* All we do here is reset the head pointer of the linked list of
* free Tcl_Obj's to NULL; the memory finalization will take care
* of releasing memory for us.
*/
Tcl_MutexLock(&tclObjMutex);
tclFreeObjList = NULL;
Tcl_MutexUnlock(&tclObjMutex);
}
#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
*
* TclGetContinuationTable --
*
* This procedure is a helper which returns the thread-specific
* hash-table used to track continuation line information associated with
* Tcl_Obj*.
*
* Results:
* A reference to the continuation line thread-data.
*
* Side effects:
* May allocate memory for the thread-data.
*
* TIP #280
*----------------------------------------------------------------------
*/
static ThreadSpecificData*
TclGetContinuationTable()
{
/*
* Initialize the hashtable tracking invisible continuation lines. For
* the release we use a thread exit handler to ensure that this is done
* before TSD blocks are made invalid. The TclFinalizeObjects() which
* would be the natural place for this is invoked afterwards, meaning that
* we try to operate on a data structure already gone.
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->lineCLPtr) {
tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
Tcl_CreateThreadExitHandler (TclThreadFinalizeObjects,NULL);
}
return tsdPtr;
}
/*
*----------------------------------------------------------------------
*
* TclContinuationsEnter --
*
* This procedure is a helper which saves the continuation line
* information associated with a Tcl_Obj*.
*
* Results:
* A reference to the newly created continuation line location table.
*
* Side effects:
* Allocates memory for the table of continuation line locations.
*
* TIP #280
*----------------------------------------------------------------------
*/
ContLineLoc*
TclContinuationsEnter(objPtr,num,loc)
Tcl_Obj* objPtr;
int num;
int* loc;
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContinuationTable();
Tcl_HashEntry* hPtr =
Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry);
ContLineLoc* clLocPtr =
(ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int));
if (!newEntry) {
/*
* Somehow we're entering ContLineLoc data for the same value (objPtr)
* more than one time. Not sure whether that's expected, or a sign of
* trouble, but at a minimum, we should take care not to leak the old
* entry.
*/
ckfree((char *) Tcl_GetHashValue(hPtr));
}
clLocPtr->num = num;
memcpy (&clLocPtr->loc, loc, num*sizeof(int));
clLocPtr->loc[num] = CLL_END; /* Sentinel */
Tcl_SetHashValue (hPtr, clLocPtr);
return clLocPtr;
}
/*
*----------------------------------------------------------------------
*
* TclContinuationsEnterDerived --
*
* This procedure is a helper which computes the continuation line
* information associated with a Tcl_Obj* cut from the middle of a
* script.
*
* Results:
* None.
*
* Side effects:
* Allocates memory for the table of continuation line locations.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclContinuationsEnterDerived(objPtr, start, clNext)
Tcl_Obj* objPtr;
int start;
int* clNext;
{
/*
* We have to handle invisible continuations lines here as well, despite
* the code we have in EvalTokensStandard (ETS) for that. Why ?
* Nesting. If our script is the sole argument to an 'eval' command, for
* example, the scriptCLLocPtr we are using here was generated by a
* previous call to ETS, and while the words we have here may contain
* continuation lines they are invisible already, and the call to ETS
* above had no bs+nl sequences to trigger its code.
*
* Luckily for us, the table we have to create here for the current word
* has to be a slice of the table currently in use, with the locations
* suitably modified to be relative to the start of the word instead of
* relative to the script.
*
* That is what we are doing now. Determine the slice we need, and if not
* empty, wrap it into a new table, and save the result into our
* thread-global hashtable, as usual.
*/
/*
* First compute the range of the word within the script.
*/
int length, end, num;
int* wordCLLast = clNext;
Tcl_GetStringFromObj(objPtr, &length);
/* Is there a better way which doesn't shimmer ? */
end = start + length; /* first char after the word */
/*
* Then compute the table slice covering the range of
* the word.
*/
while (*wordCLLast >= 0 && *wordCLLast < end) {
wordCLLast++;
}
/*
* And generate the table from the slice, if it was
* not empty.
*/
num = wordCLLast - clNext;
if (num) {
int i;
ContLineLoc* clLocPtr =
TclContinuationsEnter(objPtr, num, clNext);
/*
* Re-base the locations.
*/
for (i=0;iloc[i] -= start;
/*
* Continuation lines coming before the string and affecting us
* should not happen, due to the proper maintenance of clNext
* during compilation.
*/
if (clLocPtr->loc[i] < 0) {
Tcl_Panic("Derived ICL data for object using offsets from before the script");
}
}
}
}
/*
*----------------------------------------------------------------------
*
* TclContinuationsCopy --
*
* This procedure is a helper which copies the continuation line
* information associated with a Tcl_Obj* to another Tcl_Obj*.
* It is assumed that both contain the same string/script. Use
* this when a script is duplicated because it was shared.
*
* Results:
* None.
*
* Side effects:
* Allocates memory for the table of continuation line locations.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr)
{
ThreadSpecificData *tsdPtr = TclGetContinuationTable();
Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr);
if (hPtr) {
ContLineLoc* clLocPtr = (ContLineLoc*) Tcl_GetHashValue (hPtr);
TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
}
}
/*
*----------------------------------------------------------------------
*
* TclContinuationsGet --
*
* This procedure is a helper which retrieves the continuation line
* information associated with a Tcl_Obj*, if it has any.
*
* Results:
* A reference to the continuation line location table, or NULL
* if the Tcl_Obj* has no such information associated with it.
*
* Side effects:
* None.
*
* TIP #280
*----------------------------------------------------------------------
*/
ContLineLoc*
TclContinuationsGet(objPtr)
Tcl_Obj* objPtr;
{
ThreadSpecificData *tsdPtr = TclGetContinuationTable();
Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr);
if (hPtr) {
return (ContLineLoc*) Tcl_GetHashValue (hPtr);
} else {
return NULL;
}
}
/*
*----------------------------------------------------------------------
*
* TclThreadFinalizeObjects --
*
* This procedure is a helper which releases all continuation line
* information currently known. It is run as a thread exit handler.
*
* Results:
* None.
*
* Side effects:
* Releases memory.
*
* TIP #280
*----------------------------------------------------------------------
*/
static void
TclThreadFinalizeObjects (clientData)
ClientData clientData;
{
/*
* Release the hashtable tracking invisible continuation lines.
*/
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
ThreadSpecificData *tsdPtr = TclGetContinuationTable();
for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
/*
* We are not using Tcl_EventuallyFree (as in
* TclFreeObj()) because here we can be sure that the
* compiler will not hold references to the data in the
* hashtable, and using TEF might bork the finalization
* sequence.
*/
ContLineLocFree (Tcl_GetHashValue (hPtr));
Tcl_DeleteHashEntry (hPtr);
}
Tcl_DeleteHashTable (tsdPtr->lineCLPtr);
tsdPtr->lineCLPtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* ContLineLocFree --
*
* The freProc for continuation line location tables.
*
* Results:
* None.
*
* Side effects:
* Releases memory.
*
* TIP #280
*----------------------------------------------------------------------
*/
static void
ContLineLocFree (clientData)
char* clientData;
{
ckfree (clientData);
}
#endif
/*
*--------------------------------------------------------------
*
* Tcl_RegisterObjType --
*
* This procedure is called to register a new Tcl object type
* in the table of all object types supported by Tcl.
*
* Results:
* None.
*
* Side effects:
* The type is registered in the Tcl type table. If there was already
* a type with the same name as in typePtr, it is replaced with the
* new type.
*
*--------------------------------------------------------------
*/
void
Tcl_RegisterObjType(typePtr)
Tcl_ObjType *typePtr; /* Information about object type;
* storage must be statically
* allocated (must live forever). */
{
int new;
Tcl_MutexLock(&tableMutex);
Tcl_SetHashValue(
Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr);
Tcl_MutexUnlock(&tableMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendAllObjTypes --
*
* This procedure appends onto the argument object the name of each
* object type as a list element. This includes the builtin object
* types (e.g. int, list) as well as those added using
* Tcl_NewObj. These names can be used, for example, with
* Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
* structures.
*
* Results:
* The return value is normally TCL_OK; in this case the object
* referenced by objPtr has each type name appended to it. If an
* error occurs, TCL_ERROR is returned and the interpreter's result
* holds an error message.
*
* Side effects:
* If necessary, the object referenced by objPtr is converted into
* a list object.
*
*----------------------------------------------------------------------
*/
int
Tcl_AppendAllObjTypes(interp, objPtr)
Tcl_Interp *interp; /* Interpreter used for error reporting. */
Tcl_Obj *objPtr; /* Points to the Tcl object onto which the
* name of each registered type is appended
* as a list element. */
{
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int objc;
Tcl_Obj **objv;
/*
* Get the test for a valid list out of the way first.
*/
if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Type names are NUL-terminated, not counted strings.
* This code relies on that.
*/
Tcl_MutexLock(&tableMutex);
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));
}
Tcl_MutexUnlock(&tableMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetObjType --
*
* This procedure looks up an object type by name.
*
* Results:
* If an object type with name matching "typeName" is found, a pointer
* to its Tcl_ObjType structure is returned; otherwise, NULL is
* returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_ObjType *
Tcl_GetObjType(typeName)
CONST char *typeName; /* Name of Tcl object type to look up. */
{
register Tcl_HashEntry *hPtr;
Tcl_ObjType *typePtr = NULL;
Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
if (hPtr != (Tcl_HashEntry *) NULL) {
typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
return typePtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConvertToType --
*
* Convert the Tcl object "objPtr" to have type "typePtr" if possible.
*
* Results:
* The return value is TCL_OK on success and TCL_ERROR on failure. If
* TCL_ERROR is returned, then the interpreter's result contains an
* error message unless "interp" is NULL. Passing a NULL "interp"
* allows this procedure to be used as a test whether the conversion
* could be done (and in fact was done).
*
* Side effects:
* Any internal representation for the old type is freed.
*
*----------------------------------------------------------------------
*/
int
Tcl_ConvertToType(interp, objPtr, typePtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object to convert. */
Tcl_ObjType *typePtr; /* The target type. */
{
if (objPtr->typePtr == typePtr) {
return TCL_OK;
}
/*
* Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
* form as appropriate for the target type. This frees the old internal
* representation.
*/
return typePtr->setFromAnyProc(interp, objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewObj --
*
* This procedure is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote
* the empty string. These objects have a NULL object type and NULL
* string representation byte pointer. Type managers call this routine
* to allocate new objects that they further initialize.
*
* When TCL_MEM_DEBUG is defined, this procedure just returns the
* result of calling the debugging version Tcl_DbNewObj.
*
* Results:
* The result is a newly allocated object that represents the empty
* string. The new object's typePtr is set NULL and its ref count
* is set to 0.
*
* Side effects:
* If compiling with TCL_COMPILE_STATS, this procedure increments
* the global count of allocated objects (tclObjsAlloced).
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewObj
Tcl_Obj *
Tcl_NewObj()
{
return Tcl_DbNewObj("unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewObj()
{
register Tcl_Obj *objPtr;
/*
* Use the macro defined in tclInt.h - it will use the
* correct allocator.
*/
TclNewObj(objPtr);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewObj --
*
* This procedure is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
* empty string. It is the same as the Tcl_NewObj procedure above
* except that it calls Tcl_DbCkalloc directly with the file name and
* line number from its caller. This simplifies debugging since then
* the [memory active] command will report the correct file name and line
* number when reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
* result of calling Tcl_NewObj.
*
* Results:
* The result is a newly allocated that represents the empty string.
* The new object's typePtr is set NULL and its ref count is set to 0.
*
* Side effects:
* If compiling with TCL_COMPILE_STATS, this procedure increments
* the global count of allocated objects (tclObjsAlloced).
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewObj(file, line)
register CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
register int line; /* Line number in the source file; used
* for debugging. */
{
register Tcl_Obj *objPtr;
/*
* Use the macro defined in tclInt.h - it will use the
* correct allocator.
*/
TclDbNewObj(objPtr, file, line);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewObj(file, line)
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
return Tcl_NewObj();
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* TclAllocateFreeObjects --
*
* Procedure to allocate a number of free Tcl_Objs. This is done using
* a single ckalloc to reduce the overhead for Tcl_Obj allocation.
*
* Assumes mutex is held.
*
* Results:
* None.
*
* Side effects:
* tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
* first of a number of free Tcl_Obj's linked together by their
* internalRep.otherValuePtrs.
*
*----------------------------------------------------------------------
*/
#define OBJS_TO_ALLOC_EACH_TIME 100
void
TclAllocateFreeObjects()
{
size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
char *basePtr;
register Tcl_Obj *prevPtr, *objPtr;
register int i;
/*
* This has been noted by Purify to be a potential leak. The problem is
* that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
* Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of
* actually freeing the memory. TclFinalizeObjects() does not ckfree()
* this memory, but leaves it to Tcl's memory subsystem finalziation to
* release it. Purify apparently can't figure that out, and fires a
* false alarm.
*/
basePtr = (char *) ckalloc(bytesToAlloc);
memset(basePtr, 0, bytesToAlloc);
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
prevPtr = objPtr;
objPtr++;
}
tclFreeObjList = prevPtr;
}
#undef OBJS_TO_ALLOC_EACH_TIME
/*
*----------------------------------------------------------------------
*
* TclFreeObj --
*
* This procedure frees the memory associated with the argument
* object. It is called by the tcl.h macro Tcl_DecrRefCount when an
* object's ref count is zero. It is only "public" since it must
* be callable by that macro wherever the macro is used. It should not
* be directly called by clients.
*
* Results:
* None.
*
* Side effects:
* Deallocates the storage for the object's Tcl_Obj structure
* after deallocating the string representation and calling the
* type-specific Tcl_FreeInternalRepProc to deallocate the object's
* internal representation. If compiling with TCL_COMPILE_STATS,
* this procedure increments the global count of freed objects
* (tclObjsFreed).
*
*----------------------------------------------------------------------
*/
void
TclFreeObj(objPtr)
register Tcl_Obj *objPtr; /* The object to be freed. */
{
register Tcl_ObjType *typePtr = objPtr->typePtr;
#ifdef TCL_MEM_DEBUG
if ((objPtr)->refCount < -1) {
panic("Reference count for %lx was negative", objPtr);
}
#endif /* TCL_MEM_DEBUG */
TCL_DTRACE_OBJ_FREE(objPtr);
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
typePtr->freeIntRepProc(objPtr);
}
Tcl_InvalidateStringRep(objPtr);
/*
* If debugging Tcl's memory usage, deallocate the object using ckfree.
* Otherwise, deallocate it by adding it onto the list of free
* Tcl_Obj structs we maintain.
*/
#if defined(TCL_MEM_DEBUG) || defined(PURIFY)
Tcl_MutexLock(&tclObjMutex);
ckfree((char *) objPtr);
Tcl_MutexUnlock(&tclObjMutex);
#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
TclThreadFreeObj(objPtr);
#else
Tcl_MutexLock(&tclObjMutex);
objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
tclFreeObjList = objPtr;
Tcl_MutexUnlock(&tclObjMutex);
#endif /* TCL_MEM_DEBUG */
#ifdef TCL_TIP280
/*
* We cannot use TclGetContinuationTable() here, because that may
* re-initialize the thread-data for calls coming after the
* finalization. We have to access it using the low-level call and then
* check for validity. This function can be called after
* TclFinalizeThreadData() has already killed the thread-global data
* structures. Performing TCL_TSD_INIT will leave us with an
* un-initialized memory block upon which we crash (if we where to access
* the uninitialized hashtable).
*/
{
ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->lineCLPtr) {
Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr);
if (hPtr) {
Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree);
Tcl_DeleteHashEntry (hPtr);
}
}
}
#endif
TclIncrObjsFreed();
}
/*
*----------------------------------------------------------------------
*
* Tcl_DuplicateObj --
*
* Create and return a new object that is a duplicate of the argument
* object.
*
* Results:
* The return value is a pointer to a newly created Tcl_Obj. This
* object has reference count 0 and the same type, if any, as the
* source object objPtr. Also:
* 1) If the source object has a valid string rep, we copy it;
* otherwise, the duplicate's string rep is set NULL to mark
* it invalid.
* 2) If the source object has an internal representation (i.e. its
* typePtr is non-NULL), the new object's internal rep is set to
* a copy; otherwise the new internal rep is marked invalid.
*
* Side effects:
* What constitutes "copying" the internal representation depends on
* the type. For example, if the argument object is a list,
* the element objects it points to will not actually be copied but
* will be shared with the duplicate list. That is, the ref counts of
* the element objects will be incremented.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_DuplicateObj(objPtr)
register Tcl_Obj *objPtr; /* The object to duplicate. */
{
register Tcl_ObjType *typePtr = objPtr->typePtr;
register Tcl_Obj *dupPtr;
TclNewObj(dupPtr);
if (objPtr->bytes == NULL) {
dupPtr->bytes = NULL;
} else if (objPtr->bytes != tclEmptyStringRep) {
TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length);
}
if (typePtr != NULL) {
if (typePtr->dupIntRepProc == NULL) {
dupPtr->internalRep = objPtr->internalRep;
dupPtr->typePtr = typePtr;
} else {
(*typePtr->dupIntRepProc)(objPtr, dupPtr);
}
}
return dupPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetString --
*
* Returns the string representation byte array pointer for an object.
*
* Results:
* Returns a pointer to the string representation of objPtr. The byte
* array referenced by the returned pointer must not be modified by the
* caller. Furthermore, the caller must copy the bytes if they need to
* retain them since the object's string rep can change as a result of
* other operations.
*
* Side effects:
* May call the object's updateStringProc to update the string
* representation from the internal representation.
*
*----------------------------------------------------------------------
*/
char *
Tcl_GetString(objPtr)
register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
* should be returned. */
{
if (objPtr->bytes != NULL) {
return objPtr->bytes;
}
if (objPtr->typePtr->updateStringProc == NULL) {
panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
(*objPtr->typePtr->updateStringProc)(objPtr);
return objPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetStringFromObj --
*
* Returns the string representation's byte array pointer and length
* for an object.
*
* Results:
* Returns a pointer to the string representation of objPtr. If
* lengthPtr isn't NULL, the length of the string representation is
* stored at *lengthPtr. The byte array referenced by the returned
* pointer must not be modified by the caller. Furthermore, the
* caller must copy the bytes if they need to retain them since the
* object's string rep can change as a result of other operations.
*
* Side effects:
* May call the object's updateStringProc to update the string
* representation from the internal representation.
*
*----------------------------------------------------------------------
*/
char *
Tcl_GetStringFromObj(objPtr, lengthPtr)
register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should
* be returned. */
register int *lengthPtr; /* If non-NULL, the location where the string
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
{
if (objPtr->bytes == NULL) {
if (objPtr->typePtr->updateStringProc == NULL) {
panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
(*objPtr->typePtr->updateStringProc)(objPtr);
}
if (lengthPtr != NULL) {
*lengthPtr = objPtr->length;
}
return objPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_InvalidateStringRep --
*
* This procedure is called to invalidate an object's string
* representation.
*
* Results:
* None.
*
* Side effects:
* Deallocates the storage for any old string representation, then
* sets the string representation NULL to mark it invalid.
*
*----------------------------------------------------------------------
*/
void
Tcl_InvalidateStringRep(objPtr)
register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
* should be freed. */
{
if (objPtr->bytes != NULL) {
if (objPtr->bytes != tclEmptyStringRep) {
ckfree((char *) objPtr->bytes);
}
objPtr->bytes = NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewBooleanObj --
*
* This procedure is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and
* initializes it from the argument boolean value. A nonzero
* "boolValue" is coerced to 1.
*
* When TCL_MEM_DEBUG is defined, this procedure just returns the
* result of calling the debugging version Tcl_DbNewBooleanObj.
*
* Results:
* The newly created object is returned. This object will have an
* invalid string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewBooleanObj
Tcl_Obj *
Tcl_NewBooleanObj(boolValue)
register int boolValue; /* Boolean used to initialize new object. */
{
return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewBooleanObj(boolValue)
register int boolValue; /* Boolean used to initialize new object. */
{
register Tcl_Obj *objPtr;
TclNewObj(objPtr);
objPtr->bytes = NULL;
objPtr->internalRep.longValue = (boolValue? 1 : 0);
objPtr->typePtr = &tclBooleanType;
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewBooleanObj --
*
* This procedure is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
* same as the Tcl_NewBooleanObj procedure above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
* caller. This simplifies debugging since then the [memory active]
* command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
* result of calling Tcl_NewBooleanObj.
*
* Results:
* The newly created object is returned. This object will have an
* invalid string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewBooleanObj(boolValue, file, line)
register int boolValue; /* Boolean used to initialize new object. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
objPtr->internalRep.longValue = (boolValue? 1 : 0);
objPtr->typePtr = &tclBooleanType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewBooleanObj(boolValue, file, line)
register int boolValue; /* Boolean used to initialize new object. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
return Tcl_NewBooleanObj(boolValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetBooleanObj --
*
* Modify an object to be a boolean object and to have the specified
* boolean value. A nonzero "boolValue" is coerced to 1.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old
* internal rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetBooleanObj(objPtr, boolValue)
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
register int boolValue; /* Boolean used to set object's value. */
{
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_SetBooleanObj called with shared object");
}
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.longValue = (boolValue? 1 : 0);
objPtr->typePtr = &tclBooleanType;
Tcl_InvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetBooleanFromObj --
*
* Attempt to return a boolean from the Tcl object "objPtr". If the
* object is not already a boolean, an attempt will be made to convert
* it to one.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If the object is not already a boolean, the conversion will free
* any old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object from which to get boolean. */
register int *boolPtr; /* Place to store resulting boolean. */
{
register int result;
if (objPtr->typePtr == &tclBooleanType) {
result = TCL_OK;
} else {
result = SetBooleanFromAny(interp, objPtr);
}
if (result == TCL_OK) {
*boolPtr = (int) objPtr->internalRep.longValue;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* SetBooleanFromAny --
*
* Attempt to generate a boolean internal form for the Tcl object
* "objPtr".
*
* Results:
* The return value is a standard Tcl result. If an error occurs during
* conversion, an error message is left in the interpreter's result
* unless "interp" is NULL.
*
* Side effects:
* If no error occurs, an integer 1 or 0 is stored as "objPtr"s
* internal representation and the type of "objPtr" is set to boolean.
*
*----------------------------------------------------------------------
*/
static int
SetBooleanFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
char *string, *end;
register char c;
char lowerCase[10];
int newBool, length;
register int i;
/*
* Get the string representation. Make it up-to-date if necessary.
*/
string = Tcl_GetStringFromObj(objPtr, &length);
/*
* Use the obvious shortcuts for numerical values; if objPtr is not
* of numerical type, parse its string rep.
*/
if (objPtr->typePtr == &tclIntType) {
newBool = (objPtr->internalRep.longValue != 0);
} else if (objPtr->typePtr == &tclDoubleType) {
newBool = (objPtr->internalRep.doubleValue != 0.0);
} else if (objPtr->typePtr == &tclWideIntType) {
newBool = (objPtr->internalRep.wideValue != 0);
} else {
/*
* Copy the string converting its characters to lower case.
*/
for (i = 0; (i < 9) && (i < length); i++) {
c = string[i];
/*
* Weed out international characters so we can safely operate
* on single bytes.
*/
if (c & 0x80) {
goto badBoolean;
}
if (Tcl_UniCharIsUpper(UCHAR(c))) {
c = (char) Tcl_UniCharToLower(UCHAR(c));
}
lowerCase[i] = c;
}
lowerCase[i] = 0;
/*
* Parse the string as a boolean. We use an implementation here that
* doesn't report errors in interp if interp is NULL.
*/
c = lowerCase[0];
if ((c == '0') && (lowerCase[1] == '\0')) {
newBool = 0;
} else if ((c == '1') && (lowerCase[1] == '\0')) {
newBool = 1;
} else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
newBool = 1;
} else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
newBool = 0;
} else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
newBool = 1;
} else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
newBool = 0;
} else if ((c == 'o') && (length >= 2)) {
if (strncmp(lowerCase, "on", (size_t) length) == 0) {
newBool = 1;
} else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
newBool = 0;
} else {
goto badBoolean;
}
} else {
double dbl;
/*
* Boolean values can be extracted from ints or doubles. Note
* that we don't use strtoul or strtoull here because we don't
* care about what the value is, just whether it is equal to
* zero or not.
*/
#ifdef TCL_WIDE_INT_IS_LONG
newBool = strtol(string, &end, 0);
if (end != string) {
/*
* Make sure the string has no garbage after the end of
* the int.
*/
while ((end < (string+length))
&& isspace(UCHAR(*end))) { /* INTL: ISO only */
end++;
}
if (end == (string+length)) {
newBool = (newBool != 0);
goto goodBoolean;
}
}
#else /* !TCL_WIDE_INT_IS_LONG */
Tcl_WideInt wide = strtoll(string, &end, 0);
if (end != string) {
/*
* Make sure the string has no garbage after the end of
* the wide int.
*/
while ((end < (string+length))
&& isspace(UCHAR(*end))) { /* INTL: ISO only */
end++;
}
if (end == (string+length)) {
newBool = (wide != Tcl_LongAsWide(0));
goto goodBoolean;
}
}
#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Still might be a string containing the characters representing an
* int or double that wasn't handled above. This would be a string
* like "27" or "1.0" that is non-zero and not "1". Such a string
* would result in the boolean value true. We try converting to
* double. If that succeeds and the resulting double is non-zero, we
* have a "true". Note that numbers can't have embedded NULLs.
*/
dbl = strtod(string, &end);
if (end == string) {
goto badBoolean;
}
/*
* Make sure the string has no garbage after the end of the double.
*/
while ((end < (string+length))
&& isspace(UCHAR(*end))) { /* INTL: ISO only */
end++;
}
if (end != (string+length)) {
goto badBoolean;
}
newBool = (dbl != 0.0);
}
}
/*
* Free the old internalRep before setting the new one. We do this as
* late as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
*/
goodBoolean:
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.longValue = newBool;
objPtr->typePtr = &tclBooleanType;
return TCL_OK;
badBoolean:
if (interp != NULL) {
/*
* Must copy string before resetting the result in case a caller
* is trying to convert the interpreter's result to a boolean.
*/
char buf[100];
sprintf(buf, "expected boolean value but got \"%.50s\"", string);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfBoolean --
*
* Update the string representation for a boolean object.
* Note: This procedure does not free an existing old string rep
* so storage will be lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from
* the boolean-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfBoolean(objPtr)
register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
{
char *s = ckalloc((unsigned) 2);
s[0] = (char) (objPtr->internalRep.longValue? '1' : '0');
s[1] = '\0';
objPtr->bytes = s;
objPtr->length = 1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewDoubleObj --
*
* This procedure is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new double object and
* initializes it from the argument double value.
*
* When TCL_MEM_DEBUG is defined, this procedure just returns the
* result of calling the debugging version Tcl_DbNewDoubleObj.
*
* Results:
* The newly created object is returned. This object will have an
* invalid string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewDoubleObj
Tcl_Obj *
Tcl_NewDoubleObj(dblValue)
register double dblValue; /* Double used to initialize the object. */
{
return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewDoubleObj(dblValue)
register double dblValue; /* Double used to initialize the object. */
{
register Tcl_Obj *objPtr;
TclNewObj(objPtr);
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
objPtr->typePtr = &tclDoubleType;
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewDoubleObj --
*
* This procedure is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new double objects. It is the
* same as the Tcl_NewDoubleObj procedure above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
* caller. This simplifies debugging since then the [memory active]
* command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
* result of calling Tcl_NewDoubleObj.
*
* Results:
* The newly created object is returned. This object will have an
* invalid string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewDoubleObj(dblValue, file, line)
register double dblValue; /* Double used to initialize the object. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
objPtr->typePtr = &tclDoubleType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewDoubleObj(dblValue, file, line)
register double dblValue; /* Double used to initialize the object. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
return Tcl_NewDoubleObj(dblValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetDoubleObj --
*
* Modify an object to be a double object and to have the specified
* double value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old
* internal rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetDoubleObj(objPtr, dblValue)
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
register double dblValue; /* Double used to set the object's value. */
{
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_SetDoubleObj called with shared object");
}
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.doubleValue = dblValue;
objPtr->typePtr = &tclDoubleType;
Tcl_InvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetDoubleFromObj --
*
* Attempt to return a double from the Tcl object "objPtr". If the
* object is not already a double, an attempt will be made to convert
* it to one.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If the object is not already a double, the conversion will free
* any old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object from which to get a double. */
register double *dblPtr; /* Place to store resulting double. */
{
register int result;
if (objPtr->typePtr == &tclDoubleType) {
*dblPtr = objPtr->internalRep.doubleValue;
return TCL_OK;
}
result = SetDoubleFromAny(interp, objPtr);
if (result == TCL_OK) {
*dblPtr = objPtr->internalRep.doubleValue;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* SetDoubleFromAny --
*
* Attempt to generate an double-precision floating point internal form
* for the Tcl object "objPtr".
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If no error occurs, a double is stored as "objPtr"s internal
* representation.
*
*----------------------------------------------------------------------
*/
static int
SetDoubleFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
char *string, *end;
double newDouble;
int length;
/*
* Get the string representation. Make it up-to-date if necessary.
*/
string = Tcl_GetStringFromObj(objPtr, &length);
/*
* Now parse "objPtr"s string as an double. Numbers can't have embedded
* NULLs. We use an implementation here that doesn't report errors in
* interp if interp is NULL.
*/
errno = 0;
newDouble = strtod(string, &end);
if (end == string) {
badDouble:
if (interp != NULL) {
/*
* Must copy string before resetting the result in case a caller
* is trying to convert the interpreter's result to an int.
*/
char buf[100];
sprintf(buf, "expected floating-point number but got \"%.50s\"",
string);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
}
return TCL_ERROR;
}
if (errno != 0) {
if (interp != NULL) {
TclExprFloatError(interp, newDouble);
}
return TCL_ERROR;
}
/*
* Make sure that the string has no garbage after the end of the double.
*/
while ((end < (string+length))
&& isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (end != (string+length)) {
goto badDouble;
}
/*
* The conversion to double succeeded. Free the old internalRep before
* setting the new one. We do this as late as possible to allow the
* conversion code, in particular Tcl_GetStringFromObj, to use that old
* internalRep.
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.doubleValue = newDouble;
objPtr->typePtr = &tclDoubleType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfDouble --
*
* Update the string representation for a double-precision floating
* point object. This must obey the current tcl_precision value for
* double-to-string conversions. Note: This procedure does not free an
* existing old string rep so storage will be lost if this has not
* already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from
* the double-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfDouble(objPtr)
register Tcl_Obj *objPtr; /* Double obj with string rep to update. */
{
char buffer[TCL_DOUBLE_SPACE];
register int len;
Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue,
buffer);
len = strlen(buffer);
objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
strcpy(objPtr->bytes, buffer);
objPtr->length = len;
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewIntObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewIntObj to create a new integer object end up calling the
* debugging procedure Tcl_DbNewLongObj instead.
*
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
* calls to Tcl_NewIntObj result in a call to one of the two
* Tcl_NewIntObj implementations below. We provide two implementations
* so that the Tcl core can be compiled to do memory debugging of the
* core even if a client does not request it for itself.
*
* Integer and long integer objects share the same "integer" type
* implementation. We store all integers as longs and Tcl_GetIntFromObj
* checks whether the current value of the long can be represented by
* an int.
*
* Results:
* The newly created object is returned. This object will have an
* invalid string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewIntObj
Tcl_Obj *
Tcl_NewIntObj(intValue)
register int intValue; /* Int used to initialize the new object. */
{
return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewIntObj(intValue)
register int intValue; /* Int used to initialize the new object. */
{
register Tcl_Obj *objPtr;
TclNewObj(objPtr);
objPtr->bytes = NULL;
objPtr->internalRep.longValue = (long)intValue;
objPtr->typePtr = &tclIntType;
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetIntObj --
*
* Modify an object to be an integer and to have the specified integer
* value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old
* internal rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetIntObj(objPtr, intValue)
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
register int intValue; /* Integer used to set object's value. */
{
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_SetIntObj called with shared object");
}
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.longValue = (long) intValue;
objPtr->typePtr = &tclIntType;
Tcl_InvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetIntFromObj --
*
* Attempt to return an int from the Tcl object "objPtr". If the object
* is not already an int, an attempt will be made to convert it to one.
*
* Integer and long integer objects share the same "integer" type
* implementation. We store all integers as longs and Tcl_GetIntFromObj
* checks whether the current value of the long can be represented by
* an int.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion or if the long integer held by the object
* can not be represented by an int, an error message is left in
* the interpreter's result unless "interp" is NULL.
*
* Side effects:
* If the object is not already an int, the conversion will free
* any old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetIntFromObj(interp, objPtr, intPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object from which to get a int. */
register int *intPtr; /* Place to store resulting int. */
{
int result;
Tcl_WideInt w = 0;
/*
* If the object isn't already an integer of any width, try to
* convert it to one.
*/
if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
result = SetIntOrWideFromAny(interp, objPtr);
if (result != TCL_OK) {
return result;
}
}
/*
* Object should now be either int or wide. Get its value.
*/
#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
w = objPtr->internalRep.wideValue;
} else
#endif
{
w = Tcl_LongAsWide(objPtr->internalRep.longValue);
}
if ((LLONG_MAX > UINT_MAX)
&& ((w > UINT_MAX) || (w < -(Tcl_WideInt)UINT_MAX))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent as non-long integer",
-1));
}
return TCL_ERROR;
}
*intPtr = (int)w;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetIntFromAny --
*
* Attempts to force the internal representation for a Tcl object
* to tclIntType, specifically.
*
* Results:
* The return value is a standard object Tcl result. If an
* error occurs during conversion, an error message is left in
* the interpreter's result unless "interp" is NULL.
*
*----------------------------------------------------------------------
*/
static int
SetIntFromAny( Tcl_Interp* interp,
/* Tcl interpreter */
Tcl_Obj* objPtr )
/* Pointer to the object to convert */
{
int result;
result = SetIntOrWideFromAny( interp, objPtr );
if ( result != TCL_OK ) {
return result;
}
if ( objPtr->typePtr != &tclIntType ) {
if ( interp != NULL ) {
char *s = "integer value too large to represent";
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetIntOrWideFromAny --
*
* Attempt to generate an integer internal form for the Tcl object
* "objPtr".
*
* Results:
* The return value is a standard object Tcl result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If no error occurs, an int is stored as "objPtr"s internal
* representation.
*
*----------------------------------------------------------------------
*/
static int
SetIntOrWideFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
char *string, *end;
int length;
register char *p;
unsigned long newLong;
int isNegative = 0;
int isWide = 0;
/*
* Get the string representation. Make it up-to-date if necessary.
*/
p = string = Tcl_GetStringFromObj(objPtr, &length);
/*
* Now parse "objPtr"s string as an int. We use an implementation here
* that doesn't report errors in interp if interp is NULL. Note: use
* strtoul instead of strtol for integer conversions to allow full-size
* unsigned numbers, but don't depend on strtoul to handle sign
* characters; it won't in some implementations.
*/
errno = 0;
for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
/* Empty loop body. */
}
if (*p == '-') {
p++;
isNegative = 1;
} else if (*p == '+') {
p++;
}
if (!isdigit(UCHAR(*p))) {
badInteger:
if (interp != NULL) {
/*
* Must copy string before resetting the result in case a caller
* is trying to convert the interpreter's result to an int.
*/
char buf[100];
sprintf(buf, "expected integer but got \"%.50s\"", string);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
TclCheckBadOctal(interp, string);
}
return TCL_ERROR;
}
newLong = strtoul(p, &end, 0);
if (end == p) {
goto badInteger;
}
if (errno == ERANGE) {
if (interp != NULL) {
char *s = "integer value too large to represent";
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
}
return TCL_ERROR;
}
/*
* Make sure that the string has no garbage after the end of the int.
*/
while ((end < (string+length))
&& isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (end != (string+length)) {
goto badInteger;
}
/*
* If the resulting integer will exceed the range of a long,
* put it into a wide instead. (Tcl Bug #868489)
*/
#ifndef TCL_WIDE_INT_IS_LONG
if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1)
|| (!isNegative && newLong > LONG_MAX)) {
isWide = 1;
}
#endif
/*
* The conversion to int succeeded. Free the old internalRep before
* setting the new one. We do this as late as possible to allow the
* conversion code, in particular Tcl_GetStringFromObj, to use that old
* internalRep.
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
if (isWide) {
objPtr->internalRep.wideValue =
(isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong);
objPtr->typePtr = &tclWideIntType;
} else {
objPtr->internalRep.longValue =
(isNegative ? -(long)newLong : (long)newLong);
objPtr->typePtr = &tclIntType;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfInt --
*
* Update the string representation for an integer object.
* Note: This procedure does not free an existing old string rep
* so storage will be lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from
* the int-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfInt(objPtr)
register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
{
char buffer[TCL_INTEGER_SPACE];
register int len;
len = TclFormatInt(buffer, objPtr->internalRep.longValue);
objPtr->bytes = ckalloc((unsigned) len + 1);
strcpy(objPtr->bytes, buffer);
objPtr->length = len;
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewLongObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewLongObj to create a new long integer object end up calling
* the debugging procedure Tcl_DbNewLongObj instead.
*
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
* calls to Tcl_NewLongObj result in a call to one of the two
* Tcl_NewLongObj implementations below. We provide two implementations
* so that the Tcl core can be compiled to do memory debugging of the
* core even if a client does not request it for itself.
*
* Integer and long integer objects share the same "integer" type
* implementation. We store all integers as longs and Tcl_GetIntFromObj
* checks whether the current value of the long can be represented by
* an int.
*
* Results:
* The newly created object is returned. This object will have an
* invalid string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewLongObj
Tcl_Obj *
Tcl_NewLongObj(longValue)
register long longValue; /* Long integer used to initialize the
* new object. */
{
return Tcl_DbNewLongObj(longValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewLongObj(longValue)
register long longValue; /* Long integer used to initialize the
* new object. */
{
register Tcl_Obj *objPtr;
TclNewObj(objPtr);
objPtr->bytes = NULL;
objPtr->internalRep.longValue = longValue;
objPtr->typePtr = &tclIntType;
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewLongObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewIntObj and Tcl_NewLongObj to create new integer or
* long integer objects end up calling the debugging procedure
* Tcl_DbNewLongObj instead. We provide two implementations of
* Tcl_DbNewLongObj so that whether the Tcl core is compiled to do
* memory debugging of the core is independent of whether a client
* requests debugging for itself.
*
* When the core is compiled with TCL_MEM_DEBUG defined,
* Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
* line number from its caller. This simplifies debugging since then
* the [memory active] command will report the caller's file name and
* line number when reporting objects that haven't been freed.
*
* Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
* this procedure just returns the result of calling Tcl_NewLongObj.
*
* Results:
* The newly created long integer object is returned. This object
* will have an invalid string representation. The returned object has
* ref count 0.
*
* Side effects:
* Allocates memory.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewLongObj(longValue, file, line)
register long longValue; /* Long integer used to initialize the
* new object. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
objPtr->internalRep.longValue = longValue;
objPtr->typePtr = &tclIntType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewLongObj(longValue, file, line)
register long longValue; /* Long integer used to initialize the
* new object. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
return Tcl_NewLongObj(longValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetLongObj --
*
* Modify an object to be an integer object and to have the specified
* long integer value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old
* internal rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetLongObj(objPtr, longValue)
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
register long longValue; /* Long integer used to initialize the
* object's value. */
{
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_SetLongObj called with shared object");
}
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.longValue = longValue;
objPtr->typePtr = &tclIntType;
Tcl_InvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetLongFromObj --
*
* Attempt to return an long integer from the Tcl object "objPtr". If
* the object is not already an int object, an attempt will be made to
* convert it to one.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If the object is not already an int object, the conversion will free
* any old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetLongFromObj(interp, objPtr, longPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object from which to get a long. */
register long *longPtr; /* Place to store resulting long. */
{
register int result;
if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
result = SetIntOrWideFromAny(interp, objPtr);
if (result != TCL_OK) {
return result;
}
}
#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
/*
* If the object is already a wide integer, don't convert it.
* This code allows for any integer in the range -ULONG_MAX to
* ULONG_MAX to be converted to a long, ignoring overflow.
* The rule preserves existing semantics for conversion of
* integers on input, but avoids inadvertent demotion of
* wide integers to 32-bit ones in the internal rep.
*/
Tcl_WideInt w = objPtr->internalRep.wideValue;
if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) {
*longPtr = Tcl_WideAsLong(w);
return TCL_OK;
} else {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
}
return TCL_ERROR;
}
}
#endif
*longPtr = objPtr->internalRep.longValue;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetWideIntFromAny --
*
* Attempt to generate an integer internal form for the Tcl object
* "objPtr".
*
* Results:
* The return value is a standard object Tcl result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If no error occurs, an int is stored as "objPtr"s internal
* representation.
*
*----------------------------------------------------------------------
*/
static int
SetWideIntFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
char *string, *end;
int length;
register char *p;
Tcl_WideInt newWide;
/*
* Get the string representation. Make it up-to-date if necessary.
*/
p = string = Tcl_GetStringFromObj(objPtr, &length);
/*
* Now parse "objPtr"s string as an int. We use an implementation here
* that doesn't report errors in interp if interp is NULL. Note: use
* strtoull instead of strtoll for integer conversions to allow full-size
* unsigned numbers, but don't depend on strtoull to handle sign
* characters; it won't in some implementations.
*/
errno = 0;
#ifdef TCL_STRTOUL_SIGN_CHECK
for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
/* Empty loop body. */
}
if (*p == '-') {
p++;
newWide = -((Tcl_WideInt)strtoull(p, &end, 0));
} else if (*p == '+') {
p++;
newWide = strtoull(p, &end, 0);
} else
#else
newWide = strtoull(p, &end, 0);
#endif
if (end == p) {
badInteger:
if (interp != NULL) {
/*
* Must copy string before resetting the result in case a caller
* is trying to convert the interpreter's result to an int.
*/
char buf[100];
sprintf(buf, "expected integer but got \"%.50s\"", string);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
TclCheckBadOctal(interp, string);
}
return TCL_ERROR;
}
if (errno == ERANGE) {
if (interp != NULL) {
char *s = "integer value too large to represent";
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
}
return TCL_ERROR;
}
/*
* Make sure that the string has no garbage after the end of the int.
*/
while ((end < (string+length))
&& isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (end != (string+length)) {
goto badInteger;
}
/*
* The conversion to int succeeded. Free the old internalRep before
* setting the new one. We do this as late as possible to allow the
* conversion code, in particular Tcl_GetStringFromObj, to use that old
* internalRep.
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.wideValue = newWide;
#else
if (TCL_ERROR == SetIntFromAny(interp, objPtr)) {
return TCL_ERROR;
}
#endif
objPtr->typePtr = &tclWideIntType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfWideInt --
*
* Update the string representation for a wide integer object.
* Note: This procedure does not free an existing old string rep
* so storage will be lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from
* the wideInt-to-string conversion.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_WIDE_INT_IS_LONG
static void
UpdateStringOfWideInt(objPtr)
register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
{
char buffer[TCL_INTEGER_SPACE+2];
register unsigned len;
register Tcl_WideInt wideVal = objPtr->internalRep.wideValue;
/*
* Note that sprintf will generate a compiler warning under
* Mingw claiming %I64 is an unknown format specifier.
* Just ignore this warning. We can't use %L as the format
* specifier since that gets printed as a 32 bit value.
*/
sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
len = strlen(buffer);
objPtr->bytes = ckalloc((unsigned) len + 1);
memcpy(objPtr->bytes, buffer, len + 1);
objPtr->length = len;
}
#endif /* TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
*
* Tcl_NewWideIntObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewWideIntObj to create a new 64-bit integer object end up calling
* the debugging procedure Tcl_DbNewWideIntObj instead.
*
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
* calls to Tcl_NewWideIntObj result in a call to one of the two
* Tcl_NewWideIntObj implementations below. We provide two implementations
* so that the Tcl core can be compiled to do memory debugging of the
* core even if a client does not request it for itself.
*
* Results:
* The newly created object is returned. This object will have an
* invalid string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewWideIntObj
Tcl_Obj *
Tcl_NewWideIntObj(wideValue)
register Tcl_WideInt wideValue; /* Wide integer used to initialize
* the new object. */
{
return Tcl_DbNewWideIntObj(wideValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewWideIntObj(wideValue)
register Tcl_WideInt wideValue; /* Wide integer used to initialize
* the new object. */
{
register Tcl_Obj *objPtr;
TclNewObj(objPtr);
objPtr->bytes = NULL;
objPtr->internalRep.wideValue = wideValue;
objPtr->typePtr = &tclWideIntType;
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewWideIntObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewWideIntObj to create new wide integer end up calling
* the debugging procedure Tcl_DbNewWideIntObj instead. We
* provide two implementations of Tcl_DbNewWideIntObj so that
* whether the Tcl core is compiled to do memory debugging of the
* core is independent of whether a client requests debugging for
* itself.
*
* When the core is compiled with TCL_MEM_DEBUG defined,
* Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file
* name and line number from its caller. This simplifies
* debugging since then the checkmem command will report the
* caller's file name and line number when reporting objects that
* haven't been freed.
*
* Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
* this procedure just returns the result of calling Tcl_NewWideIntObj.
*
* Results:
* The newly created wide integer object is returned. This object
* will have an invalid string representation. The returned object has
* ref count 0.
*
* Side effects:
* Allocates memory.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewWideIntObj(wideValue, file, line)
register Tcl_WideInt wideValue; /* Wide integer used to initialize
* the new object. */
CONST char *file; /* The name of the source file
* calling this procedure; used for
* debugging. */
int line; /* Line number in the source file;
* used for debugging. */
{
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
objPtr->internalRep.wideValue = wideValue;
objPtr->typePtr = &tclWideIntType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewWideIntObj(wideValue, file, line)
register Tcl_WideInt wideValue; /* Long integer used to initialize
* the new object. */
CONST char *file; /* The name of the source file
* calling this procedure; used for
* debugging. */
int line; /* Line number in the source file;
* used for debugging. */
{
return Tcl_NewWideIntObj(wideValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetWideIntObj --
*
* Modify an object to be a wide integer object and to have the
* specified wide integer value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old
* internal rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetWideIntObj(objPtr, wideValue)
register Tcl_Obj *objPtr; /* Object w. internal rep to init. */
register Tcl_WideInt wideValue; /* Wide integer used to initialize
* the object's value. */
{
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_SetWideIntObj called with shared object");
}
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.wideValue = wideValue;
objPtr->typePtr = &tclWideIntType;
Tcl_InvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetWideIntFromObj --
*
* Attempt to return a wide integer from the Tcl object "objPtr". If
* the object is not already a wide int object, an attempt will be made
* to convert it to one.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If the object is not already an int object, the conversion will free
* any old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* Object from which to get a wide int. */
register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */
{
register int result;
if (objPtr->typePtr == &tclWideIntType) {
gotWide:
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
/*
* This cast is safe; all valid ints/longs are wides.
*/
objPtr->internalRep.wideValue =
Tcl_LongAsWide(objPtr->internalRep.longValue);
objPtr->typePtr = &tclWideIntType;
goto gotWide;
}
result = SetWideIntFromAny(interp, objPtr);
if (result == TCL_OK) {
*wideIntPtr = objPtr->internalRep.wideValue;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbIncrRefCount --
*
* This procedure is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. This checks to see whether or not
* the memory has been freed before incrementing the ref count.
*
* When TCL_MEM_DEBUG is not defined, this procedure just increments
* the reference count of the object.
*
* Results:
* None.
*
* Side effects:
* The object's ref count is incremented.
*
*----------------------------------------------------------------------
*/
void
Tcl_DbIncrRefCount(objPtr, file, line)
register Tcl_Obj *objPtr; /* The object we are registering a
* reference to. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
panic("Trying to increment refCount of previously disposed object.");
}
#endif
++(objPtr)->refCount;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbDecrRefCount --
*
* This procedure is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. This checks to see whether or not
* the memory has been freed before decrementing the ref count.
*
* When TCL_MEM_DEBUG is not defined, this procedure just decrements
* the reference count of the object.
*
* Results:
* None.
*
* Side effects:
* The object's ref count is incremented.
*
*----------------------------------------------------------------------
*/
void
Tcl_DbDecrRefCount(objPtr, file, line)
register Tcl_Obj *objPtr; /* The object we are releasing a reference
* to. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
panic("Trying to decrement refCount of previously disposed object.");
}
#endif
if (--(objPtr)->refCount <= 0) {
TclFreeObj(objPtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbIsShared --
*
* This procedure is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It tests whether the object has a ref
* count greater than one.
*
* When TCL_MEM_DEBUG is not defined, this procedure just tests
* if the object has a ref count greater than one.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_DbIsShared(objPtr, file, line)
register Tcl_Obj *objPtr; /* The object to test for being shared. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
panic("Trying to check whether previously disposed object is shared.");
}
#endif
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
if ((objPtr)->refCount <= 1) {
tclObjsShared[1]++;
} else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) {
tclObjsShared[(objPtr)->refCount]++;
} else {
tclObjsShared[0]++;
}
Tcl_MutexUnlock(&tclObjMutex);
#endif
return ((objPtr)->refCount > 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitObjHashTable --
*
* Given storage for a hash table, set up the fields to prepare
* the hash table for use, the keys are Tcl_Obj *.
*
* Results:
* None.
*
* Side effects:
* TablePtr is now ready to be passed to Tcl_FindHashEntry and
* Tcl_CreateHashEntry.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitObjHashTable(tablePtr)
register Tcl_HashTable *tablePtr; /* Pointer to table record, which
* is supplied by the caller. */
{
Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS,
&tclObjHashKeyType);
}
/*
*----------------------------------------------------------------------
*
* AllocObjEntry --
*
* Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key.
*
* Results:
* The return value is a pointer to the created entry.
*
* Side effects:
* Increments the reference count on the object.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocObjEntry(tablePtr, keyPtr)
Tcl_HashTable *tablePtr; /* Hash table. */
VOID *keyPtr; /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
Tcl_HashEntry *hPtr;
hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)));
hPtr->key.oneWordValue = (char *) objPtr;
Tcl_IncrRefCount (objPtr);
return hPtr;
}
/*
*----------------------------------------------------------------------
*
* CompareObjKeys --
*
* Compares two Tcl_Obj * keys.
*
* Results:
* The return value is 0 if they are different and 1 if they are
* the same.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CompareObjKeys(keyPtr, hPtr)
VOID *keyPtr; /* New key to compare. */
Tcl_HashEntry *hPtr; /* Existing key to compare. */
{
Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr;
Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
register CONST char *p1, *p2;
register int l1, l2;
/*
* If the object pointers are the same then they match.
*/
if (objPtr1 == objPtr2) {
return 1;
}
/*
* Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
* in a register.
*/
p1 = TclGetString(objPtr1);
l1 = objPtr1->length;
p2 = TclGetString(objPtr2);
l2 = objPtr2->length;
/*
* Only compare if the string representations are of the same length.
*/
if (l1 == l2) {
for (;; p1++, p2++, l1--) {
if (*p1 != *p2) {
break;
}
if (l1 == 0) {
return 1;
}
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* FreeObjEntry --
*
* Frees space for a Tcl_HashEntry containing the Tcl_Obj * key.
*
* Results:
* The return value is a pointer to the created entry.
*
* Side effects:
* Decrements the reference count of the object.
*
*----------------------------------------------------------------------
*/
static void
FreeObjEntry(hPtr)
Tcl_HashEntry *hPtr; /* Hash entry to free. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
Tcl_DecrRefCount (objPtr);
ckfree ((char *) hPtr);
}
/*
*----------------------------------------------------------------------
*
* HashObjKey --
*
* Compute a one-word summary of the string representation of the
* Tcl_Obj, which can be used to generate a hash index.
*
* Results:
* The return value is a one-word summary of the information in
* the string representation of the Tcl_Obj.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static unsigned int
HashObjKey(tablePtr, keyPtr)
Tcl_HashTable *tablePtr; /* Hash table. */
VOID *keyPtr; /* Key from which to compute hash value. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
CONST char *string = TclGetString(objPtr);
int length = objPtr->length;
unsigned int result;
int i;
/*
* I tried a zillion different hash functions and asked many other
* people for advice. Many people had their own favorite functions,
* all different, but no-one had much idea why they were good ones.
* I chose the one below (multiply by 9 and add new character)
* because of the following reasons:
*
* 1. Multiplying by 10 is perfect for keys that are decimal strings,
* and multiplying by 9 is just about as good.
* 2. Times-9 is (shift-left-3) plus (old). This means that each
* character's bits hang around in the low-order bits of the
* hash value for ever, plus they spread fairly rapidly up to
* the high-order bits to fill out the hash value. This seems
* works well both for decimal and non-decimal strings.
*/
result = 0;
for (i=0 ; ivarFramePtr;
name = Tcl_GetString(objPtr);
if ((*name++ == ':') && (*name == ':')) {
iPtr->varFramePtr = NULL;
}
/*
* Get the internal representation, converting to a command type if
* needed. The internal representation is a ResolvedCmdName that points
* to the actual command.
*/
if (objPtr->typePtr != &tclCmdNameType) {
result = tclCmdNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
iPtr->varFramePtr = savedFramePtr;
return (Tcl_Command) NULL;
}
}
resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
/*
* Get the current namespace.
*/
if (iPtr->varFramePtr != NULL) {
currNsPtr = iPtr->varFramePtr->nsPtr;
} else {
currNsPtr = iPtr->globalNsPtr;
}
/*
* Check the context namespace and the namespace epoch of the resolved
* symbol to make sure that it is fresh. If not, then force another
* conversion to the command type, to discard the old rep and create a
* new one. Note that we verify that the namespace id of the context
* namespace is the same as the one we cached; this insures that the
* namespace wasn't deleted and a new one created at the same address
* with the same command epoch.
*/
cmdPtr = NULL;
if ((resPtr != NULL)
&& (resPtr->refNsPtr == currNsPtr)
&& (resPtr->refNsId == currNsPtr->nsId)
&& (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
cmdPtr = resPtr->cmdPtr;
if (cmdPtr->cmdEpoch != resPtr->cmdEpoch
|| (cmdPtr->flags & CMD_IS_DELETED)) {
cmdPtr = NULL;
}
}
if (cmdPtr == NULL) {
result = tclCmdNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
iPtr->varFramePtr = savedFramePtr;
return (Tcl_Command) NULL;
}
resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL) {
cmdPtr = resPtr->cmdPtr;
}
}
iPtr->varFramePtr = savedFramePtr;
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
*
* TclSetCmdNameObj --
*
* Modify an object to be an CmdName object that refers to the argument
* Command structure.
*
* Results:
* None.
*
* Side effects:
* The object's old internal rep is freed. It's string rep is not
* changed. The refcount in the Command structure is incremented to
* keep it from being freed if the command is later deleted until
* TclExecuteByteCode has a chance to recognize that it was deleted.
*
*----------------------------------------------------------------------
*/
void
TclSetCmdNameObj(interp, objPtr, cmdPtr)
Tcl_Interp *interp; /* Points to interpreter containing command
* that should be cached in objPtr. */
register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to
* a CmdName object. */
Command *cmdPtr; /* Points to Command structure that the
* CmdName object should refer to. */
{
Interp *iPtr = (Interp *) interp;
register ResolvedCmdName *resPtr;
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
register Namespace *currNsPtr;
if (oldTypePtr == &tclCmdNameType) {
return;
}
/*
* Get the current namespace.
*/
if (iPtr->varFramePtr != NULL) {
currNsPtr = iPtr->varFramePtr->nsPtr;
} else {
currNsPtr = iPtr->globalNsPtr;
}
cmdPtr->refCount++;
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
resPtr->cmdPtr = cmdPtr;
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
/*
*----------------------------------------------------------------------
*
* FreeCmdNameInternalRep --
*
* Frees the resources associated with a cmdName object's internal
* representation.
*
* Results:
* None.
*
* Side effects:
* Decrements the ref count of any cached ResolvedCmdName structure
* pointed to by the cmdName's internal representation. If this is
* the last use of the ResolvedCmdName, it is freed. This in turn
* decrements the ref count of the Command structure pointed to by
* the ResolvedSymbol, which may free the Command structure.
*
*----------------------------------------------------------------------
*/
static void
FreeCmdNameInternalRep(objPtr)
register Tcl_Obj *objPtr; /* CmdName object with internal
* representation to free. */
{
register ResolvedCmdName *resPtr =
(ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL) {
/*
* Decrement the reference count of the ResolvedCmdName structure.
* If there are no more uses, free the ResolvedCmdName structure.
*/
resPtr->refCount--;
if (resPtr->refCount == 0) {
/*
* Now free the cached command, unless it is still in its
* hash table or if there are other references to it
* from other cmdName objects.
*/
Command *cmdPtr = resPtr->cmdPtr;
TclCleanupCommand(cmdPtr);
ckfree((char *) resPtr);
}
}
}
/*
*----------------------------------------------------------------------
*
* DupCmdNameInternalRep --
*
* Initialize the internal representation of an cmdName Tcl_Obj to a
* copy of the internal representation of an existing cmdName object.
*
* Results:
* None.
*
* Side effects:
* "copyPtr"s internal rep is set to point to the ResolvedCmdName
* structure corresponding to "srcPtr"s internal rep. Increments the
* ref count of the ResolvedCmdName structure pointed to by the
* cmdName's internal representation.
*
*----------------------------------------------------------------------
*/
static void
DupCmdNameInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
register ResolvedCmdName *resPtr =
(ResolvedCmdName *) srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
if (resPtr != NULL) {
resPtr->refCount++;
}
copyPtr->typePtr = &tclCmdNameType;
}
/*
*----------------------------------------------------------------------
*
* SetCmdNameFromAny --
*
* Generate an cmdName internal form for the Tcl object "objPtr".
*
* Results:
* The return value is a standard Tcl result. The conversion always
* succeeds and TCL_OK is returned.
*
* Side effects:
* A pointer to a ResolvedCmdName structure that holds a cached pointer
* to the command with a name that matches objPtr's string rep is
* stored as objPtr's internal representation. This ResolvedCmdName
* pointer will be NULL if no matching command was found. The ref count
* of the cached Command's structure (if any) is also incremented.
*
*----------------------------------------------------------------------
*/
static int
SetCmdNameFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
char *name;
Tcl_Command cmd;
register Command *cmdPtr;
Namespace *currNsPtr;
register ResolvedCmdName *resPtr;
if (interp == NULL) {
return TCL_ERROR;
}
/*
* Get "objPtr"s string representation. Make it up-to-date if necessary.
*/
name = objPtr->bytes;
if (name == NULL) {
name = Tcl_GetString(objPtr);
}
/*
* Find the Command structure, if any, that describes the command called
* "name". Build a ResolvedCmdName that holds a cached pointer to this
* Command, and bump the reference count in the referenced Command
* structure. A Command structure will not be deleted as long as it is
* referenced from a CmdName object.
*/
cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
/*flags*/ 0);
cmdPtr = (Command *) cmd;
if (cmdPtr != NULL) {
/*
* Get the current namespace.
*/
if (iPtr->varFramePtr != NULL) {
currNsPtr = iPtr->varFramePtr->nsPtr;
} else {
currNsPtr = iPtr->globalNsPtr;
}
cmdPtr->refCount++;
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
resPtr->cmdPtr = cmdPtr;
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
} else {
resPtr = NULL; /* no command named "name" was found */
}
/*
* Free the old internalRep before setting the new one. We do this as
* late as possible to allow the conversion code, in particular
* GetStringFromObj, to use that old internalRep. If no Command
* structure was found, leave NULL as the cached value.
*/
if ((objPtr->typePtr != NULL)
&& (objPtr->typePtr->freeIntRepProc != NULL)) {
objPtr->typePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclCmdMZ.c 0000644 0036047 0045461 00000427541 12052456743 014167 0 ustar dgp 771div /*
* tclCmdMZ.c --
*
* This file contains the top-level command routines for most of
* the Tcl built-in commands whose names begin with the letters
* M to Z. It contains only commands in the generic core (i.e.
* those that don't depend much upon UNIX facilities).
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 Scriptics Corporation.
* 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.
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"
#include "tclCompile.h"
/*
* Structures used to hold information about variable traces:
*/
typedef struct {
int flags; /* Operations for which Tcl command is
* to be invoked. */
size_t length; /* Number of non-NULL chars. in command. */
char command[4]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to
* hold command. This field must be the
* last in the structure, so that it can
* be larger than 4 bytes. */
} TraceVarInfo;
typedef struct {
VarTrace trace;
TraceVarInfo tvar;
} CompoundVarTrace;
/*
* Structure used to hold information about command traces:
*/
typedef struct {
int flags; /* Operations for which Tcl command is
* to be invoked. */
size_t length; /* Number of non-NULL chars. in command. */
Tcl_Trace stepTrace; /* Used for execution traces, when tracing
* inside the given command */
int startLevel; /* Used for bookkeeping with step execution
* traces, store the level at which the step
* trace was invoked */
char *startCmd; /* Used for bookkeeping with step execution
* traces, store the command name which invoked
* step trace */
int curFlags; /* Trace flags for the current command */
int curCode; /* Return code for the current command */
int refCount; /* Used to ensure this structure is
* not deleted too early. Keeps track
* of how many pieces of code have
* a pointer to this structure. */
char command[4]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to
* hold command. This field must be the
* last in the structure, so that it can
* be larger than 4 bytes. */
} TraceCommandInfo;
/*
* Used by command execution traces. Note that we assume in the code
* that the first two defines are exactly 4 times the
* 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants.
*
* TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command
* currently being traced, before execution.
* TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command
* currently being traced, after execution.
* TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags.
* TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace
* is currently executing. Therefore we
* don't let further traces execute.
* TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly
* by the command being traced, not because
* of an internal trace.
* The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also
* be used in command execution traces.
*/
#define TCL_TRACE_ENTER_DURING_EXEC 4
#define TCL_TRACE_LEAVE_DURING_EXEC 8
#define TCL_TRACE_ANY_EXEC 15
#define TCL_TRACE_EXEC_IN_PROGRESS 0x10
#define TCL_TRACE_EXEC_DIRECT 0x20
/*
* Forward declarations for procedures defined in this file:
*/
typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp,
int optionIndex, int objc, Tcl_Obj *CONST objv[]));
Tcl_TraceTypeObjCmd TclTraceVariableObjCmd;
Tcl_TraceTypeObjCmd TclTraceCommandObjCmd;
Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd;
/*
* Each subcommand has a number of 'types' to which it can apply.
* Currently 'execution', 'command' and 'variable' are the only
* types supported. These three arrays MUST be kept in sync!
* In the future we may provide an API to add to the list of
* supported trace types.
*/
static CONST char *traceTypeOptions[] = {
"execution", "command", "variable", (char*) NULL
};
static Tcl_TraceTypeObjCmd *CONST traceSubCmds[] = {
TclTraceExecutionObjCmd,
TclTraceCommandObjCmd,
TclTraceVariableObjCmd
};
/*
* Declarations for local procedures to this file:
*/
static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
Trace *tracePtr, Command *cmdPtr,
CONST char *command, int numChars,
int objc, Tcl_Obj *CONST objv[]));
static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
static void TraceCommandProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *oldName,
CONST char *newName, int flags));
static Tcl_CmdObjTraceProc TraceExecutionProc;
#ifdef TCL_TIP280
static void ListLines _ANSI_ARGS_((Tcl_Obj* listObj, int line,
int n, int* lines,
Tcl_Obj* const* elems));
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_PwdObjCmd --
*
* This procedure is invoked to process the "pwd" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_PwdObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *retVal;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
retVal = Tcl_FSGetCwd(interp);
if (retVal == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, retVal);
Tcl_DecrRefCount(retVal);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegexpObjCmd --
*
* This procedure is invoked to process the "regexp" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_RegexpObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, indices, match, about, offset, all, doinline, numMatchesSaved;
int cflags, eflags, stringLength;
Tcl_RegExp regExpr;
Tcl_Obj *objPtr, *resultPtr;
Tcl_RegExpInfo info;
static CONST char *options[] = {
"-all", "-about", "-indices", "-inline",
"-expanded", "-line", "-linestop", "-lineanchor",
"-nocase", "-start", "--", (char *) NULL
};
enum options {
REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE,
REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR,
REGEXP_NOCASE, REGEXP_START, REGEXP_LAST
};
indices = 0;
about = 0;
cflags = TCL_REG_ADVANCED;
eflags = 0;
offset = 0;
all = 0;
doinline = 0;
for (i = 1; i < objc; i++) {
char *name;
int index;
name = Tcl_GetString(objv[i]);
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case REGEXP_ALL: {
all = 1;
break;
}
case REGEXP_INDICES: {
indices = 1;
break;
}
case REGEXP_INLINE: {
doinline = 1;
break;
}
case REGEXP_NOCASE: {
cflags |= TCL_REG_NOCASE;
break;
}
case REGEXP_ABOUT: {
about = 1;
break;
}
case REGEXP_EXPANDED: {
cflags |= TCL_REG_EXPANDED;
break;
}
case REGEXP_LINE: {
cflags |= TCL_REG_NEWLINE;
break;
}
case REGEXP_LINESTOP: {
cflags |= TCL_REG_NLSTOP;
break;
}
case REGEXP_LINEANCHOR: {
cflags |= TCL_REG_NLANCH;
break;
}
case REGEXP_START: {
if (++i >= objc) {
goto endOfForLoop;
}
if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
return TCL_ERROR;
}
if (offset < 0) {
offset = 0;
}
break;
}
case REGEXP_LAST: {
i++;
goto endOfForLoop;
}
}
}
endOfForLoop:
if ((objc - i) < (2 - about)) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
return TCL_ERROR;
}
objc -= i;
objv += i;
if (doinline && ((objc - 2) != 0)) {
/*
* User requested -inline, but specified match variables - a no-no.
*/
Tcl_AppendResult(interp, "regexp match variables not allowed",
" when using -inline", (char *) NULL);
return TCL_ERROR;
}
/*
* Handle the odd about case separately.
*/
if (about) {
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Get the length of the string that we are matching against so
* we can do the termination test for -all matches. Do this before
* getting the regexp to avoid shimmering problems.
*/
objPtr = objv[1];
stringLength = Tcl_GetCharLength(objPtr);
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
if (offset > 0) {
/*
* Add flag if using offset (string is part of a larger string),
* so that "^" won't match.
*/
eflags |= TCL_REG_NOTBOL;
}
objc -= 2;
objv += 2;
resultPtr = Tcl_GetObjResult(interp);
if (doinline) {
/*
* Save all the subexpressions, as we will return them as a list
*/
numMatchesSaved = -1;
} else {
/*
* Save only enough subexpressions for matches we want to keep,
* expect in the case of -all, where we need to keep at least
* one to know where to move the offset.
*/
numMatchesSaved = (objc == 0) ? all : objc;
}
/*
* The following loop is to handle multiple matches within the
* same source string; each iteration handles one match. If "-all"
* hasn't been specified then the loop body only gets executed once.
* We terminate the loop when the starting offset is past the end of the
* string.
*/
while (1) {
match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
offset /* offset */, numMatchesSaved, eflags
| ((offset > 0 && offset < stringLength &&
(Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n'))
? TCL_REG_NOTBOL : 0));
if (match < 0) {
return TCL_ERROR;
}
if (match == 0) {
/*
* We want to set the value of the intepreter result only when
* this is the first time through the loop.
*/
if (all <= 1) {
/*
* If inlining, set the interpreter's object result to an
* empty list, otherwise set it to an integer object w/
* value 0.
*/
if (doinline) {
Tcl_SetListObj(resultPtr, 0, NULL);
} else {
Tcl_SetIntObj(resultPtr, 0);
}
return TCL_OK;
}
break;
}
/*
* If additional variable names have been specified, return
* index information in those variables.
*/
Tcl_RegExpGetInfo(regExpr, &info);
if (doinline) {
/*
* It's the number of substitutions, plus one for the matchVar
* at index 0
*/
objc = info.nsubs + 1;
}
for (i = 0; i < objc; i++) {
Tcl_Obj *newPtr;
if (indices) {
int start, end;
Tcl_Obj *objs[2];
/*
* Only adjust the match area if there was a match for
* that area. (Scriptics Bug 4391/SF Bug #219232)
*/
if (i <= info.nsubs && info.matches[i].start >= 0) {
start = offset + info.matches[i].start;
end = offset + info.matches[i].end;
/*
* Adjust index so it refers to the last character in the
* match instead of the first character after the match.
*/
if (end >= offset) {
end--;
}
} else {
start = -1;
end = -1;
}
objs[0] = Tcl_NewLongObj(start);
objs[1] = Tcl_NewLongObj(end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if (i <= info.nsubs) {
newPtr = Tcl_GetRange(objPtr,
offset + info.matches[i].start,
offset + info.matches[i].end - 1);
} else {
newPtr = Tcl_NewObj();
}
}
if (doinline) {
if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
!= TCL_OK) {
Tcl_DecrRefCount(newPtr);
return TCL_ERROR;
}
} else {
Tcl_Obj *valuePtr;
valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
if (valuePtr == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
Tcl_GetString(objv[i]), "\"", (char *) NULL);
Tcl_DecrRefCount(newPtr);
return TCL_ERROR;
}
}
}
if (all == 0) {
break;
}
/*
* Adjust the offset to the character just after the last one
* in the matchVar and increment all to count how many times
* we are making a match. We always increment the offset by at least
* one to prevent endless looping (as in the case:
* regexp -all {a*} a). Otherwise, when we match the NULL string at
* the end of the input string, we will loop indefinately (because the
* length of the match is 0, so offset never changes).
*/
if (info.matches[0].end == 0) {
offset++;
}
offset += info.matches[0].end;
all++;
eflags |= TCL_REG_NOTBOL;
if (offset >= stringLength) {
break;
}
}
/*
* Set the interpreter's object result to an integer object
* with value 1 if -all wasn't specified, otherwise it's all-1
* (the number of times through the while - 1).
* Get the resultPtr again as the Tcl_ObjSetVar2 above may have
* cause the result to change. [Patch #558324] (watson).
*/
if (!doinline) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegsubObjCmd --
*
* This procedure is invoked to process the "regsub" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_RegsubObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
int start, end, subStart, subEnd, match;
Tcl_RegExp regExpr;
Tcl_RegExpInfo info;
Tcl_Obj *resultPtr, *subPtr, *objPtr;
Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
static CONST char *options[] = {
"-all", "-nocase", "-expanded",
"-line", "-linestop", "-lineanchor", "-start",
"--", NULL
};
enum options {
REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED,
REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START,
REGSUB_LAST
};
cflags = TCL_REG_ADVANCED;
all = 0;
offset = 0;
resultPtr = NULL;
for (idx = 1; idx < objc; idx++) {
char *name;
int index;
name = Tcl_GetString(objv[idx]);
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case REGSUB_ALL: {
all = 1;
break;
}
case REGSUB_NOCASE: {
cflags |= TCL_REG_NOCASE;
break;
}
case REGSUB_EXPANDED: {
cflags |= TCL_REG_EXPANDED;
break;
}
case REGSUB_LINE: {
cflags |= TCL_REG_NEWLINE;
break;
}
case REGSUB_LINESTOP: {
cflags |= TCL_REG_NLSTOP;
break;
}
case REGSUB_LINEANCHOR: {
cflags |= TCL_REG_NLANCH;
break;
}
case REGSUB_START: {
if (++idx >= objc) {
goto endOfForLoop;
}
if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) {
return TCL_ERROR;
}
if (offset < 0) {
offset = 0;
}
break;
}
case REGSUB_LAST: {
idx++;
goto endOfForLoop;
}
}
}
endOfForLoop:
if (objc-idx < 3 || objc-idx > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? exp string subSpec ?varName?");
return TCL_ERROR;
}
objc -= idx;
objv += idx;
if (all && (offset == 0)
&& (strpbrk(Tcl_GetString(objv[2]), "&\\") == NULL)
&& (strpbrk(Tcl_GetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
/*
* This is a simple one pair string map situation. We make use of
* a slightly modified version of the one pair STR_MAP code.
*/
int slen, nocase;
int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *,
unsigned long));
Tcl_UniChar *p, wsrclc;
numMatches = 0;
nocase = (cflags & TCL_REG_NOCASE);
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen);
wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen);
wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
wend = wstring + wlen - (slen ? slen - 1 : 0);
result = TCL_OK;
if (slen == 0) {
/*
* regsub behavior for "" matches between each character.
* 'string map' skips the "" case.
*/
if (wstring < wend) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
for (; wstring < wend; wstring++) {
Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
Tcl_AppendUnicodeToObj(resultPtr, wstring, 1);
numMatches++;
}
wlen = 0;
}
} else {
wsrclc = Tcl_UniCharToLower(*wsrc);
for (p = wfirstChar = wstring; wstring < wend; wstring++) {
if (((*wstring == *wsrc) ||
(nocase && (Tcl_UniCharToLower(*wstring) ==
wsrclc))) &&
((slen == 1) || (strCmpFn(wstring, wsrc,
(unsigned long) slen) == 0))) {
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
}
if (p != wstring) {
Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);
p = wstring + slen;
} else {
p += slen;
}
wstring = p - 1;
Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
numMatches++;
}
}
if (numMatches) {
wlen = wfirstChar + wlen - p;
wstring = p;
}
}
objPtr = NULL;
subPtr = NULL;
goto regsubDone;
}
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
/*
* Make sure to avoid problems where the objects are shared. This
* can cause RegExpObj <> UnicodeObj shimmering that causes data
* corruption. [Bug #461322]
*/
if (objv[1] == objv[0]) {
objPtr = Tcl_DuplicateObj(objv[1]);
} else {
objPtr = objv[1];
}
wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
if (objv[2] == objv[0]) {
subPtr = Tcl_DuplicateObj(objv[2]);
} else {
subPtr = objv[2];
}
wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
result = TCL_OK;
/*
* The following loop is to handle multiple matches within the
* same source string; each iteration handles one match and its
* corresponding substitution. If "-all" hasn't been specified
* then the loop body only gets executed once. We must use
* 'offset <= wlen' in particular for the case where the regexp
* pattern can match the empty string - this is useful when
* doing, say, 'regsub -- ^ $str ...' when $str might be empty.
*/
numMatches = 0;
for ( ; offset <= wlen; ) {
/*
* The flags argument is set if string is part of a larger string,
* so that "^" won't match.
*/
match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
10 /* matches */, ((offset > 0 &&
(wstring[offset-1] != (Tcl_UniChar)'\n'))
? TCL_REG_NOTBOL : 0));
if (match < 0) {
result = TCL_ERROR;
goto done;
}
if (match == 0) {
break;
}
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
if (offset > 0) {
/*
* Copy the initial portion of the string in if an offset
* was specified.
*/
Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
}
}
numMatches++;
/*
* Copy the portion of the source string before the match to the
* result variable.
*/
Tcl_RegExpGetInfo(regExpr, &info);
start = info.matches[0].start;
end = info.matches[0].end;
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);
/*
* Append the subSpec argument to the variable, making appropriate
* substitutions. This code is a bit hairy because of the backslash
* conventions and because the code saves up ranges of characters in
* subSpec to reduce the number of calls to Tcl_SetVar.
*/
wsrc = wfirstChar = wsubspec;
wend = wsubspec + wsublen;
for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) {
if (ch == '&') {
idx = 0;
} else if (ch == '\\') {
ch = wsrc[1];
if ((ch >= '0') && (ch <= '9')) {
idx = ch - '0';
} else if ((ch == '\\') || (ch == '&')) {
*wsrc = ch;
Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
wsrc - wfirstChar + 1);
*wsrc = '\\';
wfirstChar = wsrc + 2;
wsrc++;
continue;
} else {
continue;
}
} else {
continue;
}
if (wfirstChar != wsrc) {
Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
wsrc - wfirstChar);
}
if (idx <= info.nsubs) {
subStart = info.matches[idx].start;
subEnd = info.matches[idx].end;
if ((subStart >= 0) && (subEnd >= 0)) {
Tcl_AppendUnicodeToObj(resultPtr,
wstring + offset + subStart, subEnd - subStart);
}
}
if (*wsrc == '\\') {
wsrc++;
}
wfirstChar = wsrc + 1;
}
if (wfirstChar != wsrc) {
Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
}
if (end == 0) {
/*
* Always consume at least one character of the input string
* in order to prevent infinite loops.
*/
if (offset < wlen) {
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
} else {
offset += end;
if (start == end) {
/*
* We matched an empty string, which means we must go
* forward one more step so we don't match again at the
* same spot.
*/
if (offset < wlen) {
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
}
}
if (!all) {
break;
}
}
/*
* Copy the portion of the source string after the last match to the
* result variable.
*/
regsubDone:
if (numMatches == 0) {
/*
* On zero matches, just ignore the offset, since it shouldn't
* matter to us in this case, and the user may have skewed it.
*/
resultPtr = objv[1];
Tcl_IncrRefCount(resultPtr);
} else if (offset < wlen) {
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
}
if (objc == 4) {
if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
Tcl_GetString(objv[3]), "\"", (char *) NULL);
result = TCL_ERROR;
} else {
/*
* Set the interpreter's object result to an integer object
* holding the number of matches.
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
}
} else {
/*
* No varname supplied, so just return the modified string.
*/
Tcl_SetObjResult(interp, resultPtr);
}
done:
if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); }
if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); }
if (resultPtr) { Tcl_DecrRefCount(resultPtr); }
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RenameObjCmd --
*
* This procedure is invoked to process the "rename" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_RenameObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Arbitrary value passed to the command. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *oldName, *newName;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
return TCL_ERROR;
}
oldName = Tcl_GetString(objv[1]);
newName = Tcl_GetString(objv[2]);
return TclRenameCommand(interp, oldName, newName);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ReturnObjCmd --
*
* This object-based procedure is invoked to process the "return" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ReturnObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
int optionLen, argLen, code, result;
if (iPtr->errorInfo != NULL) {
ckfree(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
if (iPtr->errorCode != NULL) {
ckfree(iPtr->errorCode);
iPtr->errorCode = NULL;
}
code = TCL_OK;
for (objv++, objc--; objc > 1; objv += 2, objc -= 2) {
char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
if (strcmp(option, "-code") == 0) {
register int c = arg[0];
if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
code = TCL_OK;
} else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
code = TCL_ERROR;
} else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
code = TCL_RETURN;
} else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
code = TCL_BREAK;
} else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
code = TCL_CONTINUE;
} else {
result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
&code);
if (result != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad completion code \"",
Tcl_GetString(objv[1]),
"\": must be ok, error, return, break, ",
"continue, or an integer", (char *) NULL);
return result;
}
}
} else if (strcmp(option, "-errorinfo") == 0) {
iPtr->errorInfo =
(char *) ckalloc((unsigned) (strlen(arg) + 1));
strcpy(iPtr->errorInfo, arg);
} else if (strcmp(option, "-errorcode") == 0) {
iPtr->errorCode =
(char *) ckalloc((unsigned) (strlen(arg) + 1));
strcpy(iPtr->errorCode, arg);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", option,
"\": must be -code, -errorcode, or -errorinfo",
(char *) NULL);
return TCL_ERROR;
}
}
if (objc == 1) {
/*
* Set the interpreter's object result. An inline version of
* Tcl_SetObjResult.
*/
Tcl_SetObjResult(interp, objv[0]);
}
iPtr->returnCode = code;
return TCL_RETURN;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SourceObjCmd --
*
* This procedure is invoked to process the "source" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SourceObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
return Tcl_FSEvalFile(interp, objv[1]);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SplitObjCmd --
*
* This procedure is invoked to process the "split" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SplitObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_UniChar ch;
int len;
char *splitChars, *string, *end;
int splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
splitChars = " \n\t\r";
splitCharLen = 4;
} else if (objc == 3) {
splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
return TCL_ERROR;
}
string = Tcl_GetStringFromObj(objv[1], &stringLen);
end = string + stringLen;
listPtr = Tcl_GetObjResult(interp);
if (stringLen == 0) {
/*
* Do nothing.
*/
} else if (splitCharLen == 0) {
Tcl_HashTable charReuseTable;
Tcl_HashEntry *hPtr;
int isNew;
/*
* Handle the special case of splitting on every character.
*
* Uses a hash table to ensure that each kind of character has
* only one Tcl_Obj instance (multiply-referenced) in the
* final list. This is a *major* win when splitting on a long
* string (especially in the megabyte range!) - DKF
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; string < end; string += len) {
len = TclUtfToUniChar(string, &ch);
/* Assume Tcl_UniChar is an integral type... */
hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew);
if (isNew) {
objPtr = Tcl_NewStringObj(string, len);
/* Don't need to fiddle with refcount... */
Tcl_SetHashValue(hPtr, (ClientData) objPtr);
} else {
objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr);
}
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
Tcl_DeleteHashTable(&charReuseTable);
} else if (splitCharLen == 1) {
char *p;
/*
* Handle the special case of splitting on a single character.
* This is only true for the one-char ASCII case, as one unicode
* char is > 1 byte in length.
*/
while (*string && (p = strchr(string, (int) *splitChars)) != NULL) {
objPtr = Tcl_NewStringObj(string, p - string);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
string = p + 1;
}
objPtr = Tcl_NewStringObj(string, end - string);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
} else {
char *element, *p, *splitEnd;
int splitLen;
Tcl_UniChar splitChar;
/*
* Normal case: split on any of a given set of characters.
* Discard instances of the split characters.
*/
splitEnd = splitChars + splitCharLen;
for (element = string; string < end; string += len) {
len = TclUtfToUniChar(string, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
splitLen = TclUtfToUniChar(p, &splitChar);
if (ch == splitChar) {
objPtr = Tcl_NewStringObj(element, string - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
element = string + len;
break;
}
}
}
objPtr = Tcl_NewStringObj(element, string - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_StringObjCmd --
*
* This procedure is invoked to process the "string" Tcl command.
* See the user documentation for details on what it does. Note
* that this command only functions correctly on properly formed
* Tcl UTF strings.
*
* Note that the primary methods here (equal, compare, match, ...)
* have bytecode equivalents. You will find the code for those in
* tclExecute.c. The code here will only be used in the non-bc
* case (like in an 'eval').
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_StringObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int index, left, right;
Tcl_Obj *resultPtr;
char *string1, *string2;
int length1, length2;
static CONST char *options[] = {
"bytelength", "compare", "equal", "first",
"index", "is", "last", "length",
"map", "match", "range", "repeat",
"replace", "tolower", "toupper", "totitle",
"trim", "trimleft", "trimright",
"wordend", "wordstart", (char *) NULL
};
enum options {
STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
STR_WORDEND, STR_WORDSTART
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_GetObjResult(interp);
switch ((enum options) index) {
case STR_EQUAL:
case STR_COMPARE: {
/*
* Remember to keep code here in some sync with the
* byte-compiled versions in tclExecute.c (INST_STR_EQ,
* INST_STR_NEQ and INST_STR_CMP as well as the expr string
* comparison in INST_EQ/INST_NEQ/INST_LT/...).
*/
int i, match, length, nocase = 0, reqlength = -1;
int (*strCmpFn)();
if (objc < 4 || objc > 7) {
str_cmp_args:
Tcl_WrongNumArgs(interp, 2, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 2; i < objc-2; i++) {
string2 = Tcl_GetStringFromObj(objv[i], &length2);
if ((length2 > 1)
&& strncmp(string2, "-nocase", (size_t)length2) == 0) {
nocase = 1;
} else if ((length2 > 1)
&& strncmp(string2, "-length", (size_t)length2) == 0) {
if (i+1 >= objc-2) {
goto str_cmp_args;
}
if (Tcl_GetIntFromObj(interp, objv[++i],
&reqlength) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option \"",
string2, "\": must be -nocase or -length",
(char *) NULL);
return TCL_ERROR;
}
}
/*
* From now on, we only access the two objects at the end
* of the argument array.
*/
objv += objc-2;
if ((reqlength == 0) || (objv[0] == objv[1])) {
/*
* Alway match at 0 chars of if it is the same obj.
*/
Tcl_SetBooleanObj(resultPtr,
((enum options) index == STR_EQUAL));
break;
} else if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
objv[1]->typePtr == &tclByteArrayType) {
/*
* Use binary versions of comparisons since that won't
* cause undue type conversions and it is much faster.
* Only do this if we're case-sensitive (which is all
* that really makes sense with byte arrays anyway, and
* we have no memcasecmp() for some reason... :^)
*/
string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1);
string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2);
strCmpFn = memcmp;
} else if ((objv[0]->typePtr == &tclStringType)
&& (objv[1]->typePtr == &tclStringType)) {
/*
* Do a unicode-specific comparison if both of the args
* are of String type. In benchmark testing this proved
* the most efficient check between the unicode and
* string comparison operations.
*/
string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1);
string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2);
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
} else {
/*
* As a catch-all we will work with UTF-8. We cannot use
* memcmp() as that is unsafe with any string containing
* NULL (\xC0\x80 in Tcl's utf rep). We can use the more
* efficient TclpUtfNcmp2 if we are case-sensitive and no
* specific length was requested.
*/
string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1);
string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2);
if ((reqlength < 0) && !nocase) {
strCmpFn = TclpUtfNcmp2;
} else {
length1 = Tcl_NumUtfChars(string1, length1);
length2 = Tcl_NumUtfChars(string2, length2);
strCmpFn = nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp;
}
}
if (((enum options) index == STR_EQUAL)
&& (reqlength < 0) && (length1 != length2)) {
match = 1; /* this will be reversed below */
} else {
length = (length1 < length2) ? length1 : length2;
if (reqlength > 0 && reqlength < length) {
length = reqlength;
} else if (reqlength < 0) {
/*
* The requested length is negative, so we ignore it by
* setting it to length + 1 so we correct the match var.
*/
reqlength = length + 1;
}
match = strCmpFn(string1, string2, (unsigned) length);
if ((match == 0) && (reqlength > length)) {
match = length1 - length2;
}
}
if ((enum options) index == STR_EQUAL) {
Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1);
} else {
Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 :
(match < 0) ? -1 : 0));
}
break;
}
case STR_FIRST: {
Tcl_UniChar *ustring1, *ustring2;
int match, start;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"subString string ?startIndex?");
return TCL_ERROR;
}
/*
* We are searching string2 for the sequence string1.
*/
match = -1;
start = 0;
length2 = -1;
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
/*
* If a startIndex is specified, we will need to fast
* forward to that point in the string before we think
* about a match
*/
if (TclGetIntForIndex(interp, objv[4], length2 - 1,
&start) != TCL_OK) {
return TCL_ERROR;
}
if (start >= length2) {
goto str_first_done;
} else if (start > 0) {
ustring2 += start;
length2 -= start;
} else if (start < 0) {
/*
* Invalid start index mapped to string start;
* Bug #423581
*/
start = 0;
}
}
if (length1 > 0) {
register Tcl_UniChar *p, *end;
end = ustring2 + length2 - length1 + 1;
for (p = ustring2; p < end; p++) {
/*
* Scan forward to find the first character.
*/
if ((*p == *ustring1) &&
(TclUniCharNcmp(ustring1, p,
(unsigned long) length1) == 0)) {
match = p - ustring2;
break;
}
}
}
/*
* Compute the character index of the matching string by
* counting the number of characters before the match.
*/
if ((match != -1) && (objc == 5)) {
match += start;
}
str_first_done:
Tcl_SetIntObj(resultPtr, match);
break;
}
case STR_INDEX: {
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
return TCL_ERROR;
}
/*
* If we have a ByteArray object, avoid indexing in the
* Utf string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* get the index'th char.
*/
if (objv[2]->typePtr == &tclByteArrayType) {
string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);
if (TclGetIntForIndex(interp, objv[3], length1 - 1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if ((index >= 0) && (index < length1)) {
Tcl_SetByteArrayObj(resultPtr,
(unsigned char *)(&string1[index]), 1);
}
} else {
/*
* Get Unicode char length to calulate what 'end' means.
*/
length1 = Tcl_GetCharLength(objv[2]);
if (TclGetIntForIndex(interp, objv[3], length1 - 1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if ((index >= 0) && (index < length1)) {
char buf[TCL_UTF_MAX];
Tcl_UniChar ch;
ch = Tcl_GetUniChar(objv[2], index);
length1 = Tcl_UniCharToUtf(ch, buf);
Tcl_SetStringObj(resultPtr, buf, length1);
}
}
break;
}
case STR_IS: {
char *end;
Tcl_UniChar ch;
/*
* The UniChar comparison function
*/
int (*chcomp)_ANSI_ARGS_((int)) = NULL;
int i, failat = 0, result = 1, strict = 0;
Tcl_Obj *objPtr, *failVarObj = NULL;
static CONST char *isOptions[] = {
"alnum", "alpha", "ascii", "control",
"boolean", "digit", "double", "false",
"graph", "integer", "lower", "print",
"punct", "space", "true", "upper",
"wordchar", "xdigit", (char *) NULL
};
enum isOptions {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE,
STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT,
STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER,
STR_IS_WORD, STR_IS_XDIGIT
};
if (objc < 4 || objc > 7) {
Tcl_WrongNumArgs(interp, 2, objv,
"class ?-strict? ?-failindex var? str");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (objc != 4) {
for (i = 3; i < objc-1; i++) {
string2 = Tcl_GetStringFromObj(objv[i], &length2);
if ((length2 > 1) &&
strncmp(string2, "-strict", (size_t) length2) == 0) {
strict = 1;
} else if ((length2 > 1) &&
strncmp(string2, "-failindex",
(size_t) length2) == 0) {
if (i+1 >= objc-1) {
Tcl_WrongNumArgs(interp, 3, objv,
"?-strict? ?-failindex var? str");
return TCL_ERROR;
}
failVarObj = objv[++i];
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option \"",
string2, "\": must be -strict or -failindex",
(char *) NULL);
return TCL_ERROR;
}
}
}
/*
* We get the objPtr so that we can short-cut for some classes
* by checking the object type (int and double), but we need
* the string otherwise, because we don't want any conversion
* of type occuring (as, for example, Tcl_Get*FromObj would do
*/
objPtr = objv[objc-1];
string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
/*
* When entering here, result == 1 and failat == 0
*/
switch ((enum isOptions) index) {
case STR_IS_ALNUM:
chcomp = Tcl_UniCharIsAlnum;
break;
case STR_IS_ALPHA:
chcomp = Tcl_UniCharIsAlpha;
break;
case STR_IS_ASCII:
for (; string1 < end; string1++, failat++) {
/*
* This is a valid check in unicode, because all
* bytes < 0xC0 are single byte chars (but isascii
* limits that def'n to 0x80).
*/
if (*((unsigned char *)string1) >= 0x80) {
result = 0;
break;
}
}
break;
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
/* Optimizers, beware Bug 1187123 ! */
if ((Tcl_GetBoolean(NULL, string1, &i)
== TCL_ERROR) ||
(((enum isOptions) index == STR_IS_TRUE) &&
i == 0) ||
(((enum isOptions) index == STR_IS_FALSE) &&
i != 0)) {
result = 0;
}
break;
case STR_IS_CONTROL:
chcomp = Tcl_UniCharIsControl;
break;
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
char *stop;
if ((objPtr->typePtr == &tclDoubleType) ||
(objPtr->typePtr == &tclIntType)) {
break;
}
/*
* This is adapted from Tcl_GetDouble
*
* The danger in this function is that
* "12345678901234567890" is an acceptable 'double',
* but will later be interp'd as an int by something
* like [expr]. Therefore, we check to see if it looks
* like an int, and if so we do a range check on it.
* If strtoul gets to the end, we know we either
* received an acceptable int, or over/underflow
*/
if (TclLooksLikeInt(string1, length1)) {
errno = 0;
#ifdef TCL_WIDE_INT_IS_LONG
strtoul(string1, &stop, 0); /* INTL: Tcl source. */
#else
strtoull(string1, &stop, 0); /* INTL: Tcl source. */
#endif
if (stop == end) {
if (errno == ERANGE) {
result = 0;
failat = -1;
}
break;
}
}
errno = 0;
strtod(string1, &stop); /* INTL: Tcl source. */
if (errno == ERANGE) {
/*
* if (errno == ERANGE), then it was an over/underflow
* problem, but in this method, we only want to know
* yes or no, so bad flow returns 0 (false) and sets
* the failVarObj to the string length.
*/
result = 0;
failat = -1;
} else if (stop == string1) {
/*
* In this case, nothing like a number was found
*/
result = 0;
failat = 0;
} else {
/*
* Assume we sucked up one char per byte
* and then we go onto SPACE, since we are
* allowed trailing whitespace
*/
failat = stop - string1;
string1 = stop;
chcomp = Tcl_UniCharIsSpace;
}
break;
}
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT: {
char *stop;
long int l = 0;
if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) {
break;
}
/*
* Like STR_IS_DOUBLE, but we use strtoul.
* Since Tcl_GetIntFromObj already failed,
* we set result to 0.
*/
result = 0;
errno = 0;
l = strtol(string1, &stop, 0); /* INTL: Tcl source. */
if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) {
/*
* if (errno == ERANGE), then it was an over/underflow
* problem, but in this method, we only want to know
* yes or no, so bad flow returns 0 (false) and sets
* the failVarObj to the string length.
*/
failat = -1;
} else if (stop == string1) {
/*
* In this case, nothing like a number was found
*/
failat = 0;
} else {
/*
* Assume we sucked up one char per byte
* and then we go onto SPACE, since we are
* allowed trailing whitespace
*/
failat = stop - string1;
string1 = stop;
chcomp = Tcl_UniCharIsSpace;
}
break;
}
case STR_IS_LOWER:
chcomp = Tcl_UniCharIsLower;
break;
case STR_IS_PRINT:
chcomp = Tcl_UniCharIsPrint;
break;
case STR_IS_PUNCT:
chcomp = Tcl_UniCharIsPunct;
break;
case STR_IS_SPACE:
chcomp = Tcl_UniCharIsSpace;
break;
case STR_IS_UPPER:
chcomp = Tcl_UniCharIsUpper;
break;
case STR_IS_WORD:
chcomp = Tcl_UniCharIsWordChar;
break;
case STR_IS_XDIGIT: {
for (; string1 < end; string1++, failat++) {
/* INTL: We assume unicode is bad for this class */
if ((*((unsigned char *)string1) >= 0xC0) ||
!isxdigit(*(unsigned char *)string1)) {
result = 0;
break;
}
}
break;
}
}
if (chcomp != NULL) {
for (; string1 < end; string1 += length2, failat++) {
length2 = TclUtfToUniChar(string1, &ch);
if (!chcomp(ch)) {
result = 0;
break;
}
}
}
str_is_done:
/*
* Only set the failVarObj when we will return 0
* and we have indicated a valid fail index (>= 0)
*/
if ((result == 0) && (failVarObj != NULL)) {
Tcl_Obj *resPtr, *tmpPtr = Tcl_NewIntObj(failat);
Tcl_IncrRefCount(tmpPtr);
resPtr = Tcl_ObjSetVar2(interp, failVarObj, NULL, tmpPtr,
TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(tmpPtr);
if (resPtr == NULL) {
return TCL_ERROR;
}
}
Tcl_SetBooleanObj(resultPtr, result);
break;
}
case STR_LAST: {
Tcl_UniChar *ustring1, *ustring2, *p;
int match, start;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"subString string ?startIndex?");
return TCL_ERROR;
}
/*
* We are searching string2 for the sequence string1.
*/
match = -1;
start = 0;
length2 = -1;
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
/*
* If a startIndex is specified, we will need to restrict
* the string range to that char index in the string
*/
if (TclGetIntForIndex(interp, objv[4], length2 - 1,
&start) != TCL_OK) {
return TCL_ERROR;
}
if (start < 0) {
goto str_last_done;
} else if (start < length2) {
p = ustring2 + start + 1 - length1;
} else {
p = ustring2 + length2 - length1;
}
} else {
p = ustring2 + length2 - length1;
}
if (length1 > 0) {
for (; p >= ustring2; p--) {
/*
* Scan backwards to find the first character.
*/
if ((*p == *ustring1) &&
(memcmp((char *) ustring1, (char *) p, (size_t)
(length1 * sizeof(Tcl_UniChar))) == 0)) {
match = p - ustring2;
break;
}
}
}
str_last_done:
Tcl_SetIntObj(resultPtr, match);
break;
}
case STR_BYTELENGTH:
case STR_LENGTH: {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
}
if ((enum options) index == STR_BYTELENGTH) {
(void) Tcl_GetStringFromObj(objv[2], &length1);
} else {
/*
* If we have a ByteArray object, avoid recomputing the
* string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* calculate the length.
*/
if (objv[2]->typePtr == &tclByteArrayType) {
(void) Tcl_GetByteArrayFromObj(objv[2], &length1);
} else {
length1 = Tcl_GetCharLength(objv[2]);
}
}
Tcl_SetIntObj(resultPtr, length1);
break;
}
case STR_MAP: {
int mapElemc, nocase = 0, copySource = 0;
Tcl_Obj **mapElemv, *sourceObj;
Tcl_UniChar *ustring1, *ustring2, *p, *end;
int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*,
CONST Tcl_UniChar*, unsigned long));
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
return TCL_ERROR;
}
if (objc == 5) {
string2 = Tcl_GetStringFromObj(objv[2], &length2);
if ((length2 > 1) &&
strncmp(string2, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option \"",
string2, "\": must be -nocase",
(char *) NULL);
return TCL_ERROR;
}
}
if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc,
&mapElemv) != TCL_OK) {
return TCL_ERROR;
}
if (mapElemc == 0) {
/*
* empty charMap, just return whatever string was given
*/
Tcl_SetObjResult(interp, objv[objc-1]);
return TCL_OK;
} else if (mapElemc & 1) {
/*
* The charMap must be an even number of key/value items
*/
Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
return TCL_ERROR;
}
/*
* Take a copy of the source string object if it is the
* same as the map string to cut out nasty sharing
* crashes. [Bug 1018562]
*/
if (objv[objc-2] == objv[objc-1]) {
sourceObj = Tcl_DuplicateObj(objv[objc-1]);
copySource = 1;
} else {
sourceObj = objv[objc-1];
}
ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
if (length1 == 0) {
/*
* Empty input string, just stop now
*/
if (copySource) {
Tcl_DecrRefCount(sourceObj);
}
break;
}
end = ustring1 + length1;
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
/*
* Force result to be Unicode
*/
Tcl_SetUnicodeObj(resultPtr, ustring1, 0);
if (mapElemc == 2) {
/*
* Special case for one map pair which avoids the extra
* for loop and extra calls to get Unicode data. The
* algorithm is otherwise identical to the multi-pair case.
* This will be >30% faster on larger strings.
*/
int mapLen;
Tcl_UniChar *mapString, u2lc;
ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
p = ustring1;
if ((length2 > length1) || (length2 == 0)) {
/* match string is either longer than input or empty */
ustring1 = end;
} else {
mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
for (; ustring1 < end; ustring1++) {
if (((*ustring1 == *ustring2) ||
(nocase && (Tcl_UniCharToLower(*ustring1) ==
u2lc))) &&
((length2 == 1) || strCmpFn(ustring1, ustring2,
(unsigned long) length2) == 0)) {
if (p != ustring1) {
Tcl_AppendUnicodeToObj(resultPtr, p,
ustring1 - p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
Tcl_AppendUnicodeToObj(resultPtr, mapString,
mapLen);
}
}
}
} else {
Tcl_UniChar **mapStrings, *u2lc = NULL;
int *mapLens;
/*
* Precompute pointers to the unicode string and length.
* This saves us repeated function calls later,
* significantly speeding up the algorithm. We only need
* the lowercase first char in the nocase case.
*/
mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2)
* sizeof(Tcl_UniChar *));
mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int));
if (nocase) {
u2lc = (Tcl_UniChar *)
ckalloc((mapElemc) * sizeof(Tcl_UniChar));
}
for (index = 0; index < mapElemc; index++) {
mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
&(mapLens[index]));
if (nocase && ((index % 2) == 0)) {
u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
}
}
for (p = ustring1; ustring1 < end; ustring1++) {
for (index = 0; index < mapElemc; index += 2) {
/*
* Get the key string to match on.
*/
ustring2 = mapStrings[index];
length2 = mapLens[index];
if ((length2 > 0) && ((*ustring1 == *ustring2) ||
(nocase && (Tcl_UniCharToLower(*ustring1) ==
u2lc[index/2]))) &&
/* restrict max compare length */
((end - ustring1) >= length2) &&
((length2 == 1) || strCmpFn(ustring2, ustring1,
(unsigned long) length2) == 0)) {
if (p != ustring1) {
/*
* Put the skipped chars onto the result first
*/
Tcl_AppendUnicodeToObj(resultPtr, p,
ustring1 - p);
p = ustring1 + length2;
} else {
p += length2;
}
/*
* Adjust len to be full length of matched string
*/
ustring1 = p - 1;
/*
* Append the map value to the unicode string
*/
Tcl_AppendUnicodeToObj(resultPtr,
mapStrings[index+1], mapLens[index+1]);
break;
}
}
}
ckfree((char *) mapStrings);
ckfree((char *) mapLens);
if (nocase) {
ckfree((char *) u2lc);
}
}
if (p != ustring1) {
/*
* Put the rest of the unmapped chars onto result
*/
Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
}
if (copySource) {
Tcl_DecrRefCount(sourceObj);
}
break;
}
case STR_MATCH: {
Tcl_UniChar *ustring1, *ustring2;
int nocase = 0;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
return TCL_ERROR;
}
if (objc == 5) {
string2 = Tcl_GetStringFromObj(objv[2], &length2);
if ((length2 > 1) &&
strncmp(string2, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option \"",
string2, "\": must be -nocase",
(char *) NULL);
return TCL_ERROR;
}
}
ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2);
Tcl_SetBooleanObj(resultPtr, TclUniCharMatch(ustring1, length1,
ustring2, length2, nocase));
break;
}
case STR_RANGE: {
int first, last;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "string first last");
return TCL_ERROR;
}
/*
* If we have a ByteArray object, avoid indexing in the
* Utf string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* get the range.
*/
if (objv[2]->typePtr == &tclByteArrayType) {
string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
length1--;
} else {
/*
* Get the length in actual characters.
*/
string1 = NULL;
length1 = Tcl_GetCharLength(objv[2]) - 1;
}
if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
|| (TclGetIntForIndex(interp, objv[4], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
if (last >= length1) {
last = length1;
}
if (last >= first) {
if (string1 != NULL) {
int numBytes = last - first + 1;
resultPtr = Tcl_NewByteArrayObj(
(unsigned char *) &string1[first], numBytes);
Tcl_SetObjResult(interp, resultPtr);
} else {
Tcl_SetObjResult(interp,
Tcl_GetRange(objv[2], first, last));
}
}
break;
}
case STR_REPEAT: {
int count;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string count");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
return TCL_ERROR;
}
if (count == 1) {
Tcl_SetObjResult(interp, objv[2]);
} else if (count > 1) {
string1 = Tcl_GetStringFromObj(objv[2], &length1);
if (length1 > 0) {
/*
* Only build up a string that has data. Instead of
* building it up with repeated appends, we just allocate
* the necessary space once and copy the string value in.
* Check for overflow with back-division. [Bug #714106]
*/
length2 = length1 * count;
if ((length2 / count) != length1) {
char buf[TCL_INTEGER_SPACE+1];
sprintf(buf, "%d", INT_MAX);
Tcl_AppendStringsToObj(resultPtr,
"string size overflow, must be less than ",
buf, (char *) NULL);
return TCL_ERROR;
}
/*
* Include space for the NULL
*/
string2 = (char *) ckalloc((size_t) length2+1);
for (index = 0; index < count; index++) {
memcpy(string2 + (length1 * index), string1,
(size_t) length1);
}
string2[length2] = '\0';
/*
* We have to directly assign this instead of using
* Tcl_SetStringObj (and indirectly TclInitStringRep)
* because that makes another copy of the data.
*/
resultPtr = Tcl_NewObj();
resultPtr->bytes = string2;
resultPtr->length = length2;
Tcl_SetObjResult(interp, resultPtr);
}
}
break;
}
case STR_REPLACE: {
Tcl_UniChar *ustring1;
int first, last;
if (objc < 5 || objc > 6) {
Tcl_WrongNumArgs(interp, 2, objv,
"string first last ?string?");
return TCL_ERROR;
}
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
length1--;
if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
|| (TclGetIntForIndex(interp, objv[4], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if ((last < first) || (last < 0) || (first > length1)) {
Tcl_SetObjResult(interp, objv[2]);
} else {
if (first < 0) {
first = 0;
}
Tcl_SetUnicodeObj(resultPtr, ustring1, first);
if (objc == 6) {
Tcl_AppendObjToObj(resultPtr, objv[5]);
}
if (last < length1) {
Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1,
length1 - last);
}
}
break;
}
case STR_TOLOWER:
case STR_TOUPPER:
case STR_TOTITLE:
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
if (objc == 3) {
/*
* Since the result object is not a shared object, it is
* safe to copy the string into the result and do the
* conversion in place. The conversion may change the length
* of the string, so reset the length after conversion.
*/
Tcl_SetStringObj(resultPtr, string1, length1);
if ((enum options) index == STR_TOLOWER) {
length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr));
} else if ((enum options) index == STR_TOUPPER) {
length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr));
} else {
length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr));
}
Tcl_SetObjLength(resultPtr, length1);
} else {
int first, last;
CONST char *start, *end;
length1 = Tcl_NumUtfChars(string1, length1) - 1;
if (TclGetIntForIndex(interp, objv[3], length1,
&first) != TCL_OK) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
last = first;
if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last >= length1) {
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[2]);
break;
}
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
length2 = end-start;
string2 = ckalloc((size_t) length2+1);
memcpy(string2, start, (size_t) length2);
string2[length2] = '\0';
if ((enum options) index == STR_TOLOWER) {
length2 = Tcl_UtfToLower(string2);
} else if ((enum options) index == STR_TOUPPER) {
length2 = Tcl_UtfToUpper(string2);
} else {
length2 = Tcl_UtfToTitle(string2);
}
Tcl_SetStringObj(resultPtr, string1, start - string1);
Tcl_AppendToObj(resultPtr, string2, length2);
Tcl_AppendToObj(resultPtr, end, -1);
ckfree(string2);
}
break;
case STR_TRIM: {
Tcl_UniChar ch, trim;
register CONST char *p, *end;
char *check, *checkEnd;
int offset;
left = 1;
right = 1;
dotrim:
if (objc == 4) {
string2 = Tcl_GetStringFromObj(objv[3], &length2);
} else if (objc == 3) {
string2 = " \t\n\r";
length2 = strlen(string2);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
checkEnd = string2 + length2;
if (left) {
end = string1 + length1;
/*
* The outer loop iterates over the string. The inner
* loop iterates over the trim characters. The loops
* terminate as soon as a non-trim character is discovered
* and string1 is left pointing at the first non-trim
* character.
*/
for (p = string1; p < end; p += offset) {
offset = TclUtfToUniChar(p, &ch);
for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
check += TclUtfToUniChar(check, &trim);
if (ch == trim) {
length1 -= offset;
string1 += offset;
break;
}
}
}
}
if (right) {
end = string1;
/*
* The outer loop iterates over the string. The inner
* loop iterates over the trim characters. The loops
* terminate as soon as a non-trim character is discovered
* and length1 marks the last non-trim character.
*/
for (p = string1 + length1; p > end; ) {
p = Tcl_UtfPrev(p, string1);
offset = TclUtfToUniChar(p, &ch);
for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
check += TclUtfToUniChar(check, &trim);
if (ch == trim) {
length1 -= offset;
break;
}
}
}
}
Tcl_SetStringObj(resultPtr, string1, length1);
break;
}
case STR_TRIMLEFT: {
left = 1;
right = 0;
goto dotrim;
}
case STR_TRIMRIGHT: {
left = 0;
right = 1;
goto dotrim;
}
case STR_WORDEND: {
int cur;
Tcl_UniChar ch;
CONST char *p, *end;
int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
numChars = Tcl_NumUtfChars(string1, length1);
if (TclGetIntForIndex(interp, objv[3], numChars-1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index < 0) {
index = 0;
}
if (index < numChars) {
p = Tcl_UtfAtIndex(string1, index);
end = string1+length1;
for (cur = index; p < end; cur++) {
p += TclUtfToUniChar(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
}
if (cur == index) {
cur++;
}
} else {
cur = numChars;
}
Tcl_SetIntObj(resultPtr, cur);
break;
}
case STR_WORDSTART: {
int cur;
Tcl_UniChar ch;
CONST char *p;
int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
numChars = Tcl_NumUtfChars(string1, length1);
if (TclGetIntForIndex(interp, objv[3], numChars-1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index >= numChars) {
index = numChars - 1;
}
cur = 0;
if (index > 0) {
p = Tcl_UtfAtIndex(string1, index);
for (cur = index; cur >= 0; cur--) {
TclUtfToUniChar(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
p = Tcl_UtfPrev(p, string1);
}
if (cur != index) {
cur += 1;
}
}
Tcl_SetIntObj(resultPtr, cur);
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SubstObjCmd --
*
* This procedure is invoked to process the "subst" Tcl command.
* See the user documentation for details on what it does. This
* command relies on Tcl_SubstObj() for its implementation.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SubstObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *substOptions[] = {
"-nobackslashes", "-nocommands", "-novariables", (char *) NULL
};
enum substOptions {
SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
};
Tcl_Obj *resultPtr;
int optionIndex, flags, i;
/*
* Parse command-line options.
*/
flags = TCL_SUBST_ALL;
for (i = 1; i < (objc-1); i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
"switch", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch (optionIndex) {
case SUBST_NOBACKSLASHES: {
flags &= ~TCL_SUBST_BACKSLASHES;
break;
}
case SUBST_NOCOMMANDS: {
flags &= ~TCL_SUBST_COMMANDS;
break;
}
case SUBST_NOVARS: {
flags &= ~TCL_SUBST_VARIABLES;
break;
}
default: {
panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
}
}
}
if (i != (objc-1)) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-nobackslashes? ?-nocommands? ?-novariables? string");
return TCL_ERROR;
}
/*
* Perform the substitution.
*/
resultPtr = Tcl_SubstObj(interp, objv[i], flags);
if (resultPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SubstObj --
*
* This function performs the substitutions specified on the
* given string as described in the user documentation for the
* "subst" Tcl command. This code is heavily based on an
* implementation by Andrew Payne. Note that if a command
* substitution returns TCL_CONTINUE or TCL_RETURN from its
* evaluation and is not completely well-formed, the results are
* not defined (or at least hard to characterise.) This fault
* will be fixed at some point, but the cost of the only sane
* fix (well-formedness check first) is such that you need to
* "precompile and cache" to stop everyone from being hit with
* the consequences every time through. Note that the current
* behaviour is not a security hole; it just restarts parsing
* the string following the substitution in a mildly surprising
* place, and it is a very bad idea to count on this remaining
* the same in future...
*
* Results:
* A Tcl_Obj* containing the substituted string, or NULL to
* indicate that an error occurred.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_SubstObj(interp, objPtr, flags)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
int flags;
{
Tcl_Obj *resultObj;
char *p, *old;
int length;
old = p = Tcl_GetStringFromObj(objPtr, &length);
resultObj = Tcl_NewStringObj("", 0);
while (length) {
switch (*p) {
case '\\':
if (flags & TCL_SUBST_BACKSLASHES) {
char buf[TCL_UTF_MAX];
int count;
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
Tcl_AppendToObj(resultObj, buf,
TclParseBackslash(p, length, &count, buf));
p += count; length -= count;
old = p;
} else {
p++; length--;
}
break;
case '$':
if (flags & TCL_SUBST_VARIABLES) {
Tcl_Parse parse;
int code;
/*
* Code is simpler overall if we (effectively) inline
* Tcl_ParseVar, particularly as that allows us to use
* a non-string interface when we come to appending
* the variable contents to the result object. There
* are a few other optimisations that doing this
* enables (like being able to continue the run of
* unsubstituted characters straight through if a '$'
* does not precede a variable name.)
*/
if (Tcl_ParseVarName(interp, p, length, &parse, 0) != TCL_OK) {
goto errorResult;
}
if (parse.numTokens == 1) {
/*
* There isn't a variable name after all: the $ is
* just a $.
*/
p++; length--;
break;
}
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
p += parse.tokenPtr->size;
length -= parse.tokenPtr->size;
code = Tcl_EvalTokensStandard(interp, parse.tokenPtr,
parse.numTokens);
if (code == TCL_ERROR) {
goto errorResult;
}
if (code == TCL_BREAK) {
Tcl_ResetResult(interp);
return resultObj;
}
if (code != TCL_CONTINUE) {
Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
}
Tcl_ResetResult(interp);
old = p;
} else {
p++; length--;
}
break;
case '[':
if (flags & TCL_SUBST_COMMANDS) {
Interp *iPtr = (Interp *) interp;
int code;
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
iPtr->evalFlags = TCL_BRACKET_TERM;
iPtr->numLevels++;
code = TclInterpReady(interp);
if (code == TCL_OK) {
code = Tcl_EvalEx(interp, p+1, length-1, 0);
}
iPtr->numLevels--;
switch (code) {
case TCL_ERROR:
goto errorResult;
case TCL_BREAK:
Tcl_ResetResult(interp);
return resultObj;
default:
Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
case TCL_CONTINUE:
Tcl_ResetResult(interp);
old = p = (p+1 + iPtr->termOffset + 1);
length -= (iPtr->termOffset + 2);
}
} else {
p++; length--;
}
break;
default:
p++; length--;
break;
}
}
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
return resultObj;
errorResult:
Tcl_DecrRefCount(resultObj);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SwitchObjCmd --
*
* This object-based procedure is invoked to process the "switch" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, j, index, mode, matched, result, splitObjs;
char *string, *pattern;
Tcl_Obj *stringObj;
Tcl_Obj *CONST *savedObjv = objv;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
int pc = 0;
int bidx = 0; /* Index of body argument */
Tcl_Obj* blist = NULL; /* List obj which is the body */
CmdFrame ctx; /* Copy of the topmost cmdframe,
* to allow us to mess with the
* line information */
#endif
static CONST char *options[] = {
"-exact", "-glob", "-regexp", "--",
NULL
};
enum options {
OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST
};
mode = OPT_EXACT;
for (i = 1; i < objc; i++) {
string = Tcl_GetString(objv[i]);
if (string[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index == OPT_LAST) {
i++;
break;
}
mode = index;
}
if (objc - i < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? string pattern body ... ?default body?");
return TCL_ERROR;
}
stringObj = objv[i];
objc -= i + 1;
objv += i + 1;
#ifdef TCL_TIP280
bidx = i+1; /* First after the match string */
#endif
/*
* If all of the pattern/command pairs are lumped into a single
* argument, split them out again.
*
* TIP #280: Determine the lines the words in the list start at, based on
* the same data for the list word itself. The cmdFramePtr line information
* is manipulated directly.
*/
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
#ifdef TCL_TIP280
blist = objv[0];
#endif
if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Ensure that the list is non-empty.
*/
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, savedObjv,
"?switches? string {pattern body ... ?default body?}");
return TCL_ERROR;
}
objv = listv;
splitObjs = 1;
}
/*
* Complain if there is an odd number of words in the list of
* patterns and bodies.
*/
if (objc % 2) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
/*
* Check if this can be due to a badly placed comment
* in the switch block.
*
* The following is an heuristic to detect the infamous
* "comment in switch" error: just check if a pattern
* begins with '#'.
*/
if (splitObjs) {
for (i=0 ; icmdFramePtr;
if (splitObjs) {
/* We have to perform the GetSrc and other type dependent handling
* of the frame here because we are munging with the line numbers,
* something the other commands like if, etc. are not doing. Them
* are fine with simply passing the CmdFrame through and having
* the special handling done in 'info frame', or the bc compiler
*/
if (ctx.type == TCL_LOCATION_BC) {
/* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc (&ctx);
pc = 1;
/* The line information in the cmdFrame is now a copy we do
* not own */
}
if (ctx.type == TCL_LOCATION_SOURCE) {
int bline = ctx.line [bidx];
if (bline >= 0) {
ctx.line = (int*) ckalloc (objc * sizeof(int));
ctx.nline = objc;
ListLines (blist, bline, objc, ctx.line, objv);
} else {
int k;
/* Dynamic code word ... All elements are relative to themselves */
ctx.line = (int*) ckalloc (objc * sizeof(int));
ctx.nline = objc;
for (k=0; k < objc; k++) {ctx.line[k] = -1;}
}
} else {
int k;
/* Anything else ... No information, or dynamic ... */
ctx.line = (int*) ckalloc (objc * sizeof(int));
ctx.nline = objc;
for (k=0; k < objc; k++) {ctx.line[k] = -1;}
}
}
#endif
for (j = i + 1; ; j += 2) {
if (j >= objc) {
/*
* This shouldn't happen since we've checked that the
* last body is not a continuation...
*/
panic("fall-out when searching for body to match pattern");
}
if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
break;
}
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[j], 0);
#else
/* TIP #280. Make invoking context available to switch branch */
result = TclEvalObjEx(interp, objv[j], 0, &ctx, splitObjs ? j : bidx+j);
if (splitObjs) {
ckfree ((char*) ctx.line);
if (pc && (ctx.type == TCL_LOCATION_SOURCE)) {
/* Death of SrcInfo reference */
Tcl_DecrRefCount (ctx.data.eval.path);
}
}
#endif
if (result == TCL_ERROR) {
char msg[100 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
return result;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TimeObjCmd --
*
* This object-based procedure is invoked to process the "time" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_TimeObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Tcl_Obj *objPtr;
Tcl_Obj *objs[4];
register int i, result;
int count;
double totalMicroSec;
Tcl_Time start, stop;
if (objc == 2) {
count = 1;
} else if (objc == 3) {
result = Tcl_GetIntFromObj(interp, objv[2], &count);
if (result != TCL_OK) {
return result;
}
} else {
Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
return TCL_ERROR;
}
objPtr = objv[1];
i = count;
Tcl_GetTime(&start);
while (i-- > 0) {
result = Tcl_EvalObjEx(interp, objPtr, 0);
if (result != TCL_OK) {
return result;
}
}
Tcl_GetTime(&stop);
totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6
+ ( stop.usec - start.usec ) );
if (count <= 1) {
/* Use int obj since we know time is not fractional [Bug 1202178] */
objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec);
} else {
objs[0] = Tcl_NewDoubleObj(totalMicroSec/count);
}
objs[1] = Tcl_NewStringObj("microseconds", -1);
objs[2] = Tcl_NewStringObj("per", -1);
objs[3] = Tcl_NewStringObj("iteration", -1);
Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TraceObjCmd --
*
* This procedure is invoked to process the "trace" Tcl command.
* See the user documentation for details on what it does.
*
* Standard syntax as of Tcl 8.4 is
*
* trace {add|info|remove} {command|variable} name ops cmd
*
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_TraceObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int optionIndex;
char *name, *flagOps, *p;
/* Main sub commands to 'trace' */
static CONST char *traceOptions[] = {
"add", "info", "remove",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
"variable", "vdelete", "vinfo",
#endif
(char *) NULL
};
/* 'OLD' options are pre-Tcl-8.4 style */
enum traceOptions {
TRACE_ADD, TRACE_INFO, TRACE_REMOVE,
#ifndef TCL_REMOVE_OBSOLETE_TRACES
TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
#endif
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
"option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE:
case TRACE_INFO: {
/*
* All sub commands of trace add/remove must take at least
* one more argument. Beyond that we let the subcommand itself
* control the argument structure.
*/
int typeIndex;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions,
"option", 0, &typeIndex) != TCL_OK) {
return TCL_ERROR;
}
return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
case TRACE_OLD_VARIABLE:
case TRACE_OLD_VDELETE: {
Tcl_Obj *copyObjv[6];
Tcl_Obj *opsList;
int code, numFlags;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
return TCL_ERROR;
}
opsList = Tcl_NewObj();
Tcl_IncrRefCount(opsList);
flagOps = Tcl_GetStringFromObj(objv[3], &numFlags);
if (numFlags == 0) {
Tcl_DecrRefCount(opsList);
goto badVarOps;
}
for (p = flagOps; *p != 0; p++) {
if (*p == 'r') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("read", -1));
} else if (*p == 'w') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("write", -1));
} else if (*p == 'u') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("unset", -1));
} else if (*p == 'a') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("array", -1));
} else {
Tcl_DecrRefCount(opsList);
goto badVarOps;
}
}
copyObjv[0] = NULL;
memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *));
copyObjv[4] = opsList;
if (optionIndex == TRACE_OLD_VARIABLE) {
code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv);
} else {
code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv);
}
Tcl_DecrRefCount(opsList);
return code;
}
case TRACE_OLD_VINFO: {
ClientData clientData;
char ops[5];
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
clientData = 0;
name = Tcl_GetString(objv[2]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
p = ops;
if (tvarPtr->flags & TCL_TRACE_READS) {
*p = 'r';
p++;
}
if (tvarPtr->flags & TCL_TRACE_WRITES) {
*p = 'w';
p++;
}
if (tvarPtr->flags & TCL_TRACE_UNSETS) {
*p = 'u';
p++;
}
if (tvarPtr->flags & TCL_TRACE_ARRAY) {
*p = 'a';
p++;
}
*p = '\0';
/*
* Build a pair (2-item list) with the ops string as
* the first obj element and the tvarPtr->command string
* as the second obj element. Append the pair (as an
* element) to the end of the result object list.
*/
elemObjPtr = Tcl_NewStringObj(ops, -1);
Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
#endif /* TCL_REMOVE_OBSOLETE_TRACES */
}
return TCL_OK;
badVarOps:
Tcl_AppendResult(interp, "bad operations \"", flagOps,
"\": should be one or more of rwua", (char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclTraceExecutionObjCmd --
*
* Helper function for Tcl_TraceObjCmd; implements the
* [trace {add|remove|info} execution ...] subcommands.
* See the user documentation for details on what these do.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Depends on the operation (add, remove, or info) being performed;
* may add or remove command traces on a command.
*
*----------------------------------------------------------------------
*/
int
TclTraceExecutionObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp; /* Current interpreter. */
int optionIndex; /* Add, info or remove */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "enter", "leave",
"enterstep", "leavestep", (char *) NULL };
enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0;
int i, listLen, result;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
return TCL_ERROR;
}
/*
* Make sure the ops argument is a list object; get its length and
* a pointer to its array of element pointers.
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of enter, leave, enterstep, or leavestep",
TCL_STATIC);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum operations) index) {
case TRACE_EXEC_ENTER:
flags |= TCL_TRACE_ENTER_EXEC;
break;
case TRACE_EXEC_LEAVE:
flags |= TCL_TRACE_LEAVE_EXEC;
break;
case TRACE_EXEC_ENTER_STEP:
flags |= TCL_TRACE_ENTER_DURING_EXEC;
break;
case TRACE_EXEC_LEAVE_STEP:
flags |= TCL_TRACE_LEAVE_DURING_EXEC;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr;
tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
+ length + 1));
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
tcmdPtr->refCount = 1;
flags |= TCL_TRACE_DELETE;
if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC)) {
flags |= (TCL_TRACE_ENTER_EXEC |
TCL_TRACE_LEAVE_EXEC);
}
memcpy(tcmdPtr->command, command, length + 1);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
(ClientData) tcmdPtr) != TCL_OK) {
ckfree((char *) tcmdPtr);
return TCL_ERROR;
}
} else {
/*
* Search through all of our traces on this command to
* see if there's one with the given command. If so, then
* delete the first one that matches.
*/
TraceCommandInfo *tcmdPtr;
ClientData clientData = NULL;
name = Tcl_GetString(objv[3]);
/* First ensure the name given is valid */
if (Tcl_FindCommand(interp, name, NULL,
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
tcmdPtr = (TraceCommandInfo *) clientData;
/*
* In checking the 'flags' field we must remove any
* extraneous flags which may have been temporarily
* added by various pieces of the trace mechanism.
*/
if ((tcmdPtr->length == length)
&& ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC |
TCL_TRACE_RENAME |
TCL_TRACE_DELETE)) == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
flags |= TCL_TRACE_DELETE;
if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC)) {
flags |= (TCL_TRACE_ENTER_EXEC |
TCL_TRACE_LEAVE_EXEC);
}
Tcl_UntraceCommand(interp, name,
flags, TraceCommandProc, clientData);
if (tcmdPtr->stepTrace != NULL) {
/*
* We need to remove the interpreter-wide trace
* which we created to allow 'step' traces.
*/
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/* Postpone deletion */
tcmdPtr->flags = 0;
}
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TclTraceExecutionObjCmd: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
clientData = NULL;
name = Tcl_GetString(objv[3]);
/* First ensure the name given is valid */
if (Tcl_FindCommand(interp, name, NULL,
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
int numOps = 0;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
/*
* Build a list with the ops list as the first obj
* element and the tcmdPtr->command string as the
* second obj element. Append this list (as an
* element) to the end of the result object list.
*/
elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_IncrRefCount(elemObjPtr);
if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("enter",5));
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("leave",5));
}
if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("enterstep",9));
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("leavestep",9));
}
Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
}
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_DecrRefCount(elemObjPtr);
elemObjPtr = NULL;
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr,
Tcl_NewStringObj(tcmdPtr->command, -1));
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclTraceCommandObjCmd --
*
* Helper function for Tcl_TraceObjCmd; implements the
* [trace {add|info|remove} command ...] subcommands.
* See the user documentation for details on what these do.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Depends on the operation (add, remove, or info) being performed;
* may add or remove command traces on a command.
*
*----------------------------------------------------------------------
*/
int
TclTraceCommandObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp; /* Current interpreter. */
int optionIndex; /* Add, info or remove */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "delete", "rename", (char *) NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0;
int i, listLen, result;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
return TCL_ERROR;
}
/*
* Make sure the ops argument is a list object; get its length and
* a pointer to its array of element pointers.
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of delete or rename", TCL_STATIC);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum operations) index) {
case TRACE_CMD_RENAME:
flags |= TCL_TRACE_RENAME;
break;
case TRACE_CMD_DELETE:
flags |= TCL_TRACE_DELETE;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr;
tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
+ length + 1));
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
tcmdPtr->refCount = 1;
flags |= TCL_TRACE_DELETE;
memcpy(tcmdPtr->command, command, length + 1);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
(ClientData) tcmdPtr) != TCL_OK) {
ckfree((char *) tcmdPtr);
return TCL_ERROR;
}
} else {
/*
* Search through all of our traces on this command to
* see if there's one with the given command. If so, then
* delete the first one that matches.
*/
TraceCommandInfo *tcmdPtr;
ClientData clientData = NULL;
name = Tcl_GetString(objv[3]);
/* First ensure the name given is valid */
if (Tcl_FindCommand(interp, name, NULL,
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
tcmdPtr = (TraceCommandInfo *) clientData;
if ((tcmdPtr->length == length)
&& (tcmdPtr->flags == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceCommand(interp, name,
flags | TCL_TRACE_DELETE,
TraceCommandProc, clientData);
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TclTraceCommandObjCmd: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char *) tcmdPtr);
}
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
clientData = NULL;
name = Tcl_GetString(objv[3]);
/* First ensure the name given is valid */
if (Tcl_FindCommand(interp, name, NULL,
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
int numOps = 0;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
/*
* Build a list with the ops list as
* the first obj element and the tcmdPtr->command string
* as the second obj element. Append this list (as an
* element) to the end of the result object list.
*/
elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_IncrRefCount(elemObjPtr);
if (tcmdPtr->flags & TCL_TRACE_RENAME) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("rename",6));
}
if (tcmdPtr->flags & TCL_TRACE_DELETE) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("delete",6));
}
Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
}
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_DecrRefCount(elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclTraceVariableObjCmd --
*
* Helper function for Tcl_TraceObjCmd; implements the
* [trace {add|info|remove} variable ...] subcommands.
* See the user documentation for details on what these do.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Depends on the operation (add, remove, or info) being performed;
* may add or remove variable traces on a variable.
*
*----------------------------------------------------------------------
*/
int
TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp; /* Current interpreter. */
int optionIndex; /* Add, info or remove */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "array", "read", "unset", "write",
(char *) NULL };
enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET,
TRACE_VAR_WRITE };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0;
int i, listLen, result;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
return TCL_ERROR;
}
/*
* Make sure the ops argument is a list object; get its length and
* a pointer to its array of element pointers.
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of array, read, unset, or write",
TCL_STATIC);
return TCL_ERROR;
}
for (i = 0; i < listLen ; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum operations) index) {
case TRACE_VAR_ARRAY:
flags |= TCL_TRACE_ARRAY;
break;
case TRACE_VAR_READ:
flags |= TCL_TRACE_READS;
break;
case TRACE_VAR_UNSET:
flags |= TCL_TRACE_UNSETS;
break;
case TRACE_VAR_WRITE:
flags |= TCL_TRACE_WRITES;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
/*
* This code essentially mallocs together the VarTrace and the
* TraceVarInfo, then inlines the Tcl_TraceVar(). This is
* necessary in order to have the TraceVarInfo to be freed
* automatically when the VarTrace is freed [Bug 1348775]
*/
CompoundVarTrace *compTracePtr;
TraceVarInfo *tvarPtr;
Var *varPtr, *arrayPtr;
VarTrace *tracePtr;
int flagMask;
compTracePtr = (CompoundVarTrace *) ckalloc((unsigned)
(sizeof(CompoundVarTrace) - sizeof(tvarPtr->command)
+ length + 1));
tracePtr = &(compTracePtr->trace);
tvarPtr = &(compTracePtr->tvar);
tvarPtr->flags = flags;
if (objv[0] == NULL) {
tvarPtr->flags |= TCL_TRACE_OLD_STYLE;
}
tvarPtr->length = length;
flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
memcpy(tvarPtr->command, command, length + 1);
name = Tcl_GetString(objv[3]);
flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
varPtr = TclLookupVar(interp, name, NULL,
(flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
ckfree((char *) tracePtr);
return TCL_ERROR;
}
flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES
| TCL_TRACE_UNSETS | TCL_TRACE_ARRAY
| TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
tracePtr->traceProc = TraceVarProc;
tracePtr->clientData = (ClientData) tvarPtr;
tracePtr->flags = flags & flagMask;
tracePtr->nextPtr = varPtr->tracePtr;
varPtr->tracePtr = tracePtr;
} else {
/*
* Search through all of our traces on this variable to
* see if there's one with the given command. If so, then
* delete the first one that matches.
*/
TraceVarInfo *tvarPtr;
ClientData clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
tvarPtr = (TraceVarInfo *) clientData;
if ((tvarPtr->length == length)
&& ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
TraceVarProc, clientData);
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
/*
* Build a list with the ops list as
* the first obj element and the tcmdPtr->command string
* as the second obj element. Append this list (as an
* element) to the end of the result object list.
*/
elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if (tvarPtr->flags & TCL_TRACE_ARRAY) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("array", 5));
}
if (tvarPtr->flags & TCL_TRACE_READS) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("read", 4));
}
if (tvarPtr->flags & TCL_TRACE_WRITES) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("write", 5));
}
if (tvarPtr->flags & TCL_TRACE_UNSETS) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("unset", 5));
}
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CommandTraceInfo --
*
* Return the clientData value associated with a trace on a
* command. This procedure can also be used to step through
* all of the traces on a particular command that have the
* same trace procedure.
*
* Results:
* The return value is the clientData value associated with
* a trace on the given command. Information will only be
* returned for a trace with proc as trace procedure. If
* the clientData argument is NULL then the first such trace is
* returned; otherwise, the next relevant one after the one
* given by clientData will be returned. If the command
* doesn't exist then an error message is left in the interpreter
* and NULL is returned. Also, if there are no (more) traces for
* the given command, NULL is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData)
Tcl_Interp *interp; /* Interpreter containing command. */
CONST char *cmdName; /* Name of command. */
int flags; /* OR-ed combo or TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY (can be 0). */
Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */
ClientData prevClientData; /* If non-NULL, gives last value returned
* by this procedure, so this call will
* return the next trace after that one.
* If NULL, this call will return the
* first trace. */
{
Command *cmdPtr;
register CommandTrace *tracePtr;
cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
NULL, TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return NULL;
}
/*
* Find the relevant trace, if any, and return its clientData.
*/
tracePtr = cmdPtr->tracePtr;
if (prevClientData != NULL) {
for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if ((tracePtr->clientData == prevClientData)
&& (tracePtr->traceProc == proc)) {
tracePtr = tracePtr->nextPtr;
break;
}
}
}
for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if (tracePtr->traceProc == proc) {
return tracePtr->clientData;
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TraceCommand --
*
* Arrange for rename/deletes to a command to cause a
* procedure to be invoked, which can monitor the operations.
*
* Also optionally arrange for execution of that command
* to cause a procedure to be invoked.
*
* Results:
* A standard Tcl return value.
*
* Side effects:
* A trace is set up on the command given by cmdName, such that
* future changes to the command will be intermediated by
* proc. See the manual entry for complete details on the calling
* sequence for proc.
*
*----------------------------------------------------------------------
*/
int
Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which command is
* to be traced. */
CONST char *cmdName; /* Name of command. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
* and any of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are
* invoked upon varName. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
Command *cmdPtr;
register CommandTrace *tracePtr;
cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
NULL, TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return TCL_ERROR;
}
/*
* Set up trace information.
*/
tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE
| TCL_TRACE_ANY_EXEC);
tracePtr->nextPtr = cmdPtr->tracePtr;
tracePtr->refCount = 1;
cmdPtr->tracePtr = tracePtr;
if ((tracePtr->flags & TCL_TRACE_ANY_EXEC)
&& !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
/*
* Bug 3484621: New execution trace means we no longer compile
* this command if we normally would. Invalidate bytecode.
*/
if (cmdPtr->compileProc != NULL) {
((Interp *)interp)->compileEpoch++;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UntraceCommand --
*
* Remove a previously-created trace for a command.
*
* Results:
* None.
*
* Side effects:
* If there exists a trace for the command given by cmdName
* with the given flags, proc, and clientData, then that trace
* is removed.
*
*----------------------------------------------------------------------
*/
void
Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing command. */
CONST char *cmdName; /* Name of command. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
* and any of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
register CommandTrace *tracePtr;
CommandTrace *prevPtr;
Command *cmdPtr;
Interp *iPtr = (Interp *) interp;
ActiveCommandTrace *activePtr;
int hasExecTraces = 0;
cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
NULL, TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return;
}
flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);
for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
return;
}
if ((tracePtr->traceProc == proc)
&& ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE |
TCL_TRACE_ANY_EXEC)) == flags)
&& (tracePtr->clientData == clientData)) {
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
hasExecTraces = 1;
}
break;
}
}
/*
* The code below makes it possible to delete traces while traces
* are active: it makes sure that the deleted trace won't be
* processed by CallCommandTraces.
*/
for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
if (activePtr->reverseScan) {
activePtr->nextTracePtr = prevPtr;
} else {
activePtr->nextTracePtr = tracePtr->nextPtr;
}
}
}
if (prevPtr == NULL) {
cmdPtr->tracePtr = tracePtr->nextPtr;
} else {
prevPtr->nextPtr = tracePtr->nextPtr;
}
tracePtr->flags = 0;
if ((--tracePtr->refCount) <= 0) {
ckfree((char*)tracePtr);
}
if (hasExecTraces) {
for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
return;
}
}
/*
* None of the remaining traces on this command are execution
* traces. We therefore remove this flag:
*/
cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
/*
* Bug 3484621: No more execution trace means we can compile
* the command again. If we will, invalidate bytecode.
*/
if (cmdPtr->compileProc != NULL) {
((Interp *)interp)->compileEpoch++;
}
}
}
/*
*----------------------------------------------------------------------
*
* TraceCommandProc --
*
* This procedure is called to handle command changes that have
* been traced using the "trace" command, when using the
* 'rename' or 'delete' options.
*
* Results:
* None.
*
* Side effects:
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static void
TraceCommandProc(clientData, interp, oldName, newName, flags)
ClientData clientData; /* Information about the command trace. */
Tcl_Interp *interp; /* Interpreter containing command. */
CONST char *oldName; /* Name of command being changed. */
CONST char *newName; /* New name of command. Empty string
* or NULL means command is being deleted
* (renamed to ""). */
int flags; /* OR-ed bits giving operation and other
* information. */
{
Interp *iPtr = (Interp *) interp;
int stateCode;
Tcl_SavedResult state;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
int code;
Tcl_DString cmd;
tcmdPtr->refCount++;
if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)) {
/*
* Generate a command to execute by appending list elements
* for the old and new command name and the operation.
*/
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
Tcl_DStringAppendElement(&cmd, oldName);
Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
if (flags & TCL_TRACE_RENAME) {
Tcl_DStringAppend(&cmd, " rename", 7);
} else if (flags & TCL_TRACE_DELETE) {
Tcl_DStringAppend(&cmd, " delete", 7);
}
/*
* Execute the command. Save the interp's result used for the
* command, including the value of iPtr->returnCode which may be
* modified when Tcl_Eval is invoked. We discard any object
* result the command returns.
*
* Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to
* other areas that this will be destroyed by us, otherwise a
* double-free might occur depending on what the eval does.
*/
Tcl_SaveResult(interp, &state);
stateCode = iPtr->returnCode;
if (flags & TCL_TRACE_DESTROYED) {
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
}
code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
Tcl_DStringLength(&cmd), 0);
if (code != TCL_OK) {
/* We ignore errors in these traced commands */
}
Tcl_RestoreResult(interp, &state);
iPtr->returnCode = stateCode;
Tcl_DStringFree(&cmd);
}
/*
* We delete when the trace was destroyed or if this is a delete trace,
* because command deletes are unconditional, so the trace must go away.
*/
if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
int untraceFlags = tcmdPtr->flags;
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/* Postpone deletion, until exec trace returns */
tcmdPtr->flags = 0;
}
/*
* We need to construct the same flags for Tcl_UntraceCommand
* as were passed to Tcl_TraceCommand. Reproduce the processing
* of [trace add execution/command]. Be careful to keep this
* code in sync with that.
*/
if (untraceFlags & TCL_TRACE_ANY_EXEC) {
untraceFlags |= TCL_TRACE_DELETE;
if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC
| TCL_TRACE_LEAVE_DURING_EXEC)) {
untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
}
} else if (untraceFlags & TCL_TRACE_RENAME) {
untraceFlags |= TCL_TRACE_DELETE;
}
/*
* Remove the trace since TCL_TRACE_DESTROYED tells us to, or the
* command we're tracing has just gone away. Then decrement the
* clientData refCount that was set up by trace creation.
*
* Note that we save the (return) state of the interpreter to prevent
* bizarre error messages.
*/
Tcl_SaveResult(interp, &state);
stateCode = iPtr->returnCode;
Tcl_UntraceCommand(interp, oldName, untraceFlags,
TraceCommandProc, clientData);
Tcl_RestoreResult(interp, &state);
iPtr->returnCode = stateCode;
tcmdPtr->refCount--;
}
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TraceCommandProc: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
return;
}
/*
*----------------------------------------------------------------------
*
* TclCheckExecutionTraces --
*
* Checks on all current command execution traces, and invokes
* procedures which have been registered. This procedure can be
* used by other code which performs execution to unify the
* tracing system, so that execution traces will function for that
* other code.
*
* For instance extensions like [incr Tcl] which use their
* own execution technique can make use of Tcl's tracing.
*
* This procedure is called by 'TclEvalObjvInternal'
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR, etc.
*
* Side effects:
* Those side effects made by any trace procedures called.
*
*----------------------------------------------------------------------
*/
int
TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code,
traceFlags, objc, objv)
Tcl_Interp *interp; /* The current interpreter. */
CONST char *command; /* Pointer to beginning of the current
* command string. */
int numChars; /* The number of characters in 'command'
* which are part of the command string. */
Command *cmdPtr; /* Points to command's Command struct. */
int code; /* The current result code. */
int traceFlags; /* Current tracing situation. */
int objc; /* Number of arguments for the command. */
Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
CommandTrace *tracePtr, *lastTracePtr;
ActiveCommandTrace active;
int curLevel;
int traceCode = TCL_OK;
TraceCommandInfo* tcmdPtr;
if (command == NULL || cmdPtr->tracePtr == NULL) {
return traceCode;
}
curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
active.nextPtr = iPtr->activeCmdTracePtr;
iPtr->activeCmdTracePtr = &active;
active.cmdPtr = cmdPtr;
lastTracePtr = NULL;
for (tracePtr = cmdPtr->tracePtr;
(traceCode == TCL_OK) && (tracePtr != NULL);
tracePtr = active.nextTracePtr) {
if (traceFlags & TCL_TRACE_LEAVE_EXEC) {
/* execute the trace command in order of creation for "leave" */
active.reverseScan = 1;
active.nextTracePtr = NULL;
tracePtr = cmdPtr->tracePtr;
while (tracePtr->nextPtr != lastTracePtr) {
active.nextTracePtr = tracePtr;
tracePtr = tracePtr->nextPtr;
}
} else {
active.reverseScan = 0;
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->traceProc == TraceCommandProc) {
tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
if (tcmdPtr->flags != 0) {
tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
tcmdPtr->curCode = code;
tcmdPtr->refCount++;
traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp,
curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TclCheckExecutionTraces: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
}
}
if (active.nextTracePtr) {
lastTracePtr = active.nextTracePtr->nextPtr;
}
}
iPtr->activeCmdTracePtr = active.nextPtr;
return(traceCode);
}
/*
*----------------------------------------------------------------------
*
* TclCheckInterpTraces --
*
* Checks on all current traces, and invokes procedures which
* have been registered. This procedure can be used by other
* code which performs execution to unify the tracing system.
* For instance extensions like [incr Tcl] which use their
* own execution technique can make use of Tcl's tracing.
*
* This procedure is called by 'TclEvalObjvInternal'
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR, etc.
*
* Side effects:
* Those side effects made by any trace procedures called.
*
*----------------------------------------------------------------------
*/
int
TclCheckInterpTraces(interp, command, numChars, cmdPtr, code,
traceFlags, objc, objv)
Tcl_Interp *interp; /* The current interpreter. */
CONST char *command; /* Pointer to beginning of the current
* command string. */
int numChars; /* The number of characters in 'command'
* which are part of the command string. */
Command *cmdPtr; /* Points to command's Command struct. */
int code; /* The current result code. */
int traceFlags; /* Current tracing situation. */
int objc; /* Number of arguments for the command. */
Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
Trace *tracePtr, *lastTracePtr;
ActiveInterpTrace active;
int curLevel;
int traceCode = TCL_OK;
if (command == NULL || iPtr->tracePtr == NULL ||
(iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
return(traceCode);
}
curLevel = iPtr->numLevels;
active.nextPtr = iPtr->activeInterpTracePtr;
iPtr->activeInterpTracePtr = &active;
lastTracePtr = NULL;
for ( tracePtr = iPtr->tracePtr;
(traceCode == TCL_OK) && (tracePtr != NULL);
tracePtr = active.nextTracePtr) {
if (traceFlags & TCL_TRACE_ENTER_EXEC) {
/*
* Execute the trace command in reverse order of creation
* for "enterstep" operation. The order is changed for
* "enterstep" instead of for "leavestep" as was done in
* TclCheckExecutionTraces because for step traces,
* Tcl_CreateObjTrace creates one more linked list of traces
* which results in one more reversal of trace invocation.
*/
active.reverseScan = 1;
active.nextTracePtr = NULL;
tracePtr = iPtr->tracePtr;
while (tracePtr->nextPtr != lastTracePtr) {
active.nextTracePtr = tracePtr;
tracePtr = tracePtr->nextPtr;
}
if (active.nextTracePtr) {
lastTracePtr = active.nextTracePtr->nextPtr;
}
} else {
active.reverseScan = 0;
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->level > 0 && curLevel > tracePtr->level) {
continue;
}
if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
/*
* The proc invoked might delete the traced command which
* which might try to free tracePtr. We want to use tracePtr
* until the end of this if section, so we use
* Tcl_Preserve() and Tcl_Release() to be sure it is not
* freed while we still need it.
*/
Tcl_Preserve((ClientData) tracePtr);
tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) {
/* New style trace */
if (tracePtr->flags & traceFlags) {
if (tracePtr->proc == TraceExecutionProc) {
TraceCommandInfo *tcmdPtr =
(TraceCommandInfo *) tracePtr->clientData;
tcmdPtr->curFlags = traceFlags;
tcmdPtr->curCode = code;
}
traceCode = (tracePtr->proc)(tracePtr->clientData,
interp, curLevel, command, (Tcl_Command)cmdPtr,
objc, objv);
}
} else {
/* Old-style trace */
if (traceFlags & TCL_TRACE_ENTER_EXEC) {
/*
* Old-style interpreter-wide traces only trigger
* before the command is executed.
*/
traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr,
command, numChars, objc, objv);
}
}
tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
Tcl_Release((ClientData) tracePtr);
}
}
iPtr->activeInterpTracePtr = active.nextPtr;
return(traceCode);
}
/*
*----------------------------------------------------------------------
*
* CallTraceProcedure --
*
* Invokes a trace procedure registered with an interpreter. These
* procedures trace command execution. Currently this trace procedure
* is called with the address of the string-based Tcl_CmdProc for the
* command, not the Tcl_ObjCmdProc.
*
* Results:
* None.
*
* Side effects:
* Those side effects made by the trace procedure.
*
*----------------------------------------------------------------------
*/
static int
CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
Tcl_Interp *interp; /* The current interpreter. */
register Trace *tracePtr; /* Describes the trace procedure to call. */
Command *cmdPtr; /* Points to command's Command struct. */
CONST char *command; /* Points to the first character of the
* command's source before substitutions. */
int numChars; /* The number of characters in the
* command's source. */
register int objc; /* Number of arguments for the command. */
Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
char *commandCopy;
int traceCode;
/*
* Copy the command characters into a new string.
*/
commandCopy = (char *) ckalloc((unsigned) (numChars + 1));
memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars);
commandCopy[numChars] = '\0';
/*
* Call the trace procedure then free allocated storage.
*/
traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr,
iPtr->numLevels, commandCopy,
(Tcl_Command) cmdPtr, objc, objv );
ckfree((char *) commandCopy);
return(traceCode);
}
/*
*----------------------------------------------------------------------
*
* CommandObjTraceDeleted --
*
* Ensure the trace is correctly deleted by decrementing its
* refCount and only deleting if no other references exist.
*
* Results:
* None.
*
* Side effects:
* May release memory.
*
*----------------------------------------------------------------------
*/
static void
CommandObjTraceDeleted(ClientData clientData) {
TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("CommandObjTraceDeleted: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TraceExecutionProc --
*
* This procedure is invoked whenever code relevant to a
* 'trace execution' command is executed. It is called in one
* of two ways in Tcl's core:
*
* (i) by the TclCheckExecutionTraces, when an execution trace
* has been triggered.
* (ii) by TclCheckInterpTraces, when a prior execution trace has
* created a trace of the internals of a procedure, passing in
* this procedure as the one to be called.
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR, etc.
*
* Side effects:
* May invoke an arbitrary Tcl procedure, and may create or
* delete an interpreter-wide trace.
*
*----------------------------------------------------------------------
*/
static int
TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
int level, CONST char* command, Tcl_Command cmdInfo,
int objc, struct Tcl_Obj *CONST objv[]) {
int call = 0;
Interp *iPtr = (Interp *) interp;
TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
int flags = tcmdPtr->curFlags;
int code = tcmdPtr->curCode;
int traceCode = TCL_OK;
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/*
* Inside any kind of execution trace callback, we do
* not allow any further execution trace callbacks to
* be called for the same trace.
*/
return traceCode;
}
if (!Tcl_InterpDeleted(interp)) {
/*
* Check whether the current call is going to eval arbitrary
* Tcl code with a generated trace, or whether we are only
* going to setup interpreter-wide traces to implement the
* 'step' traces. This latter situation can happen if
* we create a command trace without either before or after
* operations, but with either of the step operations.
*/
if (flags & TCL_TRACE_EXEC_DIRECT) {
call = flags & tcmdPtr->flags
& (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
} else {
call = 1;
}
/*
* First, if we have returned back to the level at which we
* created an interpreter trace for enterstep and/or leavestep
* execution traces, we remove it here.
*/
if (flags & TCL_TRACE_LEAVE_EXEC) {
if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel)
&& (strcmp(command, tcmdPtr->startCmd) == 0)) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
}
/*
* Second, create the tcl callback, if required.
*/
if (call) {
Tcl_SavedResult state;
int stateCode, i, saveInterpFlags;
Tcl_DString cmd;
Tcl_DString sub;
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);
/* Append command with arguments */
Tcl_DStringInit(&sub);
for (i = 0; i < objc; i++) {
char* str;
int len;
str = Tcl_GetStringFromObj(objv[i],&len);
Tcl_DStringAppendElement(&sub, str);
}
Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub));
Tcl_DStringFree(&sub);
if (flags & TCL_TRACE_ENTER_EXEC) {
/* Append trace operation */
if (flags & TCL_TRACE_EXEC_DIRECT) {
Tcl_DStringAppendElement(&cmd, "enter");
} else {
Tcl_DStringAppendElement(&cmd, "enterstep");
}
} else if (flags & TCL_TRACE_LEAVE_EXEC) {
Tcl_Obj* resultCode;
char* resultCodeStr;
/* Append result code */
resultCode = Tcl_NewIntObj(code);
resultCodeStr = Tcl_GetString(resultCode);
Tcl_DStringAppendElement(&cmd, resultCodeStr);
Tcl_DecrRefCount(resultCode);
/* Append result string */
Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp));
/* Append trace operation */
if (flags & TCL_TRACE_EXEC_DIRECT) {
Tcl_DStringAppendElement(&cmd, "leave");
} else {
Tcl_DStringAppendElement(&cmd, "leavestep");
}
} else {
panic("TraceExecutionProc: bad flag combination");
}
/*
* Execute the command. Save the interp's result used for
* the command, including the value of iPtr->returnCode which
* may be modified when Tcl_Eval is invoked. We discard any
* object result the command returns.
*/
Tcl_SaveResult(interp, &state);
stateCode = iPtr->returnCode;
saveInterpFlags = iPtr->flags;
iPtr->flags |= INTERP_TRACE_IN_PROGRESS;
tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
tcmdPtr->refCount++;
/*
* This line can have quite arbitrary side-effects,
* including deleting the trace, the command being
* traced, or even the interpreter.
*/
traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
/*
* Restore the interp tracing flag to prevent cmd traces
* from affecting interp traces
*/
iPtr->flags = saveInterpFlags;;
if (tcmdPtr->flags == 0) {
flags |= TCL_TRACE_DESTROYED;
}
if (traceCode == TCL_OK) {
/* Restore result if trace execution was successful */
Tcl_RestoreResult(interp, &state);
iPtr->returnCode = stateCode;
} else {
Tcl_DiscardResult(&state);
}
Tcl_DStringFree(&cmd);
}
/*
* Third, if there are any step execution traces for this proc,
* we register an interpreter trace to invoke enterstep and/or
* leavestep traces.
* We also need to save the current stack level and the proc
* string in startLevel and startCmd so that we can delete this
* interpreter trace when it reaches the end of this proc.
*/
if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC))) {
tcmdPtr->startLevel = level;
tcmdPtr->startCmd =
(char *) ckalloc((unsigned) (strlen(command) + 1));
strcpy(tcmdPtr->startCmd, command);
tcmdPtr->refCount++;
tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
(tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
TraceExecutionProc, (ClientData)tcmdPtr,
CommandObjTraceDeleted);
}
}
if (flags & TCL_TRACE_DESTROYED) {
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
}
if (call) {
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TraceExecutionProc: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
}
return traceCode;
}
/*
*----------------------------------------------------------------------
*
* TraceVarProc --
*
* This procedure is called to handle variable accesses that have
* been traced using the "trace" command.
*
* Results:
* Normally returns NULL. If the trace command returns an error,
* then this procedure returns an error string.
*
* Side effects:
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Information about the variable trace. */
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *name1; /* Name of variable or array. */
CONST char *name2; /* Name of element within array; NULL means
* scalar variable is being referenced. */
int flags; /* OR-ed bits giving operation and other
* information. */
{
Tcl_SavedResult state;
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
char *result;
int code, destroy = 0;
Tcl_DString cmd;
/*
* We might call Tcl_Eval() below, and that might evaluate [trace
* vdelete] which might try to free tvarPtr. However we do not
* need to protect anything here; it's done by our caller because
* the TraceVarInfo is really part of a CompoundVarTrace. [Bug 1348775]
*/
result = NULL;
if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)) {
if (tvarPtr->length != (size_t) 0) {
/*
* Generate a command to execute by appending list elements
* for the two variable names and the operation.
*/
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
Tcl_DStringAppendElement(&cmd, name1);
Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
if (flags & TCL_TRACE_ARRAY) {
Tcl_DStringAppend(&cmd, " a", 2);
} else if (flags & TCL_TRACE_READS) {
Tcl_DStringAppend(&cmd, " r", 2);
} else if (flags & TCL_TRACE_WRITES) {
Tcl_DStringAppend(&cmd, " w", 2);
} else if (flags & TCL_TRACE_UNSETS) {
Tcl_DStringAppend(&cmd, " u", 2);
}
} else {
#endif
if (flags & TCL_TRACE_ARRAY) {
Tcl_DStringAppend(&cmd, " array", 6);
} else if (flags & TCL_TRACE_READS) {
Tcl_DStringAppend(&cmd, " read", 5);
} else if (flags & TCL_TRACE_WRITES) {
Tcl_DStringAppend(&cmd, " write", 6);
} else if (flags & TCL_TRACE_UNSETS) {
Tcl_DStringAppend(&cmd, " unset", 6);
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
}
#endif
/*
* Execute the command. Save the interp's result used for
* the command. We discard any object result the command returns.
*
* Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to
* other areas that this will be destroyed by us, otherwise a
* double-free might occur depending on what the eval does.
*/
Tcl_SaveResult(interp, &state);
if ((flags & TCL_TRACE_DESTROYED)
&& !(tvarPtr->flags & TCL_TRACE_DESTROYED)) {
destroy = 1;
tvarPtr->flags |= TCL_TRACE_DESTROYED;
}
code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
Tcl_DStringLength(&cmd), 0);
if (code != TCL_OK) { /* copy error msg to result */
register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errMsgObj);
result = (char *) errMsgObj;
}
Tcl_RestoreResult(interp, &state);
Tcl_DStringFree(&cmd);
}
}
if (destroy) {
if (result != NULL) {
register Tcl_Obj *errMsgObj = (Tcl_Obj *) result;
Tcl_DecrRefCount(errMsgObj);
result = NULL;
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_WhileObjCmd --
*
* This procedure is invoked to process the "while" Tcl command.
* See the user documentation for details on what it does.
*
* With the bytecode compiler, this procedure is only called when
* a command name is computed at runtime, and is "while" or the name
* to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_WhileObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result, value;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "test command");
return TCL_ERROR;
}
while (1) {
result = Tcl_ExprBooleanObj(interp, objv[1], &value);
if (result != TCL_OK) {
return result;
}
if (!value) {
break;
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[2], 0);
#else
/* TIP #280. */
result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr,2);
#endif
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"while\" body line %d)",
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
break;
}
}
if (result == TCL_BREAK) {
result = TCL_OK;
}
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
return result;
}
#ifdef TCL_TIP280
static void
ListLines(listObj, line, n, lines, elems)
Tcl_Obj* listObj; /* Pointer to obj holding a string with list structure.
* Assumed to be valid. Assumed to contain n elements.
*/
int line; /* line the list as a whole starts on */
int n; /* #elements in lines */
int* lines; /* Array of line numbers, to fill */
Tcl_Obj* const* elems; /* The list elems as Tcl_Obj*, in need of derived
* continuation data */
{
int i;
CONST char* listStr = Tcl_GetString (listObj);
CONST char* listHead = listStr;
int length = strlen( listStr);
CONST char* element = NULL;
CONST char* next = NULL;
ContLineLoc* clLocPtr = TclContinuationsGet(listObj);
int* clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL);
for (i = 0; i < n; i++) {
TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL);
TclAdvanceLines (&line, listStr, element); /* Leading whitespace */
TclAdvanceContinuations (&line, &clNext, element - listHead);
if (clNext) {
TclContinuationsEnterDerived (elems[i], element - listHead, clNext);
}
lines [i] = line;
length -= (next - listStr);
TclAdvanceLines (&line, element, next); /* Element */
listStr = next;
if (*element == 0) {
/* ASSERT i == n */
break;
}
}
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclThreadAlloc.c 0000755 0036047 0045461 00000057107 11737050674 015401 0 ustar dgp 771div /*
* tclThreadAlloc.c --
*
* This is a very fast storage allocator for used with threads (designed
* avoid lock contention). The basic strategy is to allocate memory in
* fixed size blocks from block caches.
*
* The Initial Developer of the Original Code is America Online, Inc.
* Portions created by AOL are Copyright (C) 1999 America Online, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) && !defined(TCL_MEM_DEBUG)
#ifdef WIN32
#include "tclWinInt.h"
#else
extern Tcl_Mutex *TclpNewAllocMutex(void);
extern void *TclpGetAllocCache(void);
extern void TclpSetAllocCache(void *);
#endif
/*
* If range checking is enabled, an additional byte will be allocated
* to store the magic number at the end of the requested memory.
*/
#ifndef RCHECK
#ifdef NDEBUG
#define RCHECK 0
#else
#define RCHECK 1
#endif
#endif
/*
* The following define the number of Tcl_Obj's to allocate/move
* at a time and the high water mark to prune a per-thread cache.
* On a 32 bit system, sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k.
*
*/
#define NOBJALLOC 800
#define NOBJHIGH 1200
/*
* Alignment for allocated memory.
*/
#if defined(__APPLE__)
#define ALLOCALIGN 16
#else
#define ALLOCALIGN 8
#endif
/*
* The following union stores accounting information for
* each block including two small magic numbers and
* a bucket number when in use or a next pointer when
* free. The original requested size (not including
* the Block overhead) is also maintained.
*/
typedef union Block {
struct {
union {
union Block *next; /* Next in free list. */
struct {
unsigned char magic1; /* First magic number. */
unsigned char bucket; /* Bucket block allocated from. */
unsigned char unused; /* Padding. */
unsigned char magic2; /* Second magic number. */
} s;
} u;
size_t reqSize; /* Requested allocation size. */
} b;
unsigned char padding[ALLOCALIGN];
} Block;
#define b_next b.u.next
#define b_bucket b.u.s.bucket
#define b_magic1 b.u.s.magic1
#define b_magic2 b.u.s.magic2
#define MAGIC 0xef
#define b_reqsize b.reqSize
/*
* The following defines the minimum and and maximum block sizes and the number
* of buckets in the bucket cache.
*/
#define MINALLOC ((sizeof(Block) + 8 + (ALLOCALIGN-1)) & ~(ALLOCALIGN-1))
#define NBUCKETS (11 - (MINALLOC >> 5))
#define MAXALLOC (MINALLOC << (NBUCKETS - 1))
/*
* The following structure defines a bucket of blocks with
* various accounting and statistics information.
*/
typedef struct Bucket {
Block *firstPtr;
long nfree;
long nget;
long nput;
long nwait;
long nlock;
long nrequest;
} Bucket;
/*
* The following structure defines a cache of buckets and objs.
*/
typedef struct Cache {
struct Cache *nextPtr;
Tcl_ThreadId owner;
Tcl_Obj *firstObjPtr;
int nobjs;
int nsysalloc;
Bucket buckets[NBUCKETS];
} Cache;
/*
* The following array specifies various per-bucket
* limits and locks. The values are statically initialized
* to avoid calculating them repeatedly.
*/
struct binfo {
size_t blocksize; /* Bucket blocksize. */
int maxblocks; /* Max blocks before move to share. */
int nmove; /* Num blocks to move to share. */
Tcl_Mutex *lockPtr; /* Share bucket lock. */
} binfo[NBUCKETS];
/*
* Static functions defined in this file.
*/
static void LockBucket(Cache *cachePtr, int bucket);
static void UnlockBucket(Cache *cachePtr, int bucket);
static void PutBlocks(Cache *cachePtr, int bucket, int nmove);
static int GetBlocks(Cache *cachePtr, int bucket);
static Block *Ptr2Block(char *ptr);
static char *Block2Ptr(Block *blockPtr, int bucket, unsigned int reqsize);
static void MoveObjs(Cache *fromPtr, Cache *toPtr, int nmove);
/*
* Local variables defined in this file and initialized at
* startup.
*/
static Tcl_Mutex *listLockPtr;
static Tcl_Mutex *objLockPtr;
static Cache sharedCache;
static Cache *sharedPtr = &sharedCache;
static Cache *firstCachePtr = &sharedCache;
/*
*----------------------------------------------------------------------
*
* GetCache ---
*
* Gets per-thread memory cache, allocating it if necessary.
*
* Results:
* Pointer to cache.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Cache *
GetCache(void)
{
Cache *cachePtr;
/*
* Check for first-time initialization.
*/
if (listLockPtr == NULL) {
Tcl_Mutex *initLockPtr;
unsigned int i;
initLockPtr = Tcl_GetAllocMutex();
Tcl_MutexLock(initLockPtr);
if (listLockPtr == NULL) {
listLockPtr = TclpNewAllocMutex();
objLockPtr = TclpNewAllocMutex();
for (i = 0; i < NBUCKETS; ++i) {
binfo[i].blocksize = MINALLOC << i;
binfo[i].maxblocks = 1 << (NBUCKETS - 1 - i);
binfo[i].nmove = i < NBUCKETS-1 ? 1 << (NBUCKETS - 2 - i) : 1;
binfo[i].lockPtr = TclpNewAllocMutex();
}
}
Tcl_MutexUnlock(initLockPtr);
}
/*
* Get this thread's cache, allocating if necessary.
*/
cachePtr = TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = calloc(1, sizeof(Cache));
if (cachePtr == NULL) {
panic("alloc: could not allocate new cache");
}
Tcl_MutexLock(listLockPtr);
cachePtr->nextPtr = firstCachePtr;
firstCachePtr = cachePtr;
Tcl_MutexUnlock(listLockPtr);
cachePtr->owner = Tcl_GetCurrentThread();
TclpSetAllocCache(cachePtr);
}
return cachePtr;
}
/*
*----------------------------------------------------------------------
*
* TclFreeAllocCache --
*
* Flush and delete a cache, removing from list of caches.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclFreeAllocCache(void *arg)
{
Cache *cachePtr = arg;
Cache **nextPtrPtr;
register unsigned int bucket;
/*
* Flush blocks.
*/
for (bucket = 0; bucket < NBUCKETS; ++bucket) {
if (cachePtr->buckets[bucket].nfree > 0) {
PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].nfree);
}
}
/*
* Flush objs.
*/
if (cachePtr->nobjs > 0) {
Tcl_MutexLock(objLockPtr);
MoveObjs(cachePtr, sharedPtr, cachePtr->nobjs);
Tcl_MutexUnlock(objLockPtr);
}
/*
* Remove from pool list.
*/
Tcl_MutexLock(listLockPtr);
nextPtrPtr = &firstCachePtr;
while (*nextPtrPtr != cachePtr) {
nextPtrPtr = &(*nextPtrPtr)->nextPtr;
}
*nextPtrPtr = cachePtr->nextPtr;
cachePtr->nextPtr = NULL;
Tcl_MutexUnlock(listLockPtr);
free(cachePtr);
}
/*
*----------------------------------------------------------------------
*
* TclpAlloc --
*
* Allocate memory.
*
* Results:
* Pointer to memory just beyond Block pointer.
*
* Side effects:
* May allocate more blocks for a bucket.
*
*----------------------------------------------------------------------
*/
char *
TclpAlloc(unsigned int reqsize)
{
Cache *cachePtr;
Block *blockPtr;
register int bucket;
size_t size;
if (sizeof(int) >= sizeof(size_t)) {
/* An unsigned int overflow can also be a size_t overflow */
const size_t zero = 0;
const size_t max = ~zero;
if (((size_t) reqsize) > max - sizeof(Block) - RCHECK) {
/* Requested allocation exceeds memory */
return NULL;
}
}
cachePtr = TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = GetCache();
}
/*
* Increment the requested size to include room for
* the Block structure. Call malloc() directly if the
* required amount is greater than the largest block,
* otherwise pop the smallest block large enough,
* allocating more blocks if necessary.
*/
blockPtr = NULL;
size = reqsize + sizeof(Block);
#if RCHECK
++size;
#endif
if (size > MAXALLOC) {
bucket = NBUCKETS;
blockPtr = malloc(size);
if (blockPtr != NULL) {
cachePtr->nsysalloc += reqsize;
}
} else {
bucket = 0;
while (binfo[bucket].blocksize < size) {
++bucket;
}
if (cachePtr->buckets[bucket].nfree || GetBlocks(cachePtr, bucket)) {
blockPtr = cachePtr->buckets[bucket].firstPtr;
cachePtr->buckets[bucket].firstPtr = blockPtr->b_next;
--cachePtr->buckets[bucket].nfree;
++cachePtr->buckets[bucket].nget;
cachePtr->buckets[bucket].nrequest += reqsize;
}
}
if (blockPtr == NULL) {
return NULL;
}
return Block2Ptr(blockPtr, bucket, reqsize);
}
/*
*----------------------------------------------------------------------
*
* TclpFree --
*
* Return blocks to the thread block cache.
*
* Results:
* None.
*
* Side effects:
* May move blocks to shared cache.
*
*----------------------------------------------------------------------
*/
void
TclpFree(char *ptr)
{
if (ptr != NULL) {
Cache *cachePtr = TclpGetAllocCache();
Block *blockPtr;
int bucket;
if (cachePtr == NULL) {
cachePtr = GetCache();
}
/*
* Get the block back from the user pointer and
* call system free directly for large blocks.
* Otherwise, push the block back on the bucket and
* move blocks to the shared cache if there are now
* too many free.
*/
blockPtr = Ptr2Block(ptr);
bucket = blockPtr->b_bucket;
if (bucket == NBUCKETS) {
cachePtr->nsysalloc -= blockPtr->b_reqsize;
free(blockPtr);
} else {
cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize;
blockPtr->b_next = cachePtr->buckets[bucket].firstPtr;
cachePtr->buckets[bucket].firstPtr = blockPtr;
++cachePtr->buckets[bucket].nfree;
++cachePtr->buckets[bucket].nput;
if (cachePtr != sharedPtr &&
cachePtr->buckets[bucket].nfree > binfo[bucket].maxblocks) {
PutBlocks(cachePtr, bucket, binfo[bucket].nmove);
}
}
}
}
/*
*----------------------------------------------------------------------
*
* TclpRealloc --
*
* Re-allocate memory to a larger or smaller size.
*
* Results:
* Pointer to memory just beyond Block pointer.
*
* Side effects:
* Previous memory, if any, may be freed.
*
*----------------------------------------------------------------------
*/
char *
TclpRealloc(char *ptr, unsigned int reqsize)
{
Cache *cachePtr;
Block *blockPtr;
void *new;
size_t size, min;
int bucket;
if (ptr == NULL) {
return TclpAlloc(reqsize);
}
if (sizeof(int) >= sizeof(size_t)) {
/* An unsigned int overflow can also be a size_t overflow */
const size_t zero = 0;
const size_t max = ~zero;
if (((size_t) reqsize) > max - sizeof(Block) - RCHECK) {
/* Requested allocation exceeds memory */
return NULL;
}
}
cachePtr = TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = GetCache();
}
/*
* If the block is not a system block and fits in place,
* simply return the existing pointer. Otherwise, if the block
* is a system block and the new size would also require a system
* block, call realloc() directly.
*/
blockPtr = Ptr2Block(ptr);
size = reqsize + sizeof(Block);
#if RCHECK
++size;
#endif
bucket = blockPtr->b_bucket;
if (bucket != NBUCKETS) {
if (bucket > 0) {
min = binfo[bucket-1].blocksize;
} else {
min = 0;
}
if (size > min && size <= binfo[bucket].blocksize) {
cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize;
cachePtr->buckets[bucket].nrequest += reqsize;
return Block2Ptr(blockPtr, bucket, reqsize);
}
} else if (size > MAXALLOC) {
cachePtr->nsysalloc -= blockPtr->b_reqsize;
cachePtr->nsysalloc += reqsize;
blockPtr = realloc(blockPtr, size);
if (blockPtr == NULL) {
return NULL;
}
return Block2Ptr(blockPtr, NBUCKETS, reqsize);
}
/*
* Finally, perform an expensive malloc/copy/free.
*/
new = TclpAlloc(reqsize);
if (new != NULL) {
if (reqsize > blockPtr->b_reqsize) {
reqsize = blockPtr->b_reqsize;
}
memcpy(new, ptr, reqsize);
TclpFree(ptr);
}
return new;
}
/*
*----------------------------------------------------------------------
*
* TclThreadAllocObj --
*
* Allocate a Tcl_Obj from the per-thread cache.
*
* Results:
* Pointer to uninitialized Tcl_Obj.
*
* Side effects:
* May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's
* if list is empty.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclThreadAllocObj(void)
{
register Cache *cachePtr = TclpGetAllocCache();
register int nmove;
register Tcl_Obj *objPtr;
Tcl_Obj *newObjsPtr;
if (cachePtr == NULL) {
cachePtr = GetCache();
}
/*
* Get this thread's obj list structure and move
* or allocate new objs if necessary.
*/
if (cachePtr->nobjs == 0) {
Tcl_MutexLock(objLockPtr);
nmove = sharedPtr->nobjs;
if (nmove > 0) {
if (nmove > NOBJALLOC) {
nmove = NOBJALLOC;
}
MoveObjs(sharedPtr, cachePtr, nmove);
}
Tcl_MutexUnlock(objLockPtr);
if (cachePtr->nobjs == 0) {
cachePtr->nobjs = nmove = NOBJALLOC;
newObjsPtr = malloc(sizeof(Tcl_Obj) * nmove);
if (newObjsPtr == NULL) {
panic("alloc: could not allocate %d new objects", nmove);
}
while (--nmove >= 0) {
objPtr = &newObjsPtr[nmove];
objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
cachePtr->firstObjPtr = objPtr;
}
}
}
/*
* Pop the first object.
*/
objPtr = cachePtr->firstObjPtr;
cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
--cachePtr->nobjs;
return objPtr;
}
/*
*----------------------------------------------------------------------
*
* TclThreadFreeObj --
*
* Return a free Tcl_Obj to the per-thread cache.
*
* Results:
* None.
*
* Side effects:
* May move free Tcl_Obj's to shared list upon hitting high
* water mark.
*
*----------------------------------------------------------------------
*/
void
TclThreadFreeObj(Tcl_Obj *objPtr)
{
Cache *cachePtr = TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = GetCache();
}
/*
* Get this thread's list and push on the free Tcl_Obj.
*/
objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
cachePtr->firstObjPtr = objPtr;
++cachePtr->nobjs;
/*
* If the number of free objects has exceeded the high
* water mark, move some blocks to the shared list.
*/
if (cachePtr->nobjs > NOBJHIGH) {
Tcl_MutexLock(objLockPtr);
MoveObjs(cachePtr, sharedPtr, NOBJALLOC);
Tcl_MutexUnlock(objLockPtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetMemoryInfo --
*
* Return a list-of-lists of memory stats.
*
* Results:
* None.
*
* Side effects:
* List appended to given dstring.
*
*----------------------------------------------------------------------
*/
void
Tcl_GetMemoryInfo(Tcl_DString *dsPtr)
{
Cache *cachePtr;
char buf[200];
unsigned int n;
Tcl_MutexLock(listLockPtr);
cachePtr = firstCachePtr;
while (cachePtr != NULL) {
Tcl_DStringStartSublist(dsPtr);
if (cachePtr == sharedPtr) {
Tcl_DStringAppendElement(dsPtr, "shared");
} else {
sprintf(buf, "thread%d", (int) cachePtr->owner);
Tcl_DStringAppendElement(dsPtr, buf);
}
for (n = 0; n < NBUCKETS; ++n) {
sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld",
(unsigned long) binfo[n].blocksize,
cachePtr->buckets[n].nfree,
cachePtr->buckets[n].nget,
cachePtr->buckets[n].nput,
cachePtr->buckets[n].nrequest,
cachePtr->buckets[n].nlock,
cachePtr->buckets[n].nwait);
Tcl_DStringAppendElement(dsPtr, buf);
}
Tcl_DStringEndSublist(dsPtr);
cachePtr = cachePtr->nextPtr;
}
Tcl_MutexUnlock(listLockPtr);
}
/*
*----------------------------------------------------------------------
*
* MoveObjs --
*
* Move Tcl_Obj's between caches.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
MoveObjs(Cache *fromPtr, Cache *toPtr, int nmove)
{
register Tcl_Obj *objPtr = fromPtr->firstObjPtr;
Tcl_Obj *fromFirstObjPtr = objPtr;
toPtr->nobjs += nmove;
fromPtr->nobjs -= nmove;
/*
* Find the last object to be moved; set the next one
* (the first one not to be moved) as the first object
* in the 'from' cache.
*/
while (--nmove) {
objPtr = objPtr->internalRep.otherValuePtr;
}
fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
/*
* Move all objects as a block - they are already linked to
* each other, we just have to update the first and last.
*/
objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr;
toPtr->firstObjPtr = fromFirstObjPtr;
}
/*
*----------------------------------------------------------------------
*
* Block2Ptr, Ptr2Block --
*
* Convert between internal blocks and user pointers.
*
* Results:
* User pointer or internal block.
*
* Side effects:
* Invalid blocks will abort the server.
*
*----------------------------------------------------------------------
*/
static char *
Block2Ptr(Block *blockPtr, int bucket, unsigned int reqsize)
{
register void *ptr;
blockPtr->b_magic1 = blockPtr->b_magic2 = MAGIC;
blockPtr->b_bucket = bucket;
blockPtr->b_reqsize = reqsize;
ptr = ((void *) (blockPtr + 1));
#if RCHECK
((unsigned char *)(ptr))[reqsize] = MAGIC;
#endif
return (char *) ptr;
}
static Block *
Ptr2Block(char *ptr)
{
register Block *blockPtr;
blockPtr = (((Block *) ptr) - 1);
if (blockPtr->b_magic1 != MAGIC
#if RCHECK
|| ((unsigned char *) ptr)[blockPtr->b_reqsize] != MAGIC
#endif
|| blockPtr->b_magic2 != MAGIC) {
panic("alloc: invalid block: %p: %x %x %x\n",
blockPtr, blockPtr->b_magic1, blockPtr->b_magic2,
((unsigned char *) ptr)[blockPtr->b_reqsize]);
}
return blockPtr;
}
/*
*----------------------------------------------------------------------
*
* LockBucket, UnlockBucket --
*
* Set/unset the lock to access a bucket in the shared cache.
*
* Results:
* None.
*
* Side effects:
* Lock activity and contention are monitored globally and on
* a per-cache basis.
*
*----------------------------------------------------------------------
*/
static void
LockBucket(Cache *cachePtr, int bucket)
{
#if 0
if (Tcl_MutexTryLock(binfo[bucket].lockPtr) != TCL_OK) {
Tcl_MutexLock(binfo[bucket].lockPtr);
++cachePtr->buckets[bucket].nwait;
++sharedPtr->buckets[bucket].nwait;
}
#else
Tcl_MutexLock(binfo[bucket].lockPtr);
#endif
++cachePtr->buckets[bucket].nlock;
++sharedPtr->buckets[bucket].nlock;
}
static void
UnlockBucket(Cache *cachePtr, int bucket)
{
Tcl_MutexUnlock(binfo[bucket].lockPtr);
}
/*
*----------------------------------------------------------------------
*
* PutBlocks --
*
* Return unused blocks to the shared cache.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
PutBlocks(Cache *cachePtr, int bucket, int nmove)
{
register Block *lastPtr, *firstPtr;
register int n = nmove;
/*
* Before acquiring the lock, walk the block list to find
* the last block to be moved.
*/
firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr;
while (--n > 0) {
lastPtr = lastPtr->b_next;
}
cachePtr->buckets[bucket].firstPtr = lastPtr->b_next;
cachePtr->buckets[bucket].nfree -= nmove;
/*
* Aquire the lock and place the list of blocks at the front
* of the shared cache bucket.
*/
LockBucket(cachePtr, bucket);
lastPtr->b_next = sharedPtr->buckets[bucket].firstPtr;
sharedPtr->buckets[bucket].firstPtr = firstPtr;
sharedPtr->buckets[bucket].nfree += nmove;
UnlockBucket(cachePtr, bucket);
}
/*
*----------------------------------------------------------------------
*
* GetBlocks --
*
* Get more blocks for a bucket.
*
* Results:
* 1 if blocks where allocated, 0 otherwise.
*
* Side effects:
* Cache may be filled with available blocks.
*
*----------------------------------------------------------------------
*/
static int
GetBlocks(Cache *cachePtr, int bucket)
{
register Block *blockPtr;
register int n;
register size_t size;
/*
* First, atttempt to move blocks from the shared cache. Note
* the potentially dirty read of nfree before acquiring the lock
* which is a slight performance enhancement. The value is
* verified after the lock is actually acquired.
*/
if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].nfree > 0) {
LockBucket(cachePtr, bucket);
if (sharedPtr->buckets[bucket].nfree > 0) {
/*
* Either move the entire list or walk the list to find
* the last block to move.
*/
n = binfo[bucket].nmove;
if (n >= sharedPtr->buckets[bucket].nfree) {
cachePtr->buckets[bucket].firstPtr =
sharedPtr->buckets[bucket].firstPtr;
cachePtr->buckets[bucket].nfree =
sharedPtr->buckets[bucket].nfree;
sharedPtr->buckets[bucket].firstPtr = NULL;
sharedPtr->buckets[bucket].nfree = 0;
} else {
blockPtr = sharedPtr->buckets[bucket].firstPtr;
cachePtr->buckets[bucket].firstPtr = blockPtr;
sharedPtr->buckets[bucket].nfree -= n;
cachePtr->buckets[bucket].nfree = n;
while (--n > 0) {
blockPtr = blockPtr->b_next;
}
sharedPtr->buckets[bucket].firstPtr = blockPtr->b_next;
blockPtr->b_next = NULL;
}
}
UnlockBucket(cachePtr, bucket);
}
if (cachePtr->buckets[bucket].nfree == 0) {
/*
* If no blocks could be moved from shared, first look for a
* larger block in this cache to split up.
*/
blockPtr = NULL;
n = NBUCKETS;
size = 0; /* lint */
while (--n > bucket) {
if (cachePtr->buckets[n].nfree > 0) {
size = binfo[n].blocksize;
blockPtr = cachePtr->buckets[n].firstPtr;
cachePtr->buckets[n].firstPtr = blockPtr->b_next;
--cachePtr->buckets[n].nfree;
break;
}
}
/*
* Otherwise, allocate a big new block directly.
*/
if (blockPtr == NULL) {
size = MAXALLOC;
blockPtr = malloc(size);
if (blockPtr == NULL) {
return 0;
}
}
/*
* Split the larger block into smaller blocks for this bucket.
*/
n = size / binfo[bucket].blocksize;
cachePtr->buckets[bucket].nfree = n;
cachePtr->buckets[bucket].firstPtr = blockPtr;
while (--n > 0) {
blockPtr->b_next = (Block *)
((char *) blockPtr + binfo[bucket].blocksize);
blockPtr = blockPtr->b_next;
}
blockPtr->b_next = NULL;
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeThreadAlloc --
*
* This procedure is used to destroy all private resources used in
* this file.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadAlloc()
{
unsigned int i;
for (i = 0; i < NBUCKETS; ++i) {
TclpFreeAllocMutex(binfo[i].lockPtr);
binfo[i].lockPtr = NULL;
}
TclpFreeAllocMutex(objLockPtr);
objLockPtr = NULL;
TclpFreeAllocMutex(listLockPtr);
listLockPtr = NULL;
TclpFreeAllocCache(NULL);
}
#else /* ! defined(TCL_THREADS) && ! defined(USE_THREAD_ALLOC) */
/*
*----------------------------------------------------------------------
*
* TclFinalizeThreadAlloc --
*
* This procedure is used to destroy all private resources used in
* this file.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadAlloc()
{
Tcl_Panic("TclFinalizeThreadAlloc called when threaded memory allocator not in use.");
}
#endif /* TCL_THREADS */
tcl8.4.20/generic/tclIOGT.c 0000644 0036047 0045461 00000116041 12052456744 013746 0 ustar dgp 771div /*
* tclIOGT.c --
*
* Implements a generic transformation exposing the underlying API
* at the script level. Contributed by Andreas Kupries.
*
* Copyright (c) 2000 Ajuba Solutions
* Copyright (c) 1999-2000 Andreas Kupries (a.kupries@westend.com)
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclIO.h"
/*
* Forward declarations of internal procedures.
* First the driver procedures of the transformation.
*/
static int TransformBlockModeProc _ANSI_ARGS_ ((
ClientData instanceData, int mode));
static int TransformCloseProc _ANSI_ARGS_ ((
ClientData instanceData, Tcl_Interp* interp));
static int TransformInputProc _ANSI_ARGS_ ((
ClientData instanceData,
char* buf, int toRead, int* errorCodePtr));
static int TransformOutputProc _ANSI_ARGS_ ((
ClientData instanceData, CONST char *buf,
int toWrite, int* errorCodePtr));
static int TransformSeekProc _ANSI_ARGS_ ((
ClientData instanceData, long offset,
int mode, int* errorCodePtr));
static int TransformSetOptionProc _ANSI_ARGS_((
ClientData instanceData, Tcl_Interp *interp,
CONST char *optionName, CONST char *value));
static int TransformGetOptionProc _ANSI_ARGS_((
ClientData instanceData, Tcl_Interp *interp,
CONST char *optionName, Tcl_DString *dsPtr));
static void TransformWatchProc _ANSI_ARGS_ ((
ClientData instanceData, int mask));
static int TransformGetFileHandleProc _ANSI_ARGS_ ((
ClientData instanceData, int direction,
ClientData* handlePtr));
static int TransformNotifyProc _ANSI_ARGS_ ((
ClientData instanceData, int mask));
static Tcl_WideInt TransformWideSeekProc _ANSI_ARGS_ ((
ClientData instanceData, Tcl_WideInt offset,
int mode, int* errorCodePtr));
/*
* Forward declarations of internal procedures.
* Secondly the procedures for handling and generating fileeevents.
*/
static void TransformChannelHandlerTimer _ANSI_ARGS_ ((
ClientData clientData));
/*
* Forward declarations of internal procedures.
* Third, helper procedures encapsulating essential tasks.
*/
typedef struct TransformChannelData TransformChannelData;
static int ExecuteCallback _ANSI_ARGS_ ((
TransformChannelData* ctrl, Tcl_Interp* interp,
unsigned char* op, unsigned char* buf,
int bufLen, int transmit, int preserve));
/*
* Action codes to give to 'ExecuteCallback' (argument 'transmit')
* confering to the procedure what to do with the result of the script
* it calls.
*/
#define TRANSMIT_DONT (0) /* No transfer to do */
#define TRANSMIT_DOWN (1) /* Transfer to the underlying channel */
#define TRANSMIT_SELF (2) /* Transfer into our channel. */
#define TRANSMIT_IBUF (3) /* Transfer to internal input buffer */
#define TRANSMIT_NUM (4) /* Transfer number to 'maxRead' */
/*
* Codes for 'preserve' of 'ExecuteCallback'
*/
#define P_PRESERVE (1)
#define P_NO_PRESERVE (0)
/*
* Strings for the action codes delivered to the script implementing
* a transformation. Argument 'op' of 'ExecuteCallback'.
*/
#define A_CREATE_WRITE (UCHARP ("create/write"))
#define A_DELETE_WRITE (UCHARP ("delete/write"))
#define A_FLUSH_WRITE (UCHARP ("flush/write"))
#define A_WRITE (UCHARP ("write"))
#define A_CREATE_READ (UCHARP ("create/read"))
#define A_DELETE_READ (UCHARP ("delete/read"))
#define A_FLUSH_READ (UCHARP ("flush/read"))
#define A_READ (UCHARP ("read"))
#define A_QUERY_MAXREAD (UCHARP ("query/maxRead"))
#define A_CLEAR_READ (UCHARP ("clear/read"))
/*
* Management of a simple buffer.
*/
typedef struct ResultBuffer ResultBuffer;
static void ResultClear _ANSI_ARGS_ ((ResultBuffer* r));
static void ResultInit _ANSI_ARGS_ ((ResultBuffer* r));
static int ResultLength _ANSI_ARGS_ ((ResultBuffer* r));
static int ResultCopy _ANSI_ARGS_ ((ResultBuffer* r,
unsigned char* buf, int toRead));
static void ResultAdd _ANSI_ARGS_ ((ResultBuffer* r,
unsigned char* buf, int toWrite));
/*
* This structure describes the channel type structure for tcl based
* transformations.
*/
static Tcl_ChannelType transformChannelType = {
"transform", /* Type name. */
TCL_CHANNEL_VERSION_3,
TransformCloseProc, /* Close proc. */
TransformInputProc, /* Input proc. */
TransformOutputProc, /* Output proc. */
TransformSeekProc, /* Seek proc. */
TransformSetOptionProc, /* Set option proc. */
TransformGetOptionProc, /* Get option proc. */
TransformWatchProc, /* Initialize notifier. */
TransformGetFileHandleProc, /* Get OS handles out of channel. */
NULL, /* close2proc */
TransformBlockModeProc, /* Set blocking/nonblocking mode.*/
NULL, /* Flush proc. */
TransformNotifyProc, /* Handling of events bubbling up */
TransformWideSeekProc, /* Wide seek proc */
NULL
};
/*
* Possible values for 'flags' field in control structure, see below.
*/
#define CHANNEL_ASYNC (1<<0) /* non-blocking mode */
/*
* Definition of the structure containing the information about the
* internal input buffer.
*/
struct ResultBuffer {
unsigned char* buf; /* Reference to the buffer area */
int allocated; /* Allocated size of the buffer area */
int used; /* Number of bytes in the buffer, <= allocated */
};
/*
* Additional bytes to allocate during buffer expansion
*/
#define INCREMENT (512)
/*
* Number of milliseconds to wait before firing an event to flush
* out information waiting in buffers (fileevent support).
*/
#define FLUSH_DELAY (5)
/*
* Convenience macro to make some casts easier to use.
*/
#define UCHARP(x) ((unsigned char*) (x))
#define NO_INTERP ((Tcl_Interp*) NULL)
/*
* Definition of a structure used by all transformations generated here to
* maintain their local state.
*/
struct TransformChannelData {
/*
* General section. Data to integrate the transformation into the channel
* system.
*/
Tcl_Channel self; /* Our own Channel handle */
int readIsFlushed; /* Flag to note wether in.flushProc was called or not
*/
int flags; /* Currently CHANNEL_ASYNC or zero */
int watchMask; /* Current watch/event/interest mask */
int mode; /* mode of parent channel, OR'ed combination of
* TCL_READABLE, TCL_WRITABLE */
Tcl_TimerToken timer; /* Timer for automatic flushing of information
* sitting in an internal buffer. Required for full
* fileevent support */
/*
* Transformation specific data.
*/
int maxRead; /* Maximum allowed number of bytes to read, as
* given to us by the tcl script implementing the
* transformation. */
Tcl_Interp* interp; /* Reference to the interpreter which created the
* transformation. Used to execute the code
* below. */
Tcl_Obj* command; /* Tcl code to execute for a buffer */
ResultBuffer result; /* Internal buffer used to store the result of a
* transformation of incoming data. Additionally
* serves as buffer of all data not yet consumed by
* the reader. */
};
/*
*----------------------------------------------------------------------
*
* TclChannelTransform --
*
* Implements the Tcl "testchannel transform" debugging command.
* This is part of the testing environment. This sets up a tcl
* script (cmdObjPtr) to be used as a transform on the channel.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
TclChannelTransform(interp, chan, cmdObjPtr)
Tcl_Interp *interp; /* Interpreter for result. */
Tcl_Channel chan; /* Channel to transform. */
Tcl_Obj *cmdObjPtr; /* Script to use for transform. */
{
Channel *chanPtr; /* The actual channel. */
ChannelState *statePtr; /* state info for channel */
int mode; /* rw mode of the channel */
TransformChannelData *dataPtr;
int res;
Tcl_DString ds;
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
chan = (Tcl_Channel) chanPtr;
mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE));
/*
* Now initialize the transformation state and stack it upon the
* specified channel. One of the necessary things to do is to
* retrieve the blocking regime of the underlying channel and to
* use the same for us too.
*/
dataPtr = (TransformChannelData*) ckalloc(sizeof(TransformChannelData));
Tcl_DStringInit (&ds);
Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
dataPtr->readIsFlushed = 0;
dataPtr->flags = 0;
if (ds.string[0] == '0') {
dataPtr->flags |= CHANNEL_ASYNC;
}
Tcl_DStringFree (&ds);
dataPtr->self = chan;
dataPtr->watchMask = 0;
dataPtr->mode = mode;
dataPtr->timer = (Tcl_TimerToken) NULL;
dataPtr->maxRead = 4096; /* Initial value not relevant */
dataPtr->interp = interp;
dataPtr->command = cmdObjPtr;
Tcl_IncrRefCount(dataPtr->command);
ResultInit(&dataPtr->result);
dataPtr->self = Tcl_StackChannel(interp, &transformChannelType,
(ClientData) dataPtr, mode, chan);
if (dataPtr->self == (Tcl_Channel) NULL) {
Tcl_AppendResult(interp, "\nfailed to stack channel \"",
Tcl_GetChannelName(chan), "\"", (char *) NULL);
Tcl_DecrRefCount(dataPtr->command);
ResultClear(&dataPtr->result);
ckfree((VOID *) dataPtr);
return TCL_ERROR;
}
/*
* At last initialize the transformation at the script level.
*/
if (dataPtr->mode & TCL_WRITABLE) {
res = ExecuteCallback (dataPtr, NO_INTERP, A_CREATE_WRITE,
NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE);
if (res != TCL_OK) {
Tcl_UnstackChannel(interp, chan);
return TCL_ERROR;
}
}
if (dataPtr->mode & TCL_READABLE) {
res = ExecuteCallback (dataPtr, NO_INTERP, A_CREATE_READ,
NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE);
if (res != TCL_OK) {
ExecuteCallback (dataPtr, NO_INTERP, A_DELETE_WRITE,
NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE);
Tcl_UnstackChannel(interp, chan);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*------------------------------------------------------*
*
* ExecuteCallback --
*
* Executes the defined callback for buffer and
* operation.
*
* Sideeffects:
* As of the executed tcl script.
*
* Result:
* A standard TCL error code. In case of an
* error a message is left in the result area
* of the specified interpreter.
*
*------------------------------------------------------*
*/
static int
ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve)
TransformChannelData* dataPtr; /* Transformation with the callback */
Tcl_Interp* interp; /* Current interpreter, possibly NULL */
unsigned char* op; /* Operation invoking the callback */
unsigned char* buf; /* Buffer to give to the script. */
int bufLen; /* Ands its length */
int transmit; /* Flag, determines whether the result
* of the callback is sent to the
* underlying channel or not. */
int preserve; /* Flag. If true the procedure will
* preserver the result state of all
* accessed interpreters. */
{
/*
* Step 1, create the complete command to execute. Do this by appending
* operation and buffer to operate upon to a copy of the callback
* definition. We *cannot* create a list containing 3 objects and then use
* 'Tcl_EvalObjv', because the command may contain additional prefixed
* arguments. Feather's curried commands would come in handy here.
*/
Tcl_Obj* resObj; /* See below, switch (transmit) */
int resLen;
unsigned char* resBuf;
Tcl_SavedResult ciSave;
int res = TCL_OK;
Tcl_Obj* command = Tcl_DuplicateObj (dataPtr->command);
Tcl_Obj* temp;
if (preserve) {
Tcl_SaveResult (dataPtr->interp, &ciSave);
}
if (command == (Tcl_Obj*) NULL) {
/* Memory allocation problem */
res = TCL_ERROR;
goto cleanup;
}
Tcl_IncrRefCount(command);
temp = Tcl_NewStringObj((char*) op, -1);
if (temp == (Tcl_Obj*) NULL) {
/* Memory allocation problem */
res = TCL_ERROR;
goto cleanup;
}
res = Tcl_ListObjAppendElement(dataPtr->interp, command, temp);
if (res != TCL_OK)
goto cleanup;
/*
* Use a byte-array to prevent the misinterpretation of binary data
* coming through as UTF while at the tcl level.
*/
temp = Tcl_NewByteArrayObj(buf, bufLen);
if (temp == (Tcl_Obj*) NULL) {
/* Memory allocation problem */
res = TCL_ERROR;
goto cleanup;
}
res = Tcl_ListObjAppendElement (dataPtr->interp, command, temp);
if (res != TCL_OK)
goto cleanup;
/*
* Step 2, execute the command at the global level of the interpreter
* used to create the transformation. Destroy the command afterward.
* If an error occured and the current interpreter is defined and not
* equal to the interpreter for the callback, then copy the error
* message into current interpreter. Don't copy if in preservation mode.
*/
res = Tcl_EvalObjEx(dataPtr->interp, command, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount (command);
command = (Tcl_Obj*) NULL;
if ((res != TCL_OK) && (interp != NO_INTERP) &&
(dataPtr->interp != interp) && !preserve) {
Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp));
return res;
}
/*
* Step 3, transmit a possible conversion result to the underlying
* channel, or ourselves.
*/
switch (transmit) {
case TRANSMIT_DONT:
/* nothing to do */
break;
case TRANSMIT_DOWN:
resObj = Tcl_GetObjResult(dataPtr->interp);
resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen);
Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self),
(char*) resBuf, resLen);
break;
case TRANSMIT_SELF:
resObj = Tcl_GetObjResult (dataPtr->interp);
resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen);
Tcl_WriteRaw(dataPtr->self, (char*) resBuf, resLen);
break;
case TRANSMIT_IBUF:
resObj = Tcl_GetObjResult (dataPtr->interp);
resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen);
ResultAdd(&dataPtr->result, resBuf, resLen);
break;
case TRANSMIT_NUM:
/* Interpret result as integer number */
resObj = Tcl_GetObjResult (dataPtr->interp);
Tcl_GetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead);
break;
}
Tcl_ResetResult(dataPtr->interp);
if (preserve) {
Tcl_RestoreResult(dataPtr->interp, &ciSave);
}
return res;
cleanup:
if (preserve) {
Tcl_RestoreResult(dataPtr->interp, &ciSave);
}
if (command != (Tcl_Obj*) NULL) {
Tcl_DecrRefCount(command);
}
return res;
}
/*
*------------------------------------------------------*
*
* TransformBlockModeProc --
*
* Trap handler. Called by the generic IO system
* during option processing to change the blocking
* mode of the channel.
*
* Sideeffects:
* Forwards the request to the underlying
* channel.
*
* Result:
* 0 if successful, errno when failed.
*
*------------------------------------------------------*
*/
static int
TransformBlockModeProc (instanceData, mode)
ClientData instanceData; /* State of transformation */
int mode; /* New blocking mode */
{
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
dataPtr->flags |= CHANNEL_ASYNC;
} else {
dataPtr->flags &= ~(CHANNEL_ASYNC);
}
return 0;
}
/*
*------------------------------------------------------*
*
* TransformCloseProc --
*
* Trap handler. Called by the generic IO system
* during destruction of the transformation channel.
*
* Sideeffects:
* Releases the memory allocated in
* 'Tcl_TransformObjCmd'.
*
* Result:
* None.
*
*------------------------------------------------------*
*/
static int
TransformCloseProc (instanceData, interp)
ClientData instanceData;
Tcl_Interp* interp;
{
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
/*
* Important: In this procedure 'dataPtr->self' already points to
* the underlying channel.
*/
/*
* There is no need to cancel an existing channel handler, this is already
* done. Either by 'Tcl_UnstackChannel' or by the general cleanup in
* 'Tcl_Close'.
*
* But we have to cancel an active timer to prevent it from firing on the
* removed channel.
*/
if (dataPtr->timer != (Tcl_TimerToken) NULL) {
Tcl_DeleteTimerHandler (dataPtr->timer);
dataPtr->timer = (Tcl_TimerToken) NULL;
}
/*
* Now flush data waiting in internal buffers to output and input. The
* input must be done despite the fact that there is no real receiver
* for it anymore. But the scripts might have sideeffects other parts
* of the system rely on (f.e. signaling the close to interested parties).
*/
if (dataPtr->mode & TCL_WRITABLE) {
ExecuteCallback (dataPtr, interp, A_FLUSH_WRITE,
NULL, 0, TRANSMIT_DOWN, 1);
}
if ((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) {
dataPtr->readIsFlushed = 1;
ExecuteCallback (dataPtr, interp, A_FLUSH_READ,
NULL, 0, TRANSMIT_IBUF, 1);
}
if (dataPtr->mode & TCL_WRITABLE) {
ExecuteCallback (dataPtr, interp, A_DELETE_WRITE,
NULL, 0, TRANSMIT_DONT, 1);
}
if (dataPtr->mode & TCL_READABLE) {
ExecuteCallback (dataPtr, interp, A_DELETE_READ,
NULL, 0, TRANSMIT_DONT, 1);
}
/*
* General cleanup
*/
ResultClear(&dataPtr->result);
Tcl_DecrRefCount(dataPtr->command);
ckfree((VOID*) dataPtr);
return TCL_OK;
}
/*
*------------------------------------------------------*
*
* TransformInputProc --
*
* Called by the generic IO system to convert read data.
*
* Sideeffects:
* As defined by the conversion.
*
* Result:
* A transformed buffer.
*
*------------------------------------------------------*
*/
static int
TransformInputProc (instanceData, buf, toRead, errorCodePtr)
ClientData instanceData;
char* buf;
int toRead;
int* errorCodePtr;
{
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
int gotBytes, read, res, copied;
Tcl_Channel downChan;
/* should assert (dataPtr->mode & TCL_READABLE) */
if (toRead == 0) {
/* Catch a no-op.
*/
return 0;
}
gotBytes = 0;
downChan = Tcl_GetStackedChannel(dataPtr->self);
while (toRead > 0) {
/*
* Loop until the request is satisfied (or no data is available from
* below, possibly EOF).
*/
copied = ResultCopy (&dataPtr->result, UCHARP (buf), toRead);
toRead -= copied;
buf += copied;
gotBytes += copied;
if (toRead == 0) {
/* The request was completely satisfied from our buffers.
* We can break out of the loop and return to the caller.
*/
return gotBytes;
}
/*
* Length (dataPtr->result) == 0, toRead > 0 here . Use the incoming
* 'buf'! as target to store the intermediary information read
* from the underlying channel.
*
* Ask the tcl level how much data it allows us to read from
* the underlying channel. This feature allows the transform to
* signal EOF upstream although there is none downstream. Useful
* to control an unbounded 'fcopy', either through counting bytes,
* or by pattern matching.
*/
ExecuteCallback (dataPtr, NO_INTERP, A_QUERY_MAXREAD,
NULL, 0, TRANSMIT_NUM /* -> maxRead */, 1);
if (dataPtr->maxRead >= 0) {
if (dataPtr->maxRead < toRead) {
toRead = dataPtr->maxRead;
}
} /* else: 'maxRead < 0' == Accept the current value of toRead */
if (toRead <= 0) {
return gotBytes;
}
read = Tcl_ReadRaw(downChan, buf, toRead);
if (read < 0) {
/* Report errors to caller. EAGAIN is a special situation.
* If we had some data before we report that instead of the
* request to re-try.
*/
if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) {
return gotBytes;
}
*errorCodePtr = Tcl_GetErrno();
return -1;
}
if (read == 0) {
/*
* Check wether we hit on EOF in the underlying channel or
* not. If not differentiate between blocking and
* non-blocking modes. In non-blocking mode we ran
* temporarily out of data. Signal this to the caller via
* EWOULDBLOCK and error return (-1). In the other cases
* we simply return what we got and let the caller wait
* for more. On the other hand, if we got an EOF we have
* to convert and flush all waiting partial data.
*/
if (! Tcl_Eof (downChan)) {
if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) {
*errorCodePtr = EWOULDBLOCK;
return -1;
} else {
return gotBytes;
}
} else {
if (dataPtr->readIsFlushed) {
/* Already flushed, nothing to do anymore
*/
return gotBytes;
}
dataPtr->readIsFlushed = 1;
ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_READ,
NULL, 0, TRANSMIT_IBUF, P_PRESERVE);
if (ResultLength (&dataPtr->result) == 0) {
/* we had nothing to flush */
return gotBytes;
}
continue; /* at: while (toRead > 0) */
}
} /* read == 0 */
/* Transform the read chunk and add the result to our
* read buffer (dataPtr->result)
*/
res = ExecuteCallback (dataPtr, NO_INTERP, A_READ,
UCHARP (buf), read, TRANSMIT_IBUF, P_PRESERVE);
if (res != TCL_OK) {
*errorCodePtr = EINVAL;
return -1;
}
} /* while toRead > 0 */
return gotBytes;
}
/*
*------------------------------------------------------*
*
* TransformOutputProc --
*
* Called by the generic IO system to convert data
* waiting to be written.
*
* Sideeffects:
* As defined by the transformation.
*
* Result:
* A transformed buffer.
*
*------------------------------------------------------*
*/
static int
TransformOutputProc (instanceData, buf, toWrite, errorCodePtr)
ClientData instanceData;
CONST char* buf;
int toWrite;
int* errorCodePtr;
{
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
int res;
/* should assert (dataPtr->mode & TCL_WRITABLE) */
if (toWrite == 0) {
/* Catch a no-op.
*/
return 0;
}
res = ExecuteCallback (dataPtr, NO_INTERP, A_WRITE,
UCHARP (buf), toWrite,
TRANSMIT_DOWN, P_NO_PRESERVE);
if (res != TCL_OK) {
*errorCodePtr = EINVAL;
return -1;
}
return toWrite;
}
/*
*------------------------------------------------------*
*
* TransformSeekProc --
*
* This procedure is called by the generic IO level
* to move the access point in a channel.
*
* Sideeffects:
* Moves the location at which the channel
* will be accessed in future operations.
* Flushes all transformation buffers, then
* forwards it to the underlying channel.
*
* Result:
* -1 if failed, the new position if
* successful. An output argument contains
* the POSIX error code if an error
* occurred, or zero.
*
*------------------------------------------------------*
*/
static int
TransformSeekProc (instanceData, offset, mode, errorCodePtr)
ClientData instanceData; /* The channel to manipulate */
long offset; /* Size of movement. */
int mode; /* How to move */
int* errorCodePtr; /* Location of error flag. */
{
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
Tcl_ChannelType* parentType = Tcl_GetChannelType(parent);
Tcl_DriverSeekProc* parentSeekProc = Tcl_ChannelSeekProc(parentType);
if ((offset == 0) && (mode == SEEK_CUR)) {
/* This is no seek but a request to tell the caller the current
* location. Simply pass the request down.
*/
return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent),
offset, mode, errorCodePtr);
}
/*
* It is a real request to change the position. Flush all data waiting
* for output and discard everything in the input buffers. Then pass
* the request down, unchanged.
*/
if (dataPtr->mode & TCL_WRITABLE) {
ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_WRITE,
NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE);
}
if (dataPtr->mode & TCL_READABLE) {
ExecuteCallback (dataPtr, NO_INTERP, A_CLEAR_READ,
NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE);
ResultClear(&dataPtr->result);
dataPtr->readIsFlushed = 0;
}
return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent),
offset, mode, errorCodePtr);
}
/*
*----------------------------------------------------------------------
*
* TransformWideSeekProc --
*
* This procedure is called by the generic IO level to move the
* access point in a channel, with a (potentially) 64-bit offset.
*
* Side effects:
* Moves the location at which the channel will be accessed in
* future operations. Flushes all transformation buffers, then
* forwards it to the underlying channel.
*
* Result:
* -1 if failed, the new position if successful. An output
* argument contains the POSIX error code if an error occurred,
* or zero.
*
*----------------------------------------------------------------------
*/
static Tcl_WideInt
TransformWideSeekProc (instanceData, offset, mode, errorCodePtr)
ClientData instanceData; /* The channel to manipulate */
Tcl_WideInt offset; /* Size of movement. */
int mode; /* How to move */
int* errorCodePtr; /* Location of error flag. */
{
TransformChannelData* dataPtr =
(TransformChannelData*) instanceData;
Tcl_Channel parent =
Tcl_GetStackedChannel(dataPtr->self);
Tcl_ChannelType* parentType =
Tcl_GetChannelType(parent);
Tcl_DriverSeekProc* parentSeekProc =
Tcl_ChannelSeekProc(parentType);
Tcl_DriverWideSeekProc* parentWideSeekProc =
Tcl_ChannelWideSeekProc(parentType);
ClientData parentData =
Tcl_GetChannelInstanceData(parent);
if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) {
/*
* This is no seek but a request to tell the caller the current
* location. Simply pass the request down.
*/
if (parentWideSeekProc != NULL) {
return (*parentWideSeekProc) (parentData, offset, mode,
errorCodePtr);
}
return Tcl_LongAsWide((*parentSeekProc) (parentData, 0, mode,
errorCodePtr));
}
/*
* It is a real request to change the position. Flush all data waiting
* for output and discard everything in the input buffers. Then pass
* the request down, unchanged.
*/
if (dataPtr->mode & TCL_WRITABLE) {
ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_WRITE,
NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE);
}
if (dataPtr->mode & TCL_READABLE) {
ExecuteCallback (dataPtr, NO_INTERP, A_CLEAR_READ,
NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE);
ResultClear(&dataPtr->result);
dataPtr->readIsFlushed = 0;
}
/*
* If we have a wide seek capability, we should stick with that.
*/
if (parentWideSeekProc != NULL) {
return (*parentWideSeekProc) (parentData, offset, mode, errorCodePtr);
}
/*
* We're transferring to narrow seeks at this point; this is a bit
* complex because we have to check whether the seek is possible
* first (i.e. whether we are losing information in truncating the
* bits of the offset.) Luckily, there's a defined error for what
* happens when trying to go out of the representable range.
*/
if (offsetTcl_LongAsWide(LONG_MAX)) {
*errorCodePtr = EOVERFLOW;
return Tcl_LongAsWide(-1);
}
return Tcl_LongAsWide((*parentSeekProc) (parentData,
Tcl_WideAsLong(offset), mode, errorCodePtr));
}
/*
*------------------------------------------------------*
*
* TransformSetOptionProc --
*
* Called by generic layer to handle the reconfi-
* guration of channel specific options. As this
* channel type does not have such, it simply passes
* all requests downstream.
*
* Sideeffects:
* As defined by the channel downstream.
*
* Result:
* A standard TCL error code.
*
*------------------------------------------------------*
*/
static int
TransformSetOptionProc (instanceData, interp, optionName, value)
ClientData instanceData;
Tcl_Interp *interp;
CONST char *optionName;
CONST char *value;
{
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
Tcl_DriverSetOptionProc *setOptionProc;
setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));
if (setOptionProc != NULL) {
return (*setOptionProc)(Tcl_GetChannelInstanceData(downChan),
interp, optionName, value);
}
return TCL_ERROR;
}
/*
*------------------------------------------------------*
*
* TransformGetOptionProc --
*
* Called by generic layer to handle requests for
* the values of channel specific options. As this
* channel type does not have such, it simply passes
* all requests downstream.
*
* Sideeffects:
* As defined by the channel downstream.
*
* Result:
* A standard TCL error code.
*
*------------------------------------------------------*
*/
static int
TransformGetOptionProc (instanceData, interp, optionName, dsPtr)
ClientData instanceData;
Tcl_Interp* interp;
CONST char* optionName;
Tcl_DString* dsPtr;
{
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
Tcl_DriverGetOptionProc *getOptionProc;
getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
if (getOptionProc != NULL) {
return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan),
interp, optionName, dsPtr);
} else if (optionName == (CONST char*) NULL) {
/*
* Request is query for all options, this is ok.
*/
return TCL_OK;
}
/*
* Request for a specific option has to fail, we don't have any.
*/
return TCL_ERROR;
}
/*
*------------------------------------------------------*
*
* TransformWatchProc --
*
* Initialize the notifier to watch for events from
* this channel.
*
* Sideeffects:
* Sets up the notifier so that a future
* event on the channel will be seen by Tcl.
*
* Result:
* None.
*
*------------------------------------------------------*
*/
/* ARGSUSED */
static void
TransformWatchProc (instanceData, mask)
ClientData instanceData; /* Channel to watch */
int mask; /* Events of interest */
{
/* The caller expressed interest in events occuring for this
* channel. We are forwarding the call to the underlying
* channel now.
*/
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
Tcl_Channel downChan;
dataPtr->watchMask = mask;
/* No channel handlers any more. We will be notified automatically
* about events on the channel below via a call to our
* 'TransformNotifyProc'. But we have to pass the interest down now.
* We are allowed to add additional 'interest' to the mask if we want
* to. But this transformation has no such interest. It just passes
* the request down, unchanged.
*/
downChan = Tcl_GetStackedChannel(dataPtr->self);
(Tcl_GetChannelType(downChan))
->watchProc(Tcl_GetChannelInstanceData(downChan), mask);
/*
* Management of the internal timer.
*/
if ((dataPtr->timer != (Tcl_TimerToken) NULL) &&
(!(mask & TCL_READABLE) || (ResultLength(&dataPtr->result) == 0))) {
/* A pending timer exists, but either is there no (more)
* interest in the events it generates or nothing is availablee
* for reading, so remove it.
*/
Tcl_DeleteTimerHandler (dataPtr->timer);
dataPtr->timer = (Tcl_TimerToken) NULL;
}
if ((dataPtr->timer == (Tcl_TimerToken) NULL) &&
(mask & TCL_READABLE) && (ResultLength (&dataPtr->result) > 0)) {
/* There is no pending timer, but there is interest in readable
* events and we actually have data waiting, so generate a timer
* to flush that.
*/
dataPtr->timer = Tcl_CreateTimerHandler (FLUSH_DELAY,
TransformChannelHandlerTimer, (ClientData) dataPtr);
}
}
/*
*------------------------------------------------------*
*
* TransformGetFileHandleProc --
*
* Called from Tcl_GetChannelHandle to retrieve
* OS specific file handle from inside this channel.
*
* Sideeffects:
* None.
*
* Result:
* The appropriate Tcl_File or NULL if not
* present.
*
*------------------------------------------------------*
*/
static int
TransformGetFileHandleProc (instanceData, direction, handlePtr)
ClientData instanceData; /* Channel to query */
int direction; /* Direction of interest */
ClientData* handlePtr; /* Place to store the handle into */
{
/*
* Return the handle belonging to parent channel.
* IOW, pass the request down and the result up.
*/
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
return Tcl_GetChannelHandle(Tcl_GetStackedChannel(dataPtr->self),
direction, handlePtr);
}
/*
*------------------------------------------------------*
*
* TransformNotifyProc --
*
* ------------------------------------------------*
* Handler called by Tcl to inform us of activity
* on the underlying channel.
* ------------------------------------------------*
*
* Sideeffects:
* May process the incoming event by itself.
*
* Result:
* None.
*
*------------------------------------------------------*
*/
static int
TransformNotifyProc (clientData, mask)
ClientData clientData; /* The state of the notified transformation */
int mask; /* The mask of occuring events */
{
TransformChannelData* dataPtr = (TransformChannelData*) clientData;
/*
* An event occured in the underlying channel. This
* transformation doesn't process such events thus returns the
* incoming mask unchanged.
*/
if (dataPtr->timer != (Tcl_TimerToken) NULL) {
/*
* Delete an existing timer. It was not fired, yet we are
* here, so the channel below generated such an event and we
* don't have to. The renewal of the interest after the
* execution of channel handlers will eventually cause us to
* recreate the timer (in TransformWatchProc).
*/
Tcl_DeleteTimerHandler (dataPtr->timer);
dataPtr->timer = (Tcl_TimerToken) NULL;
}
return mask;
}
/*
*------------------------------------------------------*
*
* TransformChannelHandlerTimer --
*
* Called by the notifier (-> timer) to flush out
* information waiting in the input buffer.
*
* Sideeffects:
* As of 'Tcl_NotifyChannel'.
*
* Result:
* None.
*
*------------------------------------------------------*
*/
static void
TransformChannelHandlerTimer (clientData)
ClientData clientData; /* Transformation to query */
{
TransformChannelData* dataPtr = (TransformChannelData*) clientData;
dataPtr->timer = (Tcl_TimerToken) NULL;
if (!(dataPtr->watchMask & TCL_READABLE) ||
(ResultLength (&dataPtr->result) == 0)) {
/* The timer fired, but either is there no (more)
* interest in the events it generates or nothing is available
* for reading, so ignore it and don't recreate it.
*/
return;
}
Tcl_NotifyChannel(dataPtr->self, TCL_READABLE);
}
/*
*------------------------------------------------------*
*
* ResultClear --
*
* Deallocates any memory allocated by 'ResultAdd'.
*
* Sideeffects:
* See above.
*
* Result:
* None.
*
*------------------------------------------------------*
*/
static void
ResultClear (r)
ResultBuffer* r; /* Reference to the buffer to clear out */
{
r->used = 0;
if (r->allocated) {
ckfree((char*) r->buf);
r->buf = UCHARP (NULL);
r->allocated = 0;
}
}
/*
*------------------------------------------------------*
*
* ResultInit --
*
* Initializes the specified buffer structure. The
* structure will contain valid information for an
* emtpy buffer.
*
* Sideeffects:
* See above.
*
* Result:
* None.
*
*------------------------------------------------------*
*/
static void
ResultInit (r)
ResultBuffer* r; /* Reference to the structure to initialize */
{
r->used = 0;
r->allocated = 0;
r->buf = UCHARP (NULL);
}
/*
*------------------------------------------------------*
*
* ResultLength --
*
* Returns the number of bytes stored in the buffer.
*
* Sideeffects:
* None.
*
* Result:
* An integer, see above too.
*
*------------------------------------------------------*
*/
static int
ResultLength (r)
ResultBuffer* r; /* The structure to query */
{
return r->used;
}
/*
*------------------------------------------------------*
*
* ResultCopy --
*
* Copies the requested number of bytes from the
* buffer into the specified array and removes them
* from the buffer afterward. Copies less if there
* is not enough data in the buffer.
*
* Sideeffects:
* See above.
*
* Result:
* The number of actually copied bytes,
* possibly less than 'toRead'.
*
*------------------------------------------------------*
*/
static int
ResultCopy (r, buf, toRead)
ResultBuffer* r; /* The buffer to read from */
unsigned char* buf; /* The buffer to copy into */
int toRead; /* Number of requested bytes */
{
if (r->used == 0) {
/* Nothing to copy in the case of an empty buffer.
*/
return 0;
}
if (r->used == toRead) {
/* We have just enough. Copy everything to the caller.
*/
memcpy ((VOID*) buf, (VOID*) r->buf, (size_t) toRead);
r->used = 0;
return toRead;
}
if (r->used > toRead) {
/* The internal buffer contains more than requested.
* Copy the requested subset to the caller, and shift
* the remaining bytes down.
*/
memcpy ((VOID*) buf, (VOID*) r->buf, (size_t) toRead);
memmove ((VOID*) r->buf, (VOID*) (r->buf + toRead),
(size_t) r->used - toRead);
r->used -= toRead;
return toRead;
}
/* There is not enough in the buffer to satisfy the caller, so
* take everything.
*/
memcpy((VOID*) buf, (VOID*) r->buf, (size_t) r->used);
toRead = r->used;
r->used = 0;
return toRead;
}
/*
*------------------------------------------------------*
*
* ResultAdd --
*
* Adds the bytes in the specified array to the
* buffer, by appending it.
*
* Sideeffects:
* See above.
*
* Result:
* None.
*
*------------------------------------------------------*
*/
static void
ResultAdd (r, buf, toWrite)
ResultBuffer* r; /* The buffer to extend */
unsigned char* buf; /* The buffer to read from */
int toWrite; /* The number of bytes in 'buf' */
{
if ((r->used + toWrite) > r->allocated) {
/* Extension of the internal buffer is required.
*/
if (r->allocated == 0) {
r->allocated = toWrite + INCREMENT;
r->buf = UCHARP (ckalloc((unsigned) r->allocated));
} else {
r->allocated += toWrite + INCREMENT;
r->buf = UCHARP (ckrealloc((char*) r->buf,
(unsigned) r->allocated));
}
}
/* now copy data */
memcpy(r->buf + r->used, buf, (size_t) toWrite);
r->used += toWrite;
}
tcl8.4.20/generic/tclTimer.c 0000644 0036047 0045461 00000100246 11737050674 014265 0 ustar dgp 771div /*
* tclTimer.c --
*
* This file provides timer event management facilities for Tcl,
* including the "after" command.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* For each timer callback that's pending there is one record of the following
* type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
* together in a list sorted by time (earliest event first).
*/
typedef struct TimerHandler {
Tcl_Time time; /* When timer is to fire. */
Tcl_TimerProc *proc; /* Procedure to call. */
ClientData clientData; /* Argument to pass to proc. */
Tcl_TimerToken token; /* Identifies handler so it can be
* deleted. */
struct TimerHandler *nextPtr; /* Next event in queue, or NULL for
* end of queue. */
} TimerHandler;
/*
* The data structure below is used by the "after" command to remember
* the command to be executed later. All of the pending "after" commands
* for an interpreter are linked together in a list.
*/
typedef struct AfterInfo {
struct AfterAssocData *assocPtr;
/* Pointer to the "tclAfter" assocData for
* the interp in which command will be
* executed. */
Tcl_Obj *commandPtr; /* Command to execute. */
int id; /* Integer identifier for command; used to
* cancel it. */
Tcl_TimerToken token; /* Used to cancel the "after" command. NULL
* means that the command is run as an
* idle handler rather than as a timer
* handler. NULL means this is an "after
* idle" handler rather than a
* timer handler. */
struct AfterInfo *nextPtr; /* Next in list of all "after" commands for
* this interpreter. */
} AfterInfo;
/*
* One of the following structures is associated with each interpreter
* for which an "after" command has ever been invoked. A pointer to
* this structure is stored in the AssocData for the "tclAfter" key.
*/
typedef struct AfterAssocData {
Tcl_Interp *interp; /* The interpreter for which this data is
* registered. */
AfterInfo *firstAfterPtr; /* First in list of all "after" commands
* still pending for this interpreter, or
* NULL if none. */
} AfterAssocData;
/*
* There is one of the following structures for each of the
* handlers declared in a call to Tcl_DoWhenIdle. All of the
* currently-active handlers are linked together into a list.
*/
typedef struct IdleHandler {
Tcl_IdleProc (*proc); /* Procedure to call. */
ClientData clientData; /* Value to pass to proc. */
int generation; /* Used to distinguish older handlers from
* recently-created ones. */
struct IdleHandler *nextPtr;/* Next in list of active handlers. */
} IdleHandler;
/*
* The timer and idle queues are per-thread because they are associated
* with the notifier, which is also per-thread.
*
* All static variables used in this file are collected into a single
* instance of the following structure. For multi-threaded implementations,
* there is one instance of this structure for each thread.
*
* Notice that different structures with the same name appear in other
* files. The structure defined below is used in this file only.
*/
typedef struct ThreadSpecificData {
TimerHandler *firstTimerHandlerPtr; /* First event in queue. */
int lastTimerId; /* Timer identifier of most recently
* created timer. */
int timerPending; /* 1 if a timer event is in the queue. */
IdleHandler *idleList; /* First in list of all idle handlers. */
IdleHandler *lastIdlePtr; /* Last in list (or NULL for empty list). */
int idleGeneration; /* Used to fill in the "generation" fields
* of IdleHandler structures. Increments
* each time Tcl_DoOneEvent starts calling
* idle handlers, so that all old handlers
* can be called without calling any of the
* new ones created by old ones. */
int afterId; /* For unique identifiers of after events. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Prototypes for procedures referenced only in this file:
*/
static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp));
static void AfterProc _ANSI_ARGS_((ClientData clientData));
static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr));
static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr,
Tcl_Obj *commandPtr));
static ThreadSpecificData *InitTimer _ANSI_ARGS_((void));
static void TimerExitProc _ANSI_ARGS_((ClientData clientData));
static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
int flags));
static void TimerCheckProc _ANSI_ARGS_((ClientData clientData,
int flags));
static void TimerSetupProc _ANSI_ARGS_((ClientData clientData,
int flags));
/*
*----------------------------------------------------------------------
*
* InitTimer --
*
* This function initializes the timer module.
*
* Results:
* A pointer to the thread specific data.
*
* Side effects:
* Registers the idle and timer event sources.
*
*----------------------------------------------------------------------
*/
static ThreadSpecificData *
InitTimer()
{
ThreadSpecificData *tsdPtr =
(ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL);
Tcl_CreateThreadExitHandler(TimerExitProc, NULL);
}
return tsdPtr;
}
/*
*----------------------------------------------------------------------
*
* TimerExitProc --
*
* This function is call at exit or unload time to remove the
* timer and idle event sources.
*
* Results:
* None.
*
* Side effects:
* Removes the timer and idle event sources and remaining events.
*
*----------------------------------------------------------------------
*/
static void
TimerExitProc(clientData)
ClientData clientData; /* Not used. */
{
ThreadSpecificData *tsdPtr =
(ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
if (tsdPtr != NULL) {
register TimerHandler *timerHandlerPtr;
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
while (timerHandlerPtr != NULL) {
tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
ckfree((char *) timerHandlerPtr);
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
}
}
}
/*
*--------------------------------------------------------------
*
* Tcl_CreateTimerHandler --
*
* Arrange for a given procedure to be invoked at a particular
* time in the future.
*
* Results:
* The return value is a token for the timer event, which
* may be used to delete the event before it fires.
*
* Side effects:
* When milliseconds have elapsed, proc will be invoked
* exactly once.
*
*--------------------------------------------------------------
*/
Tcl_TimerToken
Tcl_CreateTimerHandler(milliseconds, proc, clientData)
int milliseconds; /* How many milliseconds to wait
* before invoking proc. */
Tcl_TimerProc *proc; /* Procedure to invoke. */
ClientData clientData; /* Arbitrary data to pass to proc. */
{
register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
Tcl_Time time;
ThreadSpecificData *tsdPtr;
tsdPtr = InitTimer();
timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
/*
* Compute when the event should fire.
*/
Tcl_GetTime(&time);
timerHandlerPtr->time.sec = time.sec + milliseconds/1000;
timerHandlerPtr->time.usec = time.usec + (milliseconds%1000)*1000;
if (timerHandlerPtr->time.usec >= 1000000) {
timerHandlerPtr->time.usec -= 1000000;
timerHandlerPtr->time.sec += 1;
}
/*
* Fill in other fields for the event.
*/
timerHandlerPtr->proc = proc;
timerHandlerPtr->clientData = clientData;
tsdPtr->lastTimerId++;
timerHandlerPtr->token = (Tcl_TimerToken) tsdPtr->lastTimerId;
/*
* Add the event to the queue in the correct position
* (ordered by event firing time).
*/
for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
if ((tPtr2->time.sec > timerHandlerPtr->time.sec)
|| ((tPtr2->time.sec == timerHandlerPtr->time.sec)
&& (tPtr2->time.usec > timerHandlerPtr->time.usec))) {
break;
}
}
timerHandlerPtr->nextPtr = tPtr2;
if (prevPtr == NULL) {
tsdPtr->firstTimerHandlerPtr = timerHandlerPtr;
} else {
prevPtr->nextPtr = timerHandlerPtr;
}
TimerSetupProc(NULL, TCL_ALL_EVENTS);
return timerHandlerPtr->token;
}
/*
*--------------------------------------------------------------
*
* Tcl_DeleteTimerHandler --
*
* Delete a previously-registered timer handler.
*
* Results:
* None.
*
* Side effects:
* Destroy the timer callback identified by TimerToken,
* so that its associated procedure will not be called.
* If the callback has already fired, or if the given
* token doesn't exist, then nothing happens.
*
*--------------------------------------------------------------
*/
void
Tcl_DeleteTimerHandler(token)
Tcl_TimerToken token; /* Result previously returned by
* Tcl_DeleteTimerHandler. */
{
register TimerHandler *timerHandlerPtr, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
if (token == NULL) {
return;
}
for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL;
timerHandlerPtr != NULL; prevPtr = timerHandlerPtr,
timerHandlerPtr = timerHandlerPtr->nextPtr) {
if (timerHandlerPtr->token != token) {
continue;
}
if (prevPtr == NULL) {
tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
} else {
prevPtr->nextPtr = timerHandlerPtr->nextPtr;
}
ckfree((char *) timerHandlerPtr);
return;
}
}
/*
*----------------------------------------------------------------------
*
* TimerSetupProc --
*
* This function is called by Tcl_DoOneEvent to setup the timer
* event source for before blocking. This routine checks both the
* idle and after timer lists.
*
* Results:
* None.
*
* Side effects:
* May update the maximum notifier block time.
*
*----------------------------------------------------------------------
*/
static void
TimerSetupProc(data, flags)
ClientData data; /* Not used. */
int flags; /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
if (((flags & TCL_IDLE_EVENTS) && tsdPtr->idleList)
|| ((flags & TCL_TIMER_EVENTS) && tsdPtr->timerPending)) {
/*
* There is an idle handler or a pending timer event, so just poll.
*/
blockTime.sec = 0;
blockTime.usec = 0;
} else if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
/*
* Compute the timeout for the next timer on the list.
*/
Tcl_GetTime(&blockTime);
blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec;
blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec -
blockTime.usec;
if (blockTime.usec < 0) {
blockTime.sec -= 1;
blockTime.usec += 1000000;
}
if (blockTime.sec < 0) {
blockTime.sec = 0;
blockTime.usec = 0;
}
} else {
return;
}
Tcl_SetMaxBlockTime(&blockTime);
}
/*
*----------------------------------------------------------------------
*
* TimerCheckProc --
*
* This function is called by Tcl_DoOneEvent to check the timer
* event source for events. This routine checks both the
* idle and after timer lists.
*
* Results:
* None.
*
* Side effects:
* May queue an event and update the maximum notifier block time.
*
*----------------------------------------------------------------------
*/
static void
TimerCheckProc(data, flags)
ClientData data; /* Not used. */
int flags; /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Event *timerEvPtr;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
/*
* Compute the timeout for the next timer on the list.
*/
Tcl_GetTime(&blockTime);
blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec;
blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec -
blockTime.usec;
if (blockTime.usec < 0) {
blockTime.sec -= 1;
blockTime.usec += 1000000;
}
if (blockTime.sec < 0) {
blockTime.sec = 0;
blockTime.usec = 0;
}
/*
* If the first timer has expired, stick an event on the queue.
*/
if (blockTime.sec == 0 && blockTime.usec == 0 &&
!tsdPtr->timerPending) {
tsdPtr->timerPending = 1;
timerEvPtr = (Tcl_Event *) ckalloc(sizeof(Tcl_Event));
timerEvPtr->proc = TimerHandlerEventProc;
Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
}
}
}
/*
*----------------------------------------------------------------------
*
* TimerHandlerEventProc --
*
* This procedure is called by Tcl_ServiceEvent when a timer event
* reaches the front of the event queue. This procedure handles
* the event by invoking the callbacks for all timers that are
* ready.
*
* Results:
* Returns 1 if the event was handled, meaning it should be removed
* from the queue. Returns 0 if the event was not handled, meaning
* it should stay on the queue. The only time the event isn't
* handled is if the TCL_TIMER_EVENTS flag bit isn't set.
*
* Side effects:
* Whatever the timer handler callback procedures do.
*
*----------------------------------------------------------------------
*/
static int
TimerHandlerEventProc(evPtr, flags)
Tcl_Event *evPtr; /* Event to service. */
int flags; /* Flags that indicate what events to
* handle, such as TCL_FILE_EVENTS. */
{
TimerHandler *timerHandlerPtr, **nextPtrPtr;
Tcl_Time time;
int currentTimerId;
ThreadSpecificData *tsdPtr = InitTimer();
/*
* Do nothing if timers aren't enabled. This leaves the event on the
* queue, so we will get to it as soon as ServiceEvents() is called
* with timers enabled.
*/
if (!(flags & TCL_TIMER_EVENTS)) {
return 0;
}
/*
* The code below is trickier than it may look, for the following
* reasons:
*
* 1. New handlers can get added to the list while the current
* one is being processed. If new ones get added, we don't
* want to process them during this pass through the list to avoid
* starving other event sources. This is implemented using the
* token number in the handler: new handlers will have a
* newer token than any of the ones currently on the list.
* 2. The handler can call Tcl_DoOneEvent, so we have to remove
* the handler from the list before calling it. Otherwise an
* infinite loop could result.
* 3. Tcl_DeleteTimerHandler can be called to remove an element from
* the list while a handler is executing, so the list could
* change structure during the call.
* 4. Because we only fetch the current time before entering the loop,
* the only way a new timer will even be considered runnable is if
* its expiration time is within the same millisecond as the
* current time. This is fairly likely on Windows, since it has
* a course granularity clock. Since timers are placed
* on the queue in time order with the most recently created
* handler appearing after earlier ones with the same expiration
* time, we don't have to worry about newer generation timers
* appearing before later ones.
*/
tsdPtr->timerPending = 0;
currentTimerId = tsdPtr->lastTimerId;
Tcl_GetTime(&time);
while (1) {
nextPtrPtr = &tsdPtr->firstTimerHandlerPtr;
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
if (timerHandlerPtr == NULL) {
break;
}
if ((timerHandlerPtr->time.sec > time.sec)
|| ((timerHandlerPtr->time.sec == time.sec)
&& (timerHandlerPtr->time.usec > time.usec))) {
break;
}
/*
* Bail out if the next timer is of a newer generation.
*/
if ((currentTimerId - (int)timerHandlerPtr->token) < 0) {
break;
}
/*
* Remove the handler from the queue before invoking it,
* to avoid potential reentrancy problems.
*/
(*nextPtrPtr) = timerHandlerPtr->nextPtr;
(*timerHandlerPtr->proc)(timerHandlerPtr->clientData);
ckfree((char *) timerHandlerPtr);
}
TimerSetupProc(NULL, TCL_TIMER_EVENTS);
return 1;
}
/*
*--------------------------------------------------------------
*
* Tcl_DoWhenIdle --
*
* Arrange for proc to be invoked the next time the system is
* idle (i.e., just before the next time that Tcl_DoOneEvent
* would have to wait for something to happen).
*
* Results:
* None.
*
* Side effects:
* Proc will eventually be called, with clientData as argument.
* See the manual entry for details.
*
*--------------------------------------------------------------
*/
void
Tcl_DoWhenIdle(proc, clientData)
Tcl_IdleProc *proc; /* Procedure to invoke. */
ClientData clientData; /* Arbitrary value to pass to proc. */
{
register IdleHandler *idlePtr;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));
idlePtr->proc = proc;
idlePtr->clientData = clientData;
idlePtr->generation = tsdPtr->idleGeneration;
idlePtr->nextPtr = NULL;
if (tsdPtr->lastIdlePtr == NULL) {
tsdPtr->idleList = idlePtr;
} else {
tsdPtr->lastIdlePtr->nextPtr = idlePtr;
}
tsdPtr->lastIdlePtr = idlePtr;
blockTime.sec = 0;
blockTime.usec = 0;
Tcl_SetMaxBlockTime(&blockTime);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CancelIdleCall --
*
* If there are any when-idle calls requested to a given procedure
* with given clientData, cancel all of them.
*
* Results:
* None.
*
* Side effects:
* If the proc/clientData combination were on the when-idle list,
* they are removed so that they will never be called.
*
*----------------------------------------------------------------------
*/
void
Tcl_CancelIdleCall(proc, clientData)
Tcl_IdleProc *proc; /* Procedure that was previously registered. */
ClientData clientData; /* Arbitrary value to pass to proc. */
{
register IdleHandler *idlePtr, *prevPtr;
IdleHandler *nextPtr;
ThreadSpecificData *tsdPtr = InitTimer();
for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL;
prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) {
while ((idlePtr->proc == proc)
&& (idlePtr->clientData == clientData)) {
nextPtr = idlePtr->nextPtr;
ckfree((char *) idlePtr);
idlePtr = nextPtr;
if (prevPtr == NULL) {
tsdPtr->idleList = idlePtr;
} else {
prevPtr->nextPtr = idlePtr;
}
if (idlePtr == NULL) {
tsdPtr->lastIdlePtr = prevPtr;
return;
}
}
}
}
/*
*----------------------------------------------------------------------
*
* TclServiceIdle --
*
* This procedure is invoked by the notifier when it becomes
* idle. It will invoke all idle handlers that are present at
* the time the call is invoked, but not those added during idle
* processing.
*
* Results:
* The return value is 1 if TclServiceIdle found something to
* do, otherwise return value is 0.
*
* Side effects:
* Invokes all pending idle handlers.
*
*----------------------------------------------------------------------
*/
int
TclServiceIdle()
{
IdleHandler *idlePtr;
int oldGeneration;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
if (tsdPtr->idleList == NULL) {
return 0;
}
oldGeneration = tsdPtr->idleGeneration;
tsdPtr->idleGeneration++;
/*
* The code below is trickier than it may look, for the following
* reasons:
*
* 1. New handlers can get added to the list while the current
* one is being processed. If new ones get added, we don't
* want to process them during this pass through the list (want
* to check for other work to do first). This is implemented
* using the generation number in the handler: new handlers
* will have a different generation than any of the ones currently
* on the list.
* 2. The handler can call Tcl_DoOneEvent, so we have to remove
* the handler from the list before calling it. Otherwise an
* infinite loop could result.
* 3. Tcl_CancelIdleCall can be called to remove an element from
* the list while a handler is executing, so the list could
* change structure during the call.
*/
for (idlePtr = tsdPtr->idleList;
((idlePtr != NULL)
&& ((oldGeneration - idlePtr->generation) >= 0));
idlePtr = tsdPtr->idleList) {
tsdPtr->idleList = idlePtr->nextPtr;
if (tsdPtr->idleList == NULL) {
tsdPtr->lastIdlePtr = NULL;
}
(*idlePtr->proc)(idlePtr->clientData);
ckfree((char *) idlePtr);
}
if (tsdPtr->idleList) {
blockTime.sec = 0;
blockTime.usec = 0;
Tcl_SetMaxBlockTime(&blockTime);
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AfterObjCmd --
*
* This procedure is invoked to process the "after" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_AfterObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Unused */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int ms;
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
char *argString;
int index;
char buf[16 + TCL_INTEGER_SPACE];
static CONST char *afterSubCmds[] = {
"cancel", "idle", "info", (char *) NULL
};
enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
/*
* Create the "after" information associated for this interpreter,
* if it doesn't already exist.
*/
assocPtr = Tcl_GetAssocData( interp, "tclAfter", NULL );
if (assocPtr == NULL) {
assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc,
(ClientData) assocPtr);
}
/*
* First lets see if the command was passed a number as the first argument.
*/
if (objv[1]->typePtr == &tclIntType) {
ms = (int) objv[1]->internalRep.longValue;
goto processInteger;
}
argString = Tcl_GetStringFromObj(objv[1], &length);
if (argString[0] == '+' || argString[0] == '-'
|| isdigit(UCHAR(argString[0]))) { /* INTL: digit */
if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
return TCL_ERROR;
}
processInteger:
if (ms < 0) {
ms = 0;
}
if (objc == 2) {
Tcl_Sleep(ms);
return TCL_OK;
}
afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
/*
* The variable below is used to generate unique identifiers for
* after commands. This id can wrap around, which can potentially
* cause problems. However, there are not likely to be problems
* in practice, because after commands can only be requested to
* about a month in the future, and wrap-around is unlikely to
* occur in less than about 1-10 years. Thus it's unlikely that
* any old ids will still be around when wrap-around occurs.
*/
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
(ClientData) afterPtr);
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
sprintf(buf, "after#%d", afterPtr->id);
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
/*
* If it's not a number it must be a subcommand.
*/
if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument",
0, &index) != TCL_OK) {
Tcl_AppendResult(interp, "bad argument \"", argString,
"\": must be cancel, idle, info, or a number",
(char *) NULL);
return TCL_ERROR;
}
switch ((enum afterSubCmds) index) {
case AFTER_CANCEL: {
Tcl_Obj *commandPtr;
char *command, *tempCommand;
int tempLength;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "id|command");
return TCL_ERROR;
}
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
}
command = Tcl_GetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
&& (memcmp((void*) command, (void*) tempCommand,
(unsigned) length) == 0)) {
break;
}
}
if (afterPtr == NULL) {
afterPtr = GetAfterEvent(assocPtr, commandPtr);
}
if (objc != 3) {
Tcl_DecrRefCount(commandPtr);
}
if (afterPtr != NULL) {
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
} else {
Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
}
FreeAfterPtr(afterPtr);
}
break;
}
case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script script ...");
return TCL_ERROR;
}
afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
afterPtr->token = NULL;
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
sprintf(buf, "after#%d", afterPtr->id);
Tcl_AppendResult(interp, buf, (char *) NULL);
break;
case AFTER_INFO: {
Tcl_Obj *resultListPtr;
if (objc == 2) {
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
if (assocPtr->interp == interp) {
sprintf(buf, "after#%d", afterPtr->id);
Tcl_AppendElement(interp, buf);
}
}
return TCL_OK;
}
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?id?");
return TCL_ERROR;
}
afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]),
"\" doesn't exist", (char *) NULL);
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(afterPtr->token == NULL) ? "idle" : "timer", -1));
Tcl_SetObjResult(interp, resultListPtr);
break;
}
default: {
panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetAfterEvent --
*
* This procedure parses an "after" id such as "after#4" and
* returns a pointer to the AfterInfo structure.
*
* Results:
* The return value is either a pointer to an AfterInfo structure,
* if one is found that corresponds to "cmdString" and is for interp,
* or NULL if no corresponding after event can be found.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static AfterInfo *
GetAfterEvent(assocPtr, commandPtr)
AfterAssocData *assocPtr; /* Points to "after"-related information for
* this interpreter. */
Tcl_Obj *commandPtr;
{
char *cmdString; /* Textual identifier for after event, such
* as "after#6". */
AfterInfo *afterPtr;
int id;
char *end;
cmdString = Tcl_GetString(commandPtr);
if (strncmp(cmdString, "after#", 6) != 0) {
return NULL;
}
cmdString += 6;
id = strtoul(cmdString, &end, 10);
if ((end == cmdString) || (*end != 0)) {
return NULL;
}
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
if (afterPtr->id == id) {
return afterPtr;
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* AfterProc --
*
* Timer callback to execute commands registered with the
* "after" command.
*
* Results:
* None.
*
* Side effects:
* Executes whatever command was specified. If the command
* returns an error, then the command "bgerror" is invoked
* to process the error; if bgerror fails then information
* about the error is output on stderr.
*
*----------------------------------------------------------------------
*/
static void
AfterProc(clientData)
ClientData clientData; /* Describes command to execute. */
{
AfterInfo *afterPtr = (AfterInfo *) clientData;
AfterAssocData *assocPtr = afterPtr->assocPtr;
AfterInfo *prevPtr;
int result;
Tcl_Interp *interp;
char *script;
int numBytes;
/*
* First remove the callback from our list of callbacks; otherwise
* someone could delete the callback while it's being executed, which
* could cause a core dump.
*/
if (assocPtr->firstAfterPtr == afterPtr) {
assocPtr->firstAfterPtr = afterPtr->nextPtr;
} else {
for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
prevPtr = prevPtr->nextPtr) {
/* Empty loop body. */
}
prevPtr->nextPtr = afterPtr->nextPtr;
}
/*
* Execute the callback.
*/
interp = assocPtr->interp;
Tcl_Preserve((ClientData) interp);
script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes);
result = Tcl_EvalEx(interp, script, numBytes, TCL_EVAL_GLOBAL);
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (\"after\" script)");
Tcl_BackgroundError(interp);
}
Tcl_Release((ClientData) interp);
/*
* Free the memory for the callback.
*/
Tcl_DecrRefCount(afterPtr->commandPtr);
ckfree((char *) afterPtr);
}
/*
*----------------------------------------------------------------------
*
* FreeAfterPtr --
*
* This procedure removes an "after" command from the list of
* those that are pending and frees its resources. This procedure
* does *not* cancel the timer handler; if that's needed, the
* caller must do it.
*
* Results:
* None.
*
* Side effects:
* The memory associated with afterPtr is released.
*
*----------------------------------------------------------------------
*/
static void
FreeAfterPtr(afterPtr)
AfterInfo *afterPtr; /* Command to be deleted. */
{
AfterInfo *prevPtr;
AfterAssocData *assocPtr = afterPtr->assocPtr;
if (assocPtr->firstAfterPtr == afterPtr) {
assocPtr->firstAfterPtr = afterPtr->nextPtr;
} else {
for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
prevPtr = prevPtr->nextPtr) {
/* Empty loop body. */
}
prevPtr->nextPtr = afterPtr->nextPtr;
}
Tcl_DecrRefCount(afterPtr->commandPtr);
ckfree((char *) afterPtr);
}
/*
*----------------------------------------------------------------------
*
* AfterCleanupProc --
*
* This procedure is invoked whenever an interpreter is deleted
* to cleanup the AssocData for "tclAfter".
*
* Results:
* None.
*
* Side effects:
* After commands are removed.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static void
AfterCleanupProc(clientData, interp)
ClientData clientData; /* Points to AfterAssocData for the
* interpreter. */
Tcl_Interp *interp; /* Interpreter that is being deleted. */
{
AfterAssocData *assocPtr = (AfterAssocData *) clientData;
AfterInfo *afterPtr;
while (assocPtr->firstAfterPtr != NULL) {
afterPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr->nextPtr;
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
} else {
Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
}
Tcl_DecrRefCount(afterPtr->commandPtr);
ckfree((char *) afterPtr);
}
ckfree((char *) assocPtr);
}
tcl8.4.20/generic/tclDecls.h 0000644 0036047 0045461 00000516506 12144442333 014244 0 ustar dgp 771div /*
* tclDecls.h --
*
* Declarations of functions in the platform independent public Tcl API.
*
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _TCLDECLS
#define _TCLDECLS
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
* script. Any modifications to the function declarations below should be made
* in the generic/tcl.decls script.
*/
/* !BEGIN!: Do not edit below this line. */
/*
* Exported function declarations:
*/
/* 0 */
EXTERN int Tcl_PkgProvideEx _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name, CONST char *version,
ClientData clientData));
/* 1 */
EXTERN CONST84_RETURN char * Tcl_PkgRequireEx _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *name,
CONST char *version, int exact,
ClientData *clientDataPtr));
/* 2 */
EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format));
/* 3 */
EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size));
/* 4 */
EXTERN void Tcl_Free _ANSI_ARGS_((char *ptr));
/* 5 */
EXTERN char * Tcl_Realloc _ANSI_ARGS_((char *ptr,
unsigned int size));
/* 6 */
EXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size,
CONST char *file, int line));
/* 7 */
EXTERN void Tcl_DbCkfree _ANSI_ARGS_((char *ptr,
CONST char *file, int line));
/* 8 */
EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char *ptr,
unsigned int size, CONST char *file,
int line));
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 9 */
EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_((int fd, int mask,
Tcl_FileProc *proc, ClientData clientData));
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 9 */
EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_((int fd, int mask,
Tcl_FileProc *proc, ClientData clientData));
#endif /* MACOSX */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 10 */
EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_((int fd));
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 10 */
EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_((int fd));
#endif /* MACOSX */
/* 11 */
EXTERN void Tcl_SetTimer _ANSI_ARGS_((Tcl_Time *timePtr));
/* 12 */
EXTERN void Tcl_Sleep _ANSI_ARGS_((int ms));
/* 13 */
EXTERN int Tcl_WaitForEvent _ANSI_ARGS_((Tcl_Time *timePtr));
/* 14 */
EXTERN int Tcl_AppendAllObjTypes _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr));
/* 15 */
EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr));
/* 16 */
EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj *objPtr,
CONST char *bytes, int length));
/* 17 */
EXTERN Tcl_Obj * Tcl_ConcatObj _ANSI_ARGS_((int objc,
Tcl_Obj *CONST objv[]));
/* 18 */
EXTERN int Tcl_ConvertToType _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_ObjType *typePtr));
/* 19 */
EXTERN void Tcl_DbDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr,
CONST char *file, int line));
/* 20 */
EXTERN void Tcl_DbIncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr,
CONST char *file, int line));
/* 21 */
EXTERN int Tcl_DbIsShared _ANSI_ARGS_((Tcl_Obj *objPtr,
CONST char *file, int line));
/* 22 */
EXTERN Tcl_Obj * Tcl_DbNewBooleanObj _ANSI_ARGS_((int boolValue,
CONST char *file, int line));
/* 23 */
EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj _ANSI_ARGS_((
CONST unsigned char *bytes, int length,
CONST char *file, int line));
/* 24 */
EXTERN Tcl_Obj * Tcl_DbNewDoubleObj _ANSI_ARGS_((double doubleValue,
CONST char *file, int line));
/* 25 */
EXTERN Tcl_Obj * Tcl_DbNewListObj _ANSI_ARGS_((int objc,
Tcl_Obj *CONST *objv, CONST char *file,
int line));
/* 26 */
EXTERN Tcl_Obj * Tcl_DbNewLongObj _ANSI_ARGS_((long longValue,
CONST char *file, int line));
/* 27 */
EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((CONST char *file, int line));
/* 28 */
EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((CONST char *bytes,
int length, CONST char *file, int line));
/* 29 */
EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj *objPtr));
/* 30 */
EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj *objPtr));
/* 31 */
EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *src, int *boolPtr));
/* 32 */
EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr,
int *boolPtr));
/* 33 */
EXTERN unsigned char * Tcl_GetByteArrayFromObj _ANSI_ARGS_((Tcl_Obj *objPtr,
int *lengthPtr));
/* 34 */
EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *src, double *doublePtr));
/* 35 */
EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, double *doublePtr));
/* 36 */
EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, CONST84 char **tablePtr,
CONST char *msg, int flags, int *indexPtr));
/* 37 */
EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *src, int *intPtr));
/* 38 */
EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, int *intPtr));
/* 39 */
EXTERN int Tcl_GetLongFromObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, long *longPtr));
/* 40 */
EXTERN Tcl_ObjType * Tcl_GetObjType _ANSI_ARGS_((CONST char *typeName));
/* 41 */
EXTERN char * Tcl_GetStringFromObj _ANSI_ARGS_((Tcl_Obj *objPtr,
int *lengthPtr));
/* 42 */
EXTERN void Tcl_InvalidateStringRep _ANSI_ARGS_((Tcl_Obj *objPtr));
/* 43 */
EXTERN int Tcl_ListObjAppendList _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *elemListPtr));
/* 44 */
EXTERN int Tcl_ListObjAppendElement _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *objPtr));
/* 45 */
EXTERN int Tcl_ListObjGetElements _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *listPtr,
int *objcPtr, Tcl_Obj ***objvPtr));
/* 46 */
EXTERN int Tcl_ListObjIndex _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *listPtr, int index,
Tcl_Obj **objPtrPtr));
/* 47 */
EXTERN int Tcl_ListObjLength _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *listPtr, int *lengthPtr));
/* 48 */
EXTERN int Tcl_ListObjReplace _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *listPtr, int first, int count,
int objc, Tcl_Obj *CONST objv[]));
/* 49 */
EXTERN Tcl_Obj * Tcl_NewBooleanObj _ANSI_ARGS_((int boolValue));
/* 50 */
EXTERN Tcl_Obj * Tcl_NewByteArrayObj _ANSI_ARGS_((
CONST unsigned char *bytes, int length));
/* 51 */
EXTERN Tcl_Obj * Tcl_NewDoubleObj _ANSI_ARGS_((double doubleValue));
/* 52 */
EXTERN Tcl_Obj * Tcl_NewIntObj _ANSI_ARGS_((int intValue));
/* 53 */
EXTERN Tcl_Obj * Tcl_NewListObj _ANSI_ARGS_((int objc,
Tcl_Obj *CONST objv[]));
/* 54 */
EXTERN Tcl_Obj * Tcl_NewLongObj _ANSI_ARGS_((long longValue));
/* 55 */
EXTERN Tcl_Obj * Tcl_NewObj _ANSI_ARGS_((void));
/* 56 */
EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((CONST char *bytes,
int length));
/* 57 */
EXTERN void Tcl_SetBooleanObj _ANSI_ARGS_((Tcl_Obj *objPtr,
int boolValue));
/* 58 */
EXTERN unsigned char * Tcl_SetByteArrayLength _ANSI_ARGS_((Tcl_Obj *objPtr,
int length));
/* 59 */
EXTERN void Tcl_SetByteArrayObj _ANSI_ARGS_((Tcl_Obj *objPtr,
CONST unsigned char *bytes, int length));
/* 60 */
EXTERN void Tcl_SetDoubleObj _ANSI_ARGS_((Tcl_Obj *objPtr,
double doubleValue));
/* 61 */
EXTERN void Tcl_SetIntObj _ANSI_ARGS_((Tcl_Obj *objPtr,
int intValue));
/* 62 */
EXTERN void Tcl_SetListObj _ANSI_ARGS_((Tcl_Obj *objPtr,
int objc, Tcl_Obj *CONST objv[]));
/* 63 */
EXTERN void Tcl_SetLongObj _ANSI_ARGS_((Tcl_Obj *objPtr,
long longValue));
/* 64 */
EXTERN void Tcl_SetObjLength _ANSI_ARGS_((Tcl_Obj *objPtr,
int length));
/* 65 */
EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj *objPtr,
CONST char *bytes, int length));
/* 66 */
EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *message));
/* 67 */
EXTERN void Tcl_AddObjErrorInfo _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *message, int length));
/* 68 */
EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp *interp));
/* 69 */
EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *element));
/* 70 */
EXTERN void Tcl_AppendResult _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
/* 71 */
EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc *proc,
ClientData clientData));
/* 72 */
EXTERN void Tcl_AsyncDelete _ANSI_ARGS_((Tcl_AsyncHandler async));
/* 73 */
EXTERN int Tcl_AsyncInvoke _ANSI_ARGS_((Tcl_Interp *interp,
int code));
/* 74 */
EXTERN void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async));
/* 75 */
EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void));
/* 76 */
EXTERN void Tcl_BackgroundError _ANSI_ARGS_((Tcl_Interp *interp));
/* 77 */
EXTERN char Tcl_Backslash _ANSI_ARGS_((CONST char *src,
int *readPtr));
/* 78 */
EXTERN int Tcl_BadChannelOption _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *optionName,
CONST char *optionList));
/* 79 */
EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc,
ClientData clientData));
/* 80 */
EXTERN void Tcl_CancelIdleCall _ANSI_ARGS_((
Tcl_IdleProc *idleProc,
ClientData clientData));
/* 81 */
EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
/* 82 */
EXTERN int Tcl_CommandComplete _ANSI_ARGS_((CONST char *cmd));
/* 83 */
EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc,
CONST84 char *CONST *argv));
/* 84 */
EXTERN int Tcl_ConvertElement _ANSI_ARGS_((CONST char *src,
char *dst, int flags));
/* 85 */
EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_((
CONST char *src, int length, char *dst,
int flags));
/* 86 */
EXTERN int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp *slave,
CONST char *slaveCmd, Tcl_Interp *target,
CONST char *targetCmd, int argc,
CONST84 char *CONST *argv));
/* 87 */
EXTERN int Tcl_CreateAliasObj _ANSI_ARGS_((Tcl_Interp *slave,
CONST char *slaveCmd, Tcl_Interp *target,
CONST char *targetCmd, int objc,
Tcl_Obj *CONST objv[]));
/* 88 */
EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_((
Tcl_ChannelType *typePtr,
CONST char *chanName,
ClientData instanceData, int mask));
/* 89 */
EXTERN void Tcl_CreateChannelHandler _ANSI_ARGS_((
Tcl_Channel chan, int mask,
Tcl_ChannelProc *proc, ClientData clientData));
/* 90 */
EXTERN void Tcl_CreateCloseHandler _ANSI_ARGS_((Tcl_Channel chan,
Tcl_CloseProc *proc, ClientData clientData));
/* 91 */
EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *cmdName, Tcl_CmdProc *proc,
ClientData clientData,
Tcl_CmdDeleteProc *deleteProc));
/* 92 */
EXTERN void Tcl_CreateEventSource _ANSI_ARGS_((
Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc,
ClientData clientData));
/* 93 */
EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_((
Tcl_ExitProc *proc, ClientData clientData));
/* 94 */
EXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void));
/* 95 */
EXTERN void Tcl_CreateMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name, int numArgs,
Tcl_ValueType *argTypes, Tcl_MathProc *proc,
ClientData clientData));
/* 96 */
EXTERN Tcl_Command Tcl_CreateObjCommand _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *cmdName, Tcl_ObjCmdProc *proc,
ClientData clientData,
Tcl_CmdDeleteProc *deleteProc));
/* 97 */
EXTERN Tcl_Interp * Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *slaveName, int isSafe));
/* 98 */
EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds,
Tcl_TimerProc *proc, ClientData clientData));
/* 99 */
EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp *interp,
int level, Tcl_CmdTraceProc *proc,
ClientData clientData));
/* 100 */
EXTERN void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name));
/* 101 */
EXTERN void Tcl_DeleteChannelHandler _ANSI_ARGS_((
Tcl_Channel chan, Tcl_ChannelProc *proc,
ClientData clientData));
/* 102 */
EXTERN void Tcl_DeleteCloseHandler _ANSI_ARGS_((Tcl_Channel chan,
Tcl_CloseProc *proc, ClientData clientData));
/* 103 */
EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *cmdName));
/* 104 */
EXTERN int Tcl_DeleteCommandFromToken _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Command command));
/* 105 */
EXTERN void Tcl_DeleteEvents _ANSI_ARGS_((
Tcl_EventDeleteProc *proc,
ClientData clientData));
/* 106 */
EXTERN void Tcl_DeleteEventSource _ANSI_ARGS_((
Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc,
ClientData clientData));
/* 107 */
EXTERN void Tcl_DeleteExitHandler _ANSI_ARGS_((
Tcl_ExitProc *proc, ClientData clientData));
/* 108 */
EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_((
Tcl_HashEntry *entryPtr));
/* 109 */
EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_((
Tcl_HashTable *tablePtr));
/* 110 */
EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp *interp));
/* 111 */
EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids,
Tcl_Pid *pidPtr));
/* 112 */
EXTERN void Tcl_DeleteTimerHandler _ANSI_ARGS_((
Tcl_TimerToken token));
/* 113 */
EXTERN void Tcl_DeleteTrace _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Trace trace));
/* 114 */
EXTERN void Tcl_DontCallWhenDeleted _ANSI_ARGS_((
Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc,
ClientData clientData));
/* 115 */
EXTERN int Tcl_DoOneEvent _ANSI_ARGS_((int flags));
/* 116 */
EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc *proc,
ClientData clientData));
/* 117 */
EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString *dsPtr,
CONST char *bytes, int length));
/* 118 */
EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_((
Tcl_DString *dsPtr, CONST char *element));
/* 119 */
EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_((
Tcl_DString *dsPtr));
/* 120 */
EXTERN void Tcl_DStringFree _ANSI_ARGS_((Tcl_DString *dsPtr));
/* 121 */
EXTERN void Tcl_DStringGetResult _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_DString *dsPtr));
/* 122 */
EXTERN void Tcl_DStringInit _ANSI_ARGS_((Tcl_DString *dsPtr));
/* 123 */
EXTERN void Tcl_DStringResult _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_DString *dsPtr));
/* 124 */
EXTERN void Tcl_DStringSetLength _ANSI_ARGS_((Tcl_DString *dsPtr,
int length));
/* 125 */
EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_((
Tcl_DString *dsPtr));
/* 126 */
EXTERN int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan));
/* 127 */
EXTERN CONST84_RETURN char * Tcl_ErrnoId _ANSI_ARGS_((void));
/* 128 */
EXTERN CONST84_RETURN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err));
/* 129 */
EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *script));
/* 130 */
EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *fileName));
/* 131 */
EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
/* 132 */
EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((
ClientData clientData,
Tcl_FreeProc *freeProc));
/* 133 */
EXTERN void Tcl_Exit _ANSI_ARGS_((int status));
/* 134 */
EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *hiddenCmdToken,
CONST char *cmdName));
/* 135 */
EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *expr, int *ptr));
/* 136 */
EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, int *ptr));
/* 137 */
EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *expr, double *ptr));
/* 138 */
EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, double *ptr));
/* 139 */
EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *expr, long *ptr));
/* 140 */
EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, long *ptr));
/* 141 */
EXTERN int Tcl_ExprObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr));
/* 142 */
EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *expr));
/* 143 */
EXTERN void Tcl_Finalize _ANSI_ARGS_((void));
/* 144 */
EXTERN void Tcl_FindExecutable _ANSI_ARGS_((CONST char *argv0));
/* 145 */
EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_((
Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr));
/* 146 */
EXTERN int Tcl_Flush _ANSI_ARGS_((Tcl_Channel chan));
/* 147 */
EXTERN void Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp *interp));
/* 148 */
EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *slaveCmd,
Tcl_Interp **targetInterpPtr,
CONST84 char **targetCmdPtr, int *argcPtr,
CONST84 char ***argvPtr));
/* 149 */
EXTERN int Tcl_GetAliasObj _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *slaveCmd,
Tcl_Interp **targetInterpPtr,
CONST84 char **targetCmdPtr, int *objcPtr,
Tcl_Obj ***objv));
/* 150 */
EXTERN ClientData Tcl_GetAssocData _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name,
Tcl_InterpDeleteProc **procPtr));
/* 151 */
EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *chanName, int *modePtr));
/* 152 */
EXTERN int Tcl_GetChannelBufferSize _ANSI_ARGS_((
Tcl_Channel chan));
/* 153 */
EXTERN int Tcl_GetChannelHandle _ANSI_ARGS_((Tcl_Channel chan,
int direction, ClientData *handlePtr));
/* 154 */
EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_((
Tcl_Channel chan));
/* 155 */
EXTERN int Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan));
/* 156 */
EXTERN CONST84_RETURN char * Tcl_GetChannelName _ANSI_ARGS_((
Tcl_Channel chan));
/* 157 */
EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan, CONST char *optionName,
Tcl_DString *dsPtr));
/* 158 */
EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan));
/* 159 */
EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *cmdName, Tcl_CmdInfo *infoPtr));
/* 160 */
EXTERN CONST84_RETURN char * Tcl_GetCommandName _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Command command));
/* 161 */
EXTERN int Tcl_GetErrno _ANSI_ARGS_((void));
/* 162 */
EXTERN CONST84_RETURN char * Tcl_GetHostName _ANSI_ARGS_((void));
/* 163 */
EXTERN int Tcl_GetInterpPath _ANSI_ARGS_((Tcl_Interp *askInterp,
Tcl_Interp *slaveInterp));
/* 164 */
EXTERN Tcl_Interp * Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp));
/* 165 */
EXTERN CONST char * Tcl_GetNameOfExecutable _ANSI_ARGS_((void));
/* 166 */
EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp *interp));
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
/* 167 */
EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *chanID, int forWriting,
int checkUsage, ClientData *filePtr));
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 167 */
EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *chanID, int forWriting,
int checkUsage, ClientData *filePtr));
#endif /* MACOSX */
/* 168 */
EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((CONST char *path));
/* 169 */
EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan,
Tcl_DString *dsPtr));
/* 170 */
EXTERN int Tcl_GetsObj _ANSI_ARGS_((Tcl_Channel chan,
Tcl_Obj *objPtr));
/* 171 */
EXTERN int Tcl_GetServiceMode _ANSI_ARGS_((void));
/* 172 */
EXTERN Tcl_Interp * Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *slaveName));
/* 173 */
EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type));
/* 174 */
EXTERN CONST84_RETURN char * Tcl_GetStringResult _ANSI_ARGS_((
Tcl_Interp *interp));
/* 175 */
EXTERN CONST84_RETURN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName, int flags));
/* 176 */
EXTERN CONST84_RETURN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *part1, CONST char *part2,
int flags));
/* 177 */
EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *command));
/* 178 */
EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
/* 179 */
EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *cmdName,
CONST char *hiddenCmdToken));
/* 180 */
EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp));
/* 181 */
EXTERN void Tcl_InitHashTable _ANSI_ARGS_((
Tcl_HashTable *tablePtr, int keyType));
/* 182 */
EXTERN int Tcl_InputBlocked _ANSI_ARGS_((Tcl_Channel chan));
/* 183 */
EXTERN int Tcl_InputBuffered _ANSI_ARGS_((Tcl_Channel chan));
/* 184 */
EXTERN int Tcl_InterpDeleted _ANSI_ARGS_((Tcl_Interp *interp));
/* 185 */
EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp *interp));
/* 186 */
EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc,
CONST84 char *CONST *argv,
Tcl_DString *resultPtr));
/* 187 */
EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName, char *addr, int type));
/* Slot 188 is reserved */
/* 189 */
EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData handle,
int mode));
/* 190 */
EXTERN int Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp *interp));
/* 191 */
EXTERN Tcl_Channel Tcl_MakeTcpClientChannel _ANSI_ARGS_((
ClientData tcpSocket));
/* 192 */
EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc,
CONST84 char *CONST *argv));
/* 193 */
EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_((
Tcl_HashSearch *searchPtr));
/* 194 */
EXTERN void Tcl_NotifyChannel _ANSI_ARGS_((Tcl_Channel channel,
int mask));
/* 195 */
EXTERN Tcl_Obj * Tcl_ObjGetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
int flags));
/* 196 */
EXTERN Tcl_Obj * Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
Tcl_Obj *newValuePtr, int flags));
/* 197 */
EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_((
Tcl_Interp *interp, int argc,
CONST84 char **argv, int flags));
/* 198 */
EXTERN Tcl_Channel Tcl_OpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *fileName, CONST char *modeString,
int permissions));
/* 199 */
EXTERN Tcl_Channel Tcl_OpenTcpClient _ANSI_ARGS_((Tcl_Interp *interp,
int port, CONST char *address,
CONST char *myaddr, int myport, int async));
/* 200 */
EXTERN Tcl_Channel Tcl_OpenTcpServer _ANSI_ARGS_((Tcl_Interp *interp,
int port, CONST char *host,
Tcl_TcpAcceptProc *acceptProc,
ClientData callbackData));
/* 201 */
EXTERN void Tcl_Preserve _ANSI_ARGS_((ClientData data));
/* 202 */
EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp *interp,
double value, char *dst));
/* 203 */
EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char *assignment));
/* 204 */
EXTERN CONST84_RETURN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp *interp));
/* 205 */
EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event *evPtr,
Tcl_QueuePosition position));
/* 206 */
EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan, char *bufPtr,
int toRead));
/* 207 */
EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void));
/* 208 */
EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *cmd, int flags));
/* 209 */
EXTERN int Tcl_RecordAndEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *cmdPtr, int flags));
/* 210 */
EXTERN void Tcl_RegisterChannel _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
/* 211 */
EXTERN void Tcl_RegisterObjType _ANSI_ARGS_((
Tcl_ObjType *typePtr));
/* 212 */
EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *pattern));
/* 213 */
EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_RegExp regexp, CONST char *text,
CONST char *start));
/* 214 */
EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *text, CONST char *pattern));
/* 215 */
EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp,
int index, CONST84 char **startPtr,
CONST84 char **endPtr));
/* 216 */
EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData));
/* 217 */
EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp));
/* 218 */
EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char *src,
int *flagPtr));
/* 219 */
EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char *src,
int length, int *flagPtr));
/* 220 */
EXTERN int Tcl_SeekOld _ANSI_ARGS_((Tcl_Channel chan,
int offset, int mode));
/* 221 */
EXTERN int Tcl_ServiceAll _ANSI_ARGS_((void));
/* 222 */
EXTERN int Tcl_ServiceEvent _ANSI_ARGS_((int flags));
/* 223 */
EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name, Tcl_InterpDeleteProc *proc,
ClientData clientData));
/* 224 */
EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_((
Tcl_Channel chan, int sz));
/* 225 */
EXTERN int Tcl_SetChannelOption _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan, CONST char *optionName,
CONST char *newValue));
/* 226 */
EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *cmdName,
CONST Tcl_CmdInfo *infoPtr));
/* 227 */
EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err));
/* 228 */
EXTERN void Tcl_SetErrorCode _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
/* 229 */
EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time *timePtr));
/* 230 */
EXTERN void Tcl_SetPanicProc _ANSI_ARGS_((
Tcl_PanicProc *panicProc));
/* 231 */
EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_((
Tcl_Interp *interp, int depth));
/* 232 */
EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp *interp,
char *result, Tcl_FreeProc *freeProc));
/* 233 */
EXTERN int Tcl_SetServiceMode _ANSI_ARGS_((int mode));
/* 234 */
EXTERN void Tcl_SetObjErrorCode _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *errorObjPtr));
/* 235 */
EXTERN void Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *resultObjPtr));
/* 236 */
EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel,
int type));
/* 237 */
EXTERN CONST84_RETURN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName, CONST char *newValue,
int flags));
/* 238 */
EXTERN CONST84_RETURN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *part1, CONST char *part2,
CONST char *newValue, int flags));
/* 239 */
EXTERN CONST84_RETURN char * Tcl_SignalId _ANSI_ARGS_((int sig));
/* 240 */
EXTERN CONST84_RETURN char * Tcl_SignalMsg _ANSI_ARGS_((int sig));
/* 241 */
EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp *interp));
/* 242 */
EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *listStr, int *argcPtr,
CONST84 char ***argvPtr));
/* 243 */
EXTERN void Tcl_SplitPath _ANSI_ARGS_((CONST char *path,
int *argcPtr, CONST84 char ***argvPtr));
/* 244 */
EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc));
/* 245 */
EXTERN int Tcl_StringMatch _ANSI_ARGS_((CONST char *str,
CONST char *pattern));
/* 246 */
EXTERN int Tcl_TellOld _ANSI_ARGS_((Tcl_Channel chan));
/* 247 */
EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName, int flags,
Tcl_VarTraceProc *proc,
ClientData clientData));
/* 248 */
EXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *part1, CONST char *part2,
int flags, Tcl_VarTraceProc *proc,
ClientData clientData));
/* 249 */
EXTERN char * Tcl_TranslateFileName _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *name,
Tcl_DString *bufferPtr));
/* 250 */
EXTERN int Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan,
CONST char *str, int len, int atHead));
/* 251 */
EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName));
/* 252 */
EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Channel chan));
/* 253 */
EXTERN int Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName, int flags));
/* 254 */
EXTERN int Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *part1, CONST char *part2,
int flags));
/* 255 */
EXTERN void Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName, int flags,
Tcl_VarTraceProc *proc,
ClientData clientData));
/* 256 */
EXTERN void Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *part1, CONST char *part2,
int flags, Tcl_VarTraceProc *proc,
ClientData clientData));
/* 257 */
EXTERN void Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName));
/* 258 */
EXTERN int Tcl_UpVar _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *frameName, CONST char *varName,
CONST char *localName, int flags));
/* 259 */
EXTERN int Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *frameName, CONST char *part1,
CONST char *part2, CONST char *localName,
int flags));
/* 260 */
EXTERN int Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
/* 261 */
EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName, int flags,
Tcl_VarTraceProc *procPtr,
ClientData prevClientData));
/* 262 */
EXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *part1, CONST char *part2,
int flags, Tcl_VarTraceProc *procPtr,
ClientData prevClientData));
/* 263 */
EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan,
CONST char *s, int slen));
/* 264 */
EXTERN void Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[],
CONST char *message));
/* 265 */
EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((
CONST char *fileName));
/* 266 */
EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((CONST char *file,
int line));
/* 267 */
EXTERN void Tcl_AppendResultVA _ANSI_ARGS_((Tcl_Interp *interp,
va_list argList));
/* 268 */
EXTERN void Tcl_AppendStringsToObjVA _ANSI_ARGS_((
Tcl_Obj *objPtr, va_list argList));
/* 269 */
EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr));
/* 270 */
EXTERN CONST84_RETURN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *start, CONST84 char **termPtr));
/* 271 */
EXTERN CONST84_RETURN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name, CONST char *version,
int exact));
/* 272 */
EXTERN CONST84_RETURN char * Tcl_PkgPresentEx _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *name,
CONST char *version, int exact,
ClientData *clientDataPtr));
/* 273 */
EXTERN int Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name, CONST char *version));
/* 274 */
EXTERN CONST84_RETURN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name, CONST char *version,
int exact));
/* 275 */
EXTERN void Tcl_SetErrorCodeVA _ANSI_ARGS_((Tcl_Interp *interp,
va_list argList));
/* 276 */
EXTERN int Tcl_VarEvalVA _ANSI_ARGS_((Tcl_Interp *interp,
va_list argList));
/* 277 */
EXTERN Tcl_Pid Tcl_WaitPid _ANSI_ARGS_((Tcl_Pid pid, int *statPtr,
int options));
/* 278 */
EXTERN void Tcl_PanicVA _ANSI_ARGS_((CONST char *format,
va_list argList));
/* 279 */
EXTERN void Tcl_GetVersion _ANSI_ARGS_((int *major, int *minor,
int *patchLevel, int *type));
/* 280 */
EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp));
/* 281 */
EXTERN Tcl_Channel Tcl_StackChannel _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_ChannelType *typePtr,
ClientData instanceData, int mask,
Tcl_Channel prevChan));
/* 282 */
EXTERN int Tcl_UnstackChannel _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
/* 283 */
EXTERN Tcl_Channel Tcl_GetStackedChannel _ANSI_ARGS_((Tcl_Channel chan));
/* 284 */
EXTERN void Tcl_SetMainLoop _ANSI_ARGS_((Tcl_MainLoopProc *proc));
/* Slot 285 is reserved */
/* 286 */
EXTERN void Tcl_AppendObjToObj _ANSI_ARGS_((Tcl_Obj *objPtr,
Tcl_Obj *appendObjPtr));
/* 287 */
EXTERN Tcl_Encoding Tcl_CreateEncoding _ANSI_ARGS_((
Tcl_EncodingType *typePtr));
/* 288 */
EXTERN void Tcl_CreateThreadExitHandler _ANSI_ARGS_((
Tcl_ExitProc *proc, ClientData clientData));
/* 289 */
EXTERN void Tcl_DeleteThreadExitHandler _ANSI_ARGS_((
Tcl_ExitProc *proc, ClientData clientData));
/* 290 */
EXTERN void Tcl_DiscardResult _ANSI_ARGS_((
Tcl_SavedResult *statePtr));
/* 291 */
EXTERN int Tcl_EvalEx _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *script, int numBytes, int flags));
/* 292 */
EXTERN int Tcl_EvalObjv _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[], int flags));
/* 293 */
EXTERN int Tcl_EvalObjEx _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, int flags));
/* 294 */
EXTERN void Tcl_ExitThread _ANSI_ARGS_((int status));
/* 295 */
EXTERN int Tcl_ExternalToUtf _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Encoding encoding, CONST char *src,
int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr));
/* 296 */
EXTERN char * Tcl_ExternalToUtfDString _ANSI_ARGS_((
Tcl_Encoding encoding, CONST char *src,
int srcLen, Tcl_DString *dsPtr));
/* 297 */
EXTERN void Tcl_FinalizeThread _ANSI_ARGS_((void));
/* 298 */
EXTERN void Tcl_FinalizeNotifier _ANSI_ARGS_((
ClientData clientData));
/* 299 */
EXTERN void Tcl_FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding));
/* 300 */
EXTERN Tcl_ThreadId Tcl_GetCurrentThread _ANSI_ARGS_((void));
/* 301 */
EXTERN Tcl_Encoding Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name));
/* 302 */
EXTERN CONST84_RETURN char * Tcl_GetEncodingName _ANSI_ARGS_((
Tcl_Encoding encoding));
/* 303 */
EXTERN void Tcl_GetEncodingNames _ANSI_ARGS_((Tcl_Interp *interp));
/* 304 */
EXTERN int Tcl_GetIndexFromObjStruct _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr,
CONST VOID *tablePtr, int offset,
CONST char *msg, int flags, int *indexPtr));
/* 305 */
EXTERN VOID * Tcl_GetThreadData _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr, int size));
/* 306 */
EXTERN Tcl_Obj * Tcl_GetVar2Ex _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *part1, CONST char *part2,
int flags));
/* 307 */
EXTERN ClientData Tcl_InitNotifier _ANSI_ARGS_((void));
/* 308 */
EXTERN void Tcl_MutexLock _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
/* 309 */
EXTERN void Tcl_MutexUnlock _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
/* 310 */
EXTERN void Tcl_ConditionNotify _ANSI_ARGS_((
Tcl_Condition *condPtr));
/* 311 */
EXTERN void Tcl_ConditionWait _ANSI_ARGS_((
Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr,
Tcl_Time *timePtr));
/* 312 */
EXTERN int Tcl_NumUtfChars _ANSI_ARGS_((CONST char *src,
int length));
/* 313 */
EXTERN int Tcl_ReadChars _ANSI_ARGS_((Tcl_Channel channel,
Tcl_Obj *objPtr, int charsToRead,
int appendFlag));
/* 314 */
EXTERN void Tcl_RestoreResult _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_SavedResult *statePtr));
/* 315 */
EXTERN void Tcl_SaveResult _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_SavedResult *statePtr));
/* 316 */
EXTERN int Tcl_SetSystemEncoding _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *name));
/* 317 */
EXTERN Tcl_Obj * Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *part1, CONST char *part2,
Tcl_Obj *newValuePtr, int flags));
/* 318 */
EXTERN void Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId));
/* 319 */
EXTERN void Tcl_ThreadQueueEvent _ANSI_ARGS_((
Tcl_ThreadId threadId, Tcl_Event *evPtr,
Tcl_QueuePosition position));
/* 320 */
EXTERN Tcl_UniChar Tcl_UniCharAtIndex _ANSI_ARGS_((CONST char *src,
int index));
/* 321 */
EXTERN Tcl_UniChar Tcl_UniCharToLower _ANSI_ARGS_((int ch));
/* 322 */
EXTERN Tcl_UniChar Tcl_UniCharToTitle _ANSI_ARGS_((int ch));
/* 323 */
EXTERN Tcl_UniChar Tcl_UniCharToUpper _ANSI_ARGS_((int ch));
/* 324 */
EXTERN int Tcl_UniCharToUtf _ANSI_ARGS_((int ch, char *buf));
/* 325 */
EXTERN CONST84_RETURN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char *src,
int index));
/* 326 */
EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char *src,
int length));
/* 327 */
EXTERN int Tcl_UtfBackslash _ANSI_ARGS_((CONST char *src,
int *readPtr, char *dst));
/* 328 */
EXTERN CONST84_RETURN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char *src,
int ch));
/* 329 */
EXTERN CONST84_RETURN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char *src,
int ch));
/* 330 */
EXTERN CONST84_RETURN char * Tcl_UtfNext _ANSI_ARGS_((CONST char *src));
/* 331 */
EXTERN CONST84_RETURN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char *src,
CONST char *start));
/* 332 */
EXTERN int Tcl_UtfToExternal _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Encoding encoding, CONST char *src,
int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr));
/* 333 */
EXTERN char * Tcl_UtfToExternalDString _ANSI_ARGS_((
Tcl_Encoding encoding, CONST char *src,
int srcLen, Tcl_DString *dsPtr));
/* 334 */
EXTERN int Tcl_UtfToLower _ANSI_ARGS_((char *src));
/* 335 */
EXTERN int Tcl_UtfToTitle _ANSI_ARGS_((char *src));
/* 336 */
EXTERN int Tcl_UtfToUniChar _ANSI_ARGS_((CONST char *src,
Tcl_UniChar *chPtr));
/* 337 */
EXTERN int Tcl_UtfToUpper _ANSI_ARGS_((char *src));
/* 338 */
EXTERN int Tcl_WriteChars _ANSI_ARGS_((Tcl_Channel chan,
CONST char *src, int srcLen));
/* 339 */
EXTERN int Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan,
Tcl_Obj *objPtr));
/* 340 */
EXTERN char * Tcl_GetString _ANSI_ARGS_((Tcl_Obj *objPtr));
/* 341 */
EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void));
/* 342 */
EXTERN void Tcl_SetDefaultEncodingDir _ANSI_ARGS_((
CONST char *path));
/* 343 */
EXTERN void Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData));
/* 344 */
EXTERN void Tcl_ServiceModeHook _ANSI_ARGS_((int mode));
/* 345 */
EXTERN int Tcl_UniCharIsAlnum _ANSI_ARGS_((int ch));
/* 346 */
EXTERN int Tcl_UniCharIsAlpha _ANSI_ARGS_((int ch));
/* 347 */
EXTERN int Tcl_UniCharIsDigit _ANSI_ARGS_((int ch));
/* 348 */
EXTERN int Tcl_UniCharIsLower _ANSI_ARGS_((int ch));
/* 349 */
EXTERN int Tcl_UniCharIsSpace _ANSI_ARGS_((int ch));
/* 350 */
EXTERN int Tcl_UniCharIsUpper _ANSI_ARGS_((int ch));
/* 351 */
EXTERN int Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch));
/* 352 */
EXTERN int Tcl_UniCharLen _ANSI_ARGS_((
CONST Tcl_UniChar *uniStr));
/* 353 */
EXTERN int Tcl_UniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar *ucs,
CONST Tcl_UniChar *uct,
unsigned long numChars));
/* 354 */
EXTERN char * Tcl_UniCharToUtfDString _ANSI_ARGS_((
CONST Tcl_UniChar *uniStr, int uniLength,
Tcl_DString *dsPtr));
/* 355 */
EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString _ANSI_ARGS_((CONST char *src,
int length, Tcl_DString *dsPtr));
/* 356 */
EXTERN Tcl_RegExp Tcl_GetRegExpFromObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *patObj, int flags));
/* 357 */
EXTERN Tcl_Obj * Tcl_EvalTokens _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count));
/* 358 */
EXTERN void Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse *parsePtr));
/* 359 */
EXTERN void Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *script, CONST char *command,
int length));
/* 360 */
EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *start, int numBytes,
Tcl_Parse *parsePtr, int append,
CONST84 char **termPtr));
/* 361 */
EXTERN int Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *start, int numBytes, int nested,
Tcl_Parse *parsePtr));
/* 362 */
EXTERN int Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *start, int numBytes,
Tcl_Parse *parsePtr));
/* 363 */
EXTERN int Tcl_ParseQuotedString _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *start,
int numBytes, Tcl_Parse *parsePtr,
int append, CONST84 char **termPtr));
/* 364 */
EXTERN int Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *start, int numBytes,
Tcl_Parse *parsePtr, int append));
/* 365 */
EXTERN char * Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_DString *cwdPtr));
/* 366 */
EXTERN int Tcl_Chdir _ANSI_ARGS_((CONST char *dirName));
/* 367 */
EXTERN int Tcl_Access _ANSI_ARGS_((CONST char *path, int mode));
/* 368 */
EXTERN int Tcl_Stat _ANSI_ARGS_((CONST char *path,
struct stat *bufPtr));
/* 369 */
EXTERN int Tcl_UtfNcmp _ANSI_ARGS_((CONST char *s1,
CONST char *s2, unsigned long n));
/* 370 */
EXTERN int Tcl_UtfNcasecmp _ANSI_ARGS_((CONST char *s1,
CONST char *s2, unsigned long n));
/* 371 */
EXTERN int Tcl_StringCaseMatch _ANSI_ARGS_((CONST char *str,
CONST char *pattern, int nocase));
/* 372 */
EXTERN int Tcl_UniCharIsControl _ANSI_ARGS_((int ch));
/* 373 */
EXTERN int Tcl_UniCharIsGraph _ANSI_ARGS_((int ch));
/* 374 */
EXTERN int Tcl_UniCharIsPrint _ANSI_ARGS_((int ch));
/* 375 */
EXTERN int Tcl_UniCharIsPunct _ANSI_ARGS_((int ch));
/* 376 */
EXTERN int Tcl_RegExpExecObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_RegExp regexp, Tcl_Obj *textObj,
int offset, int nmatches, int flags));
/* 377 */
EXTERN void Tcl_RegExpGetInfo _ANSI_ARGS_((Tcl_RegExp regexp,
Tcl_RegExpInfo *infoPtr));
/* 378 */
EXTERN Tcl_Obj * Tcl_NewUnicodeObj _ANSI_ARGS_((
CONST Tcl_UniChar *unicode, int numChars));
/* 379 */
EXTERN void Tcl_SetUnicodeObj _ANSI_ARGS_((Tcl_Obj *objPtr,
CONST Tcl_UniChar *unicode, int numChars));
/* 380 */
EXTERN int Tcl_GetCharLength _ANSI_ARGS_((Tcl_Obj *objPtr));
/* 381 */
EXTERN Tcl_UniChar Tcl_GetUniChar _ANSI_ARGS_((Tcl_Obj *objPtr,
int index));
/* 382 */
EXTERN Tcl_UniChar * Tcl_GetUnicode _ANSI_ARGS_((Tcl_Obj *objPtr));
/* 383 */
EXTERN Tcl_Obj * Tcl_GetRange _ANSI_ARGS_((Tcl_Obj *objPtr, int first,
int last));
/* 384 */
EXTERN void Tcl_AppendUnicodeToObj _ANSI_ARGS_((Tcl_Obj *objPtr,
CONST Tcl_UniChar *unicode, int length));
/* 385 */
EXTERN int Tcl_RegExpMatchObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *textObj, Tcl_Obj *patternObj));
/* 386 */
EXTERN void Tcl_SetNotifier _ANSI_ARGS_((
Tcl_NotifierProcs *notifierProcPtr));
/* 387 */
EXTERN Tcl_Mutex * Tcl_GetAllocMutex _ANSI_ARGS_((void));
/* 388 */
EXTERN int Tcl_GetChannelNames _ANSI_ARGS_((Tcl_Interp *interp));
/* 389 */
EXTERN int Tcl_GetChannelNamesEx _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *pattern));
/* 390 */
EXTERN int Tcl_ProcObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
/* 391 */
EXTERN void Tcl_ConditionFinalize _ANSI_ARGS_((
Tcl_Condition *condPtr));
/* 392 */
EXTERN void Tcl_MutexFinalize _ANSI_ARGS_((Tcl_Mutex *mutex));
/* 393 */
EXTERN int Tcl_CreateThread _ANSI_ARGS_((Tcl_ThreadId *idPtr,
Tcl_ThreadCreateProc proc,
ClientData clientData, int stackSize,
int flags));
/* 394 */
EXTERN int Tcl_ReadRaw _ANSI_ARGS_((Tcl_Channel chan, char *dst,
int bytesToRead));
/* 395 */
EXTERN int Tcl_WriteRaw _ANSI_ARGS_((Tcl_Channel chan,
CONST char *src, int srcLen));
/* 396 */
EXTERN Tcl_Channel Tcl_GetTopChannel _ANSI_ARGS_((Tcl_Channel chan));
/* 397 */
EXTERN int Tcl_ChannelBuffered _ANSI_ARGS_((Tcl_Channel chan));
/* 398 */
EXTERN CONST84_RETURN char * Tcl_ChannelName _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 399 */
EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 400 */
EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 401 */
EXTERN Tcl_DriverCloseProc * Tcl_ChannelCloseProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 402 */
EXTERN Tcl_DriverClose2Proc * Tcl_ChannelClose2Proc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 403 */
EXTERN Tcl_DriverInputProc * Tcl_ChannelInputProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 404 */
EXTERN Tcl_DriverOutputProc * Tcl_ChannelOutputProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 405 */
EXTERN Tcl_DriverSeekProc * Tcl_ChannelSeekProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 406 */
EXTERN Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 407 */
EXTERN Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 408 */
EXTERN Tcl_DriverWatchProc * Tcl_ChannelWatchProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 409 */
EXTERN Tcl_DriverGetHandleProc * Tcl_ChannelGetHandleProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 410 */
EXTERN Tcl_DriverFlushProc * Tcl_ChannelFlushProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 411 */
EXTERN Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* 412 */
EXTERN int Tcl_JoinThread _ANSI_ARGS_((Tcl_ThreadId threadId,
int *result));
/* 413 */
EXTERN int Tcl_IsChannelShared _ANSI_ARGS_((Tcl_Channel channel));
/* 414 */
EXTERN int Tcl_IsChannelRegistered _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Channel channel));
/* 415 */
EXTERN void Tcl_CutChannel _ANSI_ARGS_((Tcl_Channel channel));
/* 416 */
EXTERN void Tcl_SpliceChannel _ANSI_ARGS_((Tcl_Channel channel));
/* 417 */
EXTERN void Tcl_ClearChannelHandlers _ANSI_ARGS_((
Tcl_Channel channel));
/* 418 */
EXTERN int Tcl_IsChannelExisting _ANSI_ARGS_((
CONST char *channelName));
/* 419 */
EXTERN int Tcl_UniCharNcasecmp _ANSI_ARGS_((
CONST Tcl_UniChar *ucs,
CONST Tcl_UniChar *uct,
unsigned long numChars));
/* 420 */
EXTERN int Tcl_UniCharCaseMatch _ANSI_ARGS_((
CONST Tcl_UniChar *uniStr,
CONST Tcl_UniChar *uniPattern, int nocase));
/* 421 */
EXTERN Tcl_HashEntry * Tcl_FindHashEntry _ANSI_ARGS_((
Tcl_HashTable *tablePtr, CONST char *key));
/* 422 */
EXTERN Tcl_HashEntry * Tcl_CreateHashEntry _ANSI_ARGS_((
Tcl_HashTable *tablePtr, CONST char *key,
int *newPtr));
/* 423 */
EXTERN void Tcl_InitCustomHashTable _ANSI_ARGS_((
Tcl_HashTable *tablePtr, int keyType,
Tcl_HashKeyType *typePtr));
/* 424 */
EXTERN void Tcl_InitObjHashTable _ANSI_ARGS_((
Tcl_HashTable *tablePtr));
/* 425 */
EXTERN ClientData Tcl_CommandTraceInfo _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName, int flags,
Tcl_CommandTraceProc *procPtr,
ClientData prevClientData));
/* 426 */
EXTERN int Tcl_TraceCommand _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName, int flags,
Tcl_CommandTraceProc *proc,
ClientData clientData));
/* 427 */
EXTERN void Tcl_UntraceCommand _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName, int flags,
Tcl_CommandTraceProc *proc,
ClientData clientData));
/* 428 */
EXTERN char * Tcl_AttemptAlloc _ANSI_ARGS_((unsigned int size));
/* 429 */
EXTERN char * Tcl_AttemptDbCkalloc _ANSI_ARGS_((unsigned int size,
CONST char *file, int line));
/* 430 */
EXTERN char * Tcl_AttemptRealloc _ANSI_ARGS_((char *ptr,
unsigned int size));
/* 431 */
EXTERN char * Tcl_AttemptDbCkrealloc _ANSI_ARGS_((char *ptr,
unsigned int size, CONST char *file,
int line));
/* 432 */
EXTERN int Tcl_AttemptSetObjLength _ANSI_ARGS_((Tcl_Obj *objPtr,
int length));
/* 433 */
EXTERN Tcl_ThreadId Tcl_GetChannelThread _ANSI_ARGS_((
Tcl_Channel channel));
/* 434 */
EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj _ANSI_ARGS_((Tcl_Obj *objPtr,
int *lengthPtr));
/* 435 */
EXTERN int Tcl_GetMathFuncInfo _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name, int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr,
ClientData *clientDataPtr));
/* 436 */
EXTERN Tcl_Obj * Tcl_ListMathFuncs _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *pattern));
/* 437 */
EXTERN Tcl_Obj * Tcl_SubstObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, int flags));
/* 438 */
EXTERN int Tcl_DetachChannel _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel channel));
/* 439 */
EXTERN int Tcl_IsStandardChannel _ANSI_ARGS_((
Tcl_Channel channel));
/* 440 */
EXTERN int Tcl_FSCopyFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr));
/* 441 */
EXTERN int Tcl_FSCopyDirectory _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
/* 442 */
EXTERN int Tcl_FSCreateDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr));
/* 443 */
EXTERN int Tcl_FSDeleteFile _ANSI_ARGS_((Tcl_Obj *pathPtr));
/* 444 */
EXTERN int Tcl_FSLoadFile _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, CONST char *sym1,
CONST char *sym2,
Tcl_PackageInitProc **proc1Ptr,
Tcl_PackageInitProc **proc2Ptr,
Tcl_LoadHandle *handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr));
/* 445 */
EXTERN int Tcl_FSMatchInDirectory _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *result,
Tcl_Obj *pathPtr, CONST char *pattern,
Tcl_GlobTypeData *types));
/* 446 */
EXTERN Tcl_Obj * Tcl_FSLink _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_Obj *toPtr, int linkAction));
/* 447 */
EXTERN int Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr,
int recursive, Tcl_Obj **errorPtr));
/* 448 */
EXTERN int Tcl_FSRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr));
/* 449 */
EXTERN int Tcl_FSLstat _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_StatBuf *buf));
/* 450 */
EXTERN int Tcl_FSUtime _ANSI_ARGS_((Tcl_Obj *pathPtr,
struct utimbuf *tval));
/* 451 */
EXTERN int Tcl_FSFileAttrsGet _ANSI_ARGS_((Tcl_Interp *interp,
int index, Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef));
/* 452 */
EXTERN int Tcl_FSFileAttrsSet _ANSI_ARGS_((Tcl_Interp *interp,
int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr));
/* 453 */
EXTERN CONST char ** Tcl_FSFileAttrStrings _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef));
/* 454 */
EXTERN int Tcl_FSStat _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_StatBuf *buf));
/* 455 */
EXTERN int Tcl_FSAccess _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode));
/* 456 */
EXTERN Tcl_Channel Tcl_FSOpenFileChannel _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *pathPtr,
CONST char *modeString, int permissions));
/* 457 */
EXTERN Tcl_Obj * Tcl_FSGetCwd _ANSI_ARGS_((Tcl_Interp *interp));
/* 458 */
EXTERN int Tcl_FSChdir _ANSI_ARGS_((Tcl_Obj *pathPtr));
/* 459 */
EXTERN int Tcl_FSConvertToPathType _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *pathPtr));
/* 460 */
EXTERN Tcl_Obj * Tcl_FSJoinPath _ANSI_ARGS_((Tcl_Obj *listObj,
int elements));
/* 461 */
EXTERN Tcl_Obj * Tcl_FSSplitPath _ANSI_ARGS_((Tcl_Obj *pathPtr,
int *lenPtr));
/* 462 */
EXTERN int Tcl_FSEqualPaths _ANSI_ARGS_((Tcl_Obj *firstPtr,
Tcl_Obj *secondPtr));
/* 463 */
EXTERN Tcl_Obj * Tcl_FSGetNormalizedPath _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *pathPtr));
/* 464 */
EXTERN Tcl_Obj * Tcl_FSJoinToPath _ANSI_ARGS_((Tcl_Obj *pathPtr,
int objc, Tcl_Obj *CONST objv[]));
/* 465 */
EXTERN ClientData Tcl_FSGetInternalRep _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_Filesystem *fsPtr));
/* 466 */
EXTERN Tcl_Obj * Tcl_FSGetTranslatedPath _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *pathPtr));
/* 467 */
EXTERN int Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *fileName));
/* 468 */
EXTERN Tcl_Obj * Tcl_FSNewNativePath _ANSI_ARGS_((
Tcl_Filesystem *fromFilesystem,
ClientData clientData));
/* 469 */
EXTERN CONST char * Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj *pathPtr));
/* 470 */
EXTERN Tcl_Obj * Tcl_FSFileSystemInfo _ANSI_ARGS_((Tcl_Obj *pathPtr));
/* 471 */
EXTERN Tcl_Obj * Tcl_FSPathSeparator _ANSI_ARGS_((Tcl_Obj *pathPtr));
/* 472 */
EXTERN Tcl_Obj * Tcl_FSListVolumes _ANSI_ARGS_((void));
/* 473 */
EXTERN int Tcl_FSRegister _ANSI_ARGS_((ClientData clientData,
Tcl_Filesystem *fsPtr));
/* 474 */
EXTERN int Tcl_FSUnregister _ANSI_ARGS_((Tcl_Filesystem *fsPtr));
/* 475 */
EXTERN ClientData Tcl_FSData _ANSI_ARGS_((Tcl_Filesystem *fsPtr));
/* 476 */
EXTERN CONST char * Tcl_FSGetTranslatedStringPath _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *pathPtr));
/* 477 */
EXTERN Tcl_Filesystem * Tcl_FSGetFileSystemForPath _ANSI_ARGS_((
Tcl_Obj *pathPtr));
/* 478 */
EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathPtr));
/* 479 */
EXTERN int Tcl_OutputBuffered _ANSI_ARGS_((Tcl_Channel chan));
/* 480 */
EXTERN void Tcl_FSMountsChanged _ANSI_ARGS_((
Tcl_Filesystem *fsPtr));
/* 481 */
EXTERN int Tcl_EvalTokensStandard _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count));
/* 482 */
EXTERN void Tcl_GetTime _ANSI_ARGS_((Tcl_Time *timeBuf));
/* 483 */
EXTERN Tcl_Trace Tcl_CreateObjTrace _ANSI_ARGS_((Tcl_Interp *interp,
int level, int flags,
Tcl_CmdObjTraceProc *objProc,
ClientData clientData,
Tcl_CmdObjTraceDeleteProc *delProc));
/* 484 */
EXTERN int Tcl_GetCommandInfoFromToken _ANSI_ARGS_((
Tcl_Command token, Tcl_CmdInfo *infoPtr));
/* 485 */
EXTERN int Tcl_SetCommandInfoFromToken _ANSI_ARGS_((
Tcl_Command token,
CONST Tcl_CmdInfo *infoPtr));
/* 486 */
EXTERN Tcl_Obj * Tcl_DbNewWideIntObj _ANSI_ARGS_((
Tcl_WideInt wideValue, CONST char *file,
int line));
/* 487 */
EXTERN int Tcl_GetWideIntFromObj _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_WideInt *widePtr));
/* 488 */
EXTERN Tcl_Obj * Tcl_NewWideIntObj _ANSI_ARGS_((Tcl_WideInt wideValue));
/* 489 */
EXTERN void Tcl_SetWideIntObj _ANSI_ARGS_((Tcl_Obj *objPtr,
Tcl_WideInt wideValue));
/* 490 */
EXTERN Tcl_StatBuf * Tcl_AllocStatBuf _ANSI_ARGS_((void));
/* 491 */
EXTERN Tcl_WideInt Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan,
Tcl_WideInt offset, int mode));
/* 492 */
EXTERN Tcl_WideInt Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan));
/* 493 */
EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* Slot 494 is reserved */
/* Slot 495 is reserved */
/* Slot 496 is reserved */
/* Slot 497 is reserved */
/* Slot 498 is reserved */
/* Slot 499 is reserved */
/* Slot 500 is reserved */
/* Slot 501 is reserved */
/* Slot 502 is reserved */
/* Slot 503 is reserved */
/* Slot 504 is reserved */
/* Slot 505 is reserved */
/* Slot 506 is reserved */
/* Slot 507 is reserved */
/* Slot 508 is reserved */
/* Slot 509 is reserved */
/* Slot 510 is reserved */
/* Slot 511 is reserved */
/* Slot 512 is reserved */
/* Slot 513 is reserved */
/* Slot 514 is reserved */
/* Slot 515 is reserved */
/* Slot 516 is reserved */
/* Slot 517 is reserved */
/* Slot 518 is reserved */
/* Slot 519 is reserved */
/* Slot 520 is reserved */
/* Slot 521 is reserved */
/* Slot 522 is reserved */
/* Slot 523 is reserved */
/* Slot 524 is reserved */
/* Slot 525 is reserved */
/* Slot 526 is reserved */
/* Slot 527 is reserved */
/* Slot 528 is reserved */
/* Slot 529 is reserved */
/* Slot 530 is reserved */
/* Slot 531 is reserved */
/* Slot 532 is reserved */
/* Slot 533 is reserved */
/* Slot 534 is reserved */
/* Slot 535 is reserved */
/* Slot 536 is reserved */
/* Slot 537 is reserved */
/* Slot 538 is reserved */
/* Slot 539 is reserved */
/* Slot 540 is reserved */
/* Slot 541 is reserved */
/* Slot 542 is reserved */
/* Slot 543 is reserved */
/* Slot 544 is reserved */
/* Slot 545 is reserved */
/* Slot 546 is reserved */
/* Slot 547 is reserved */
/* Slot 548 is reserved */
/* Slot 549 is reserved */
/* Slot 550 is reserved */
/* Slot 551 is reserved */
/* Slot 552 is reserved */
/* Slot 553 is reserved */
/* 554 */
EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc _ANSI_ARGS_((
Tcl_ChannelType *chanTypePtr));
/* Slot 555 is reserved */
/* Slot 556 is reserved */
/* Slot 557 is reserved */
/* Slot 558 is reserved */
/* Slot 559 is reserved */
/* Slot 560 is reserved */
/* Slot 561 is reserved */
/* Slot 562 is reserved */
/* Slot 563 is reserved */
/* Slot 564 is reserved */
/* Slot 565 is reserved */
/* Slot 566 is reserved */
/* Slot 567 is reserved */
/* Slot 568 is reserved */
/* Slot 569 is reserved */
/* Slot 570 is reserved */
/* Slot 571 is reserved */
/* Slot 572 is reserved */
/* 573 */
EXTERN int Tcl_PkgRequireProc _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name, int objc,
Tcl_Obj *CONST objv[],
ClientData *clientDataPtr));
/* Slot 574 is reserved */
/* Slot 575 is reserved */
/* Slot 576 is reserved */
/* Slot 577 is reserved */
/* Slot 578 is reserved */
/* Slot 579 is reserved */
/* Slot 580 is reserved */
/* Slot 581 is reserved */
/* Slot 582 is reserved */
/* Slot 583 is reserved */
/* Slot 584 is reserved */
/* Slot 585 is reserved */
/* Slot 586 is reserved */
/* Slot 587 is reserved */
/* Slot 588 is reserved */
/* Slot 589 is reserved */
/* Slot 590 is reserved */
/* Slot 591 is reserved */
/* Slot 592 is reserved */
/* Slot 593 is reserved */
/* Slot 594 is reserved */
/* Slot 595 is reserved */
/* Slot 596 is reserved */
/* Slot 597 is reserved */
/* Slot 598 is reserved */
/* Slot 599 is reserved */
/* Slot 600 is reserved */
/* Slot 601 is reserved */
/* Slot 602 is reserved */
/* Slot 603 is reserved */
/* Slot 604 is reserved */
/* Slot 605 is reserved */
/* Slot 606 is reserved */
/* Slot 607 is reserved */
/* Slot 608 is reserved */
/* Slot 609 is reserved */
/* Slot 610 is reserved */
/* Slot 611 is reserved */
/* Slot 612 is reserved */
/* Slot 613 is reserved */
/* Slot 614 is reserved */
/* Slot 615 is reserved */
/* Slot 616 is reserved */
/* Slot 617 is reserved */
/* Slot 618 is reserved */
/* Slot 619 is reserved */
/* Slot 620 is reserved */
/* Slot 621 is reserved */
/* Slot 622 is reserved */
/* Slot 623 is reserved */
/* Slot 624 is reserved */
/* Slot 625 is reserved */
/* Slot 626 is reserved */
/* Slot 627 is reserved */
/* Slot 628 is reserved */
/* Slot 629 is reserved */
/* 630 */
EXTERN void TclUnusedStubEntry _ANSI_ARGS_((void));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
struct TclIntStubs *tclIntStubs;
struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
typedef struct TclStubs {
int magic;
struct TclStubHooks *hooks;
int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, CONST char *version, ClientData clientData)); /* 0 */
CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, CONST char *version, int exact, ClientData *clientDataPtr)); /* 1 */
void (*tcl_Panic) _ANSI_ARGS_((CONST char *format, ...)); /* 2 */
char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
void (*tcl_Free) _ANSI_ARGS_((char *ptr)); /* 4 */
char * (*tcl_Realloc) _ANSI_ARGS_((char *ptr, unsigned int size)); /* 5 */
char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char *file, int line)); /* 6 */
void (*tcl_DbCkfree) _ANSI_ARGS_((char *ptr, CONST char *file, int line)); /* 7 */
char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char *ptr, unsigned int size, CONST char *file, int line)); /* 8 */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tcl_CreateFileHandler) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc *proc, ClientData clientData)); /* 9 */
#endif /* UNIX */
#if defined(__WIN32__) /* WIN */
VOID *reserved9;
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tcl_CreateFileHandler) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc *proc, ClientData clientData)); /* 9 */
#endif /* MACOSX */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tcl_DeleteFileHandler) _ANSI_ARGS_((int fd)); /* 10 */
#endif /* UNIX */
#if defined(__WIN32__) /* WIN */
VOID *reserved10;
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tcl_DeleteFileHandler) _ANSI_ARGS_((int fd)); /* 10 */
#endif /* MACOSX */
void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time *timePtr)); /* 11 */
void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */
int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time *timePtr)); /* 13 */
int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* 14 */
void (*tcl_AppendStringsToObj) _ANSI_ARGS_((Tcl_Obj *objPtr, ...)); /* 15 */
void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj *objPtr, CONST char *bytes, int length)); /* 16 */
Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */
int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_ObjType *typePtr)); /* 18 */
void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj *objPtr, CONST char *file, int line)); /* 19 */
void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj *objPtr, CONST char *file, int line)); /* 20 */
int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj *objPtr, CONST char *file, int line)); /* 21 */
Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char *file, int line)); /* 22 */
Tcl_Obj * (*tcl_DbNewByteArrayObj) _ANSI_ARGS_((CONST unsigned char *bytes, int length, CONST char *file, int line)); /* 23 */
Tcl_Obj * (*tcl_DbNewDoubleObj) _ANSI_ARGS_((double doubleValue, CONST char *file, int line)); /* 24 */
Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST *objv, CONST char *file, int line)); /* 25 */
Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, CONST char *file, int line)); /* 26 */
Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((CONST char *file, int line)); /* 27 */
Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char *bytes, int length, CONST char *file, int line)); /* 28 */
Tcl_Obj * (*tcl_DuplicateObj) _ANSI_ARGS_((Tcl_Obj *objPtr)); /* 29 */
void (*tclFreeObj) _ANSI_ARGS_((Tcl_Obj *objPtr)); /* 30 */
int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *src, int *boolPtr)); /* 31 */
int (*tcl_GetBooleanFromObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr)); /* 32 */
unsigned char * (*tcl_GetByteArrayFromObj) _ANSI_ARGS_((Tcl_Obj *objPtr, int *lengthPtr)); /* 33 */
int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *src, double *doublePtr)); /* 34 */
int (*tcl_GetDoubleFromObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr)); /* 35 */
int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char **tablePtr, CONST char *msg, int flags, int *indexPtr)); /* 36 */
int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *src, int *intPtr)); /* 37 */
int (*tcl_GetIntFromObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)); /* 38 */
int (*tcl_GetLongFromObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)); /* 39 */
Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((CONST char *typeName)); /* 40 */
char * (*tcl_GetStringFromObj) _ANSI_ARGS_((Tcl_Obj *objPtr, int *lengthPtr)); /* 41 */
void (*tcl_InvalidateStringRep) _ANSI_ARGS_((Tcl_Obj *objPtr)); /* 42 */
int (*tcl_ListObjAppendList) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr)); /* 43 */
int (*tcl_ListObjAppendElement) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr)); /* 44 */
int (*tcl_ListObjGetElements) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr)); /* 45 */
int (*tcl_ListObjIndex) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr)); /* 46 */
int (*tcl_ListObjLength) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr)); /* 47 */
int (*tcl_ListObjReplace) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *CONST objv[])); /* 48 */
Tcl_Obj * (*tcl_NewBooleanObj) _ANSI_ARGS_((int boolValue)); /* 49 */
Tcl_Obj * (*tcl_NewByteArrayObj) _ANSI_ARGS_((CONST unsigned char *bytes, int length)); /* 50 */
Tcl_Obj * (*tcl_NewDoubleObj) _ANSI_ARGS_((double doubleValue)); /* 51 */
Tcl_Obj * (*tcl_NewIntObj) _ANSI_ARGS_((int intValue)); /* 52 */
Tcl_Obj * (*tcl_NewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 53 */
Tcl_Obj * (*tcl_NewLongObj) _ANSI_ARGS_((long longValue)); /* 54 */
Tcl_Obj * (*tcl_NewObj) _ANSI_ARGS_((void)); /* 55 */
Tcl_Obj * (*tcl_NewStringObj) _ANSI_ARGS_((CONST char *bytes, int length)); /* 56 */
void (*tcl_SetBooleanObj) _ANSI_ARGS_((Tcl_Obj *objPtr, int boolValue)); /* 57 */
unsigned char * (*tcl_SetByteArrayLength) _ANSI_ARGS_((Tcl_Obj *objPtr, int length)); /* 58 */
void (*tcl_SetByteArrayObj) _ANSI_ARGS_((Tcl_Obj *objPtr, CONST unsigned char *bytes, int length)); /* 59 */
void (*tcl_SetDoubleObj) _ANSI_ARGS_((Tcl_Obj *objPtr, double doubleValue)); /* 60 */
void (*tcl_SetIntObj) _ANSI_ARGS_((Tcl_Obj *objPtr, int intValue)); /* 61 */
void (*tcl_SetListObj) _ANSI_ARGS_((Tcl_Obj *objPtr, int objc, Tcl_Obj *CONST objv[])); /* 62 */
void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj *objPtr, long longValue)); /* 63 */
void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj *objPtr, int length)); /* 64 */
void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj *objPtr, CONST char *bytes, int length)); /* 65 */
void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *message)); /* 66 */
void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *message, int length)); /* 67 */
void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp *interp)); /* 68 */
void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *element)); /* 69 */
void (*tcl_AppendResult) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 70 */
Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc *proc, ClientData clientData)); /* 71 */
void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */
int (*tcl_AsyncInvoke) _ANSI_ARGS_((Tcl_Interp *interp, int code)); /* 73 */
void (*tcl_AsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 74 */
int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp *interp)); /* 76 */
char (*tcl_Backslash) _ANSI_ARGS_((CONST char *src, int *readPtr)); /* 77 */
int (*tcl_BadChannelOption) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *optionName, CONST char *optionList)); /* 78 */
void (*tcl_CallWhenDeleted) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData)); /* 79 */
void (*tcl_CancelIdleCall) _ANSI_ARGS_((Tcl_IdleProc *idleProc, ClientData clientData)); /* 80 */
int (*tcl_Close) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan)); /* 81 */
int (*tcl_CommandComplete) _ANSI_ARGS_((CONST char *cmd)); /* 82 */
char * (*tcl_Concat) _ANSI_ARGS_((int argc, CONST84 char *CONST *argv)); /* 83 */
int (*tcl_ConvertElement) _ANSI_ARGS_((CONST char *src, char *dst, int flags)); /* 84 */
int (*tcl_ConvertCountedElement) _ANSI_ARGS_((CONST char *src, int length, char *dst, int flags)); /* 85 */
int (*tcl_CreateAlias) _ANSI_ARGS_((Tcl_Interp *slave, CONST char *slaveCmd, Tcl_Interp *target, CONST char *targetCmd, int argc, CONST84 char *CONST *argv)); /* 86 */
int (*tcl_CreateAliasObj) _ANSI_ARGS_((Tcl_Interp *slave, CONST char *slaveCmd, Tcl_Interp *target, CONST char *targetCmd, int objc, Tcl_Obj *CONST objv[])); /* 87 */
Tcl_Channel (*tcl_CreateChannel) _ANSI_ARGS_((Tcl_ChannelType *typePtr, CONST char *chanName, ClientData instanceData, int mask)); /* 88 */
void (*tcl_CreateChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData)); /* 89 */
void (*tcl_CreateCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData)); /* 90 */
Tcl_Command (*tcl_CreateCommand) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc)); /* 91 */
void (*tcl_CreateEventSource) _ANSI_ARGS_((Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData)); /* 92 */
void (*tcl_CreateExitHandler) _ANSI_ARGS_((Tcl_ExitProc *proc, ClientData clientData)); /* 93 */
Tcl_Interp * (*tcl_CreateInterp) _ANSI_ARGS_((void)); /* 94 */
void (*tcl_CreateMathFunc) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData)); /* 95 */
Tcl_Command (*tcl_CreateObjCommand) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc)); /* 96 */
Tcl_Interp * (*tcl_CreateSlave) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *slaveName, int isSafe)); /* 97 */
Tcl_TimerToken (*tcl_CreateTimerHandler) _ANSI_ARGS_((int milliseconds, Tcl_TimerProc *proc, ClientData clientData)); /* 98 */
Tcl_Trace (*tcl_CreateTrace) _ANSI_ARGS_((Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData)); /* 99 */
void (*tcl_DeleteAssocData) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); /* 100 */
void (*tcl_DeleteChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_ChannelProc *proc, ClientData clientData)); /* 101 */
void (*tcl_DeleteCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData)); /* 102 */
int (*tcl_DeleteCommand) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *cmdName)); /* 103 */
int (*tcl_DeleteCommandFromToken) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Command command)); /* 104 */
void (*tcl_DeleteEvents) _ANSI_ARGS_((Tcl_EventDeleteProc *proc, ClientData clientData)); /* 105 */
void (*tcl_DeleteEventSource) _ANSI_ARGS_((Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData)); /* 106 */
void (*tcl_DeleteExitHandler) _ANSI_ARGS_((Tcl_ExitProc *proc, ClientData clientData)); /* 107 */
void (*tcl_DeleteHashEntry) _ANSI_ARGS_((Tcl_HashEntry *entryPtr)); /* 108 */
void (*tcl_DeleteHashTable) _ANSI_ARGS_((Tcl_HashTable *tablePtr)); /* 109 */
void (*tcl_DeleteInterp) _ANSI_ARGS_((Tcl_Interp *interp)); /* 110 */
void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid *pidPtr)); /* 111 */
void (*tcl_DeleteTimerHandler) _ANSI_ARGS_((Tcl_TimerToken token)); /* 112 */
void (*tcl_DeleteTrace) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Trace trace)); /* 113 */
void (*tcl_DontCallWhenDeleted) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData)); /* 114 */
int (*tcl_DoOneEvent) _ANSI_ARGS_((int flags)); /* 115 */
void (*tcl_DoWhenIdle) _ANSI_ARGS_((Tcl_IdleProc *proc, ClientData clientData)); /* 116 */
char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString *dsPtr, CONST char *bytes, int length)); /* 117 */
char * (*tcl_DStringAppendElement) _ANSI_ARGS_((Tcl_DString *dsPtr, CONST char *element)); /* 118 */
void (*tcl_DStringEndSublist) _ANSI_ARGS_((Tcl_DString *dsPtr)); /* 119 */
void (*tcl_DStringFree) _ANSI_ARGS_((Tcl_DString *dsPtr)); /* 120 */
void (*tcl_DStringGetResult) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *dsPtr)); /* 121 */
void (*tcl_DStringInit) _ANSI_ARGS_((Tcl_DString *dsPtr)); /* 122 */
void (*tcl_DStringResult) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *dsPtr)); /* 123 */
void (*tcl_DStringSetLength) _ANSI_ARGS_((Tcl_DString *dsPtr, int length)); /* 124 */
void (*tcl_DStringStartSublist) _ANSI_ARGS_((Tcl_DString *dsPtr)); /* 125 */
int (*tcl_Eof) _ANSI_ARGS_((Tcl_Channel chan)); /* 126 */
CONST84_RETURN char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */
CONST84_RETURN char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */
int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script)); /* 129 */
int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *fileName)); /* 130 */
int (*tcl_EvalObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* 131 */
void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc *freeProc)); /* 132 */
void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */
int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *hiddenCmdToken, CONST char *cmdName)); /* 134 */
int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *expr, int *ptr)); /* 135 */
int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr)); /* 136 */
int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *expr, double *ptr)); /* 137 */
int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr)); /* 138 */
int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *expr, long *ptr)); /* 139 */
int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr)); /* 140 */
int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr)); /* 141 */
int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *expr)); /* 142 */
void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */
void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char *argv0)); /* 144 */
Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr)); /* 145 */
int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */
void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp *interp)); /* 147 */
int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr)); /* 148 */
int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv)); /* 149 */
ClientData (*tcl_GetAssocData) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, Tcl_InterpDeleteProc **procPtr)); /* 150 */
Tcl_Channel (*tcl_GetChannel) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *chanName, int *modePtr)); /* 151 */
int (*tcl_GetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan)); /* 152 */
int (*tcl_GetChannelHandle) _ANSI_ARGS_((Tcl_Channel chan, int direction, ClientData *handlePtr)); /* 153 */
ClientData (*tcl_GetChannelInstanceData) _ANSI_ARGS_((Tcl_Channel chan)); /* 154 */
int (*tcl_GetChannelMode) _ANSI_ARGS_((Tcl_Channel chan)); /* 155 */
CONST84_RETURN char * (*tcl_GetChannelName) _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */
int (*tcl_GetChannelOption) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan, CONST char *optionName, Tcl_DString *dsPtr)); /* 157 */
Tcl_ChannelType * (*tcl_GetChannelType) _ANSI_ARGS_((Tcl_Channel chan)); /* 158 */
int (*tcl_GetCommandInfo) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *cmdName, Tcl_CmdInfo *infoPtr)); /* 159 */
CONST84_RETURN char * (*tcl_GetCommandName) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Command command)); /* 160 */
int (*tcl_GetErrno) _ANSI_ARGS_((void)); /* 161 */
CONST84_RETURN char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */
int (*tcl_GetInterpPath) _ANSI_ARGS_((Tcl_Interp *askInterp, Tcl_Interp *slaveInterp)); /* 163 */
Tcl_Interp * (*tcl_GetMaster) _ANSI_ARGS_((Tcl_Interp *interp)); /* 164 */
CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */
Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp *interp)); /* 166 */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *chanID, int forWriting, int checkUsage, ClientData *filePtr)); /* 167 */
#endif /* UNIX */
#if defined(__WIN32__) /* WIN */
VOID *reserved167;
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *chanID, int forWriting, int checkUsage, ClientData *filePtr)); /* 167 */
#endif /* MACOSX */
Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((CONST char *path)); /* 168 */
int (*tcl_Gets) _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString *dsPtr)); /* 169 */
int (*tcl_GetsObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj *objPtr)); /* 170 */
int (*tcl_GetServiceMode) _ANSI_ARGS_((void)); /* 171 */
Tcl_Interp * (*tcl_GetSlave) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *slaveName)); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) _ANSI_ARGS_((int type)); /* 173 */
CONST84_RETURN char * (*tcl_GetStringResult) _ANSI_ARGS_((Tcl_Interp *interp)); /* 174 */
CONST84_RETURN char * (*tcl_GetVar) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, int flags)); /* 175 */
CONST84_RETURN char * (*tcl_GetVar2) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags)); /* 176 */
int (*tcl_GlobalEval) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *command)); /* 177 */
int (*tcl_GlobalEvalObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* 178 */
int (*tcl_HideCommand) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *cmdName, CONST char *hiddenCmdToken)); /* 179 */
int (*tcl_Init) _ANSI_ARGS_((Tcl_Interp *interp)); /* 180 */
void (*tcl_InitHashTable) _ANSI_ARGS_((Tcl_HashTable *tablePtr, int keyType)); /* 181 */
int (*tcl_InputBlocked) _ANSI_ARGS_((Tcl_Channel chan)); /* 182 */
int (*tcl_InputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 183 */
int (*tcl_InterpDeleted) _ANSI_ARGS_((Tcl_Interp *interp)); /* 184 */
int (*tcl_IsSafe) _ANSI_ARGS_((Tcl_Interp *interp)); /* 185 */
char * (*tcl_JoinPath) _ANSI_ARGS_((int argc, CONST84 char *CONST *argv, Tcl_DString *resultPtr)); /* 186 */
int (*tcl_LinkVar) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, char *addr, int type)); /* 187 */
VOID *reserved188;
Tcl_Channel (*tcl_MakeFileChannel) _ANSI_ARGS_((ClientData handle, int mode)); /* 189 */
int (*tcl_MakeSafe) _ANSI_ARGS_((Tcl_Interp *interp)); /* 190 */
Tcl_Channel (*tcl_MakeTcpClientChannel) _ANSI_ARGS_((ClientData tcpSocket)); /* 191 */
char * (*tcl_Merge) _ANSI_ARGS_((int argc, CONST84 char *CONST *argv)); /* 192 */
Tcl_HashEntry * (*tcl_NextHashEntry) _ANSI_ARGS_((Tcl_HashSearch *searchPtr)); /* 193 */
void (*tcl_NotifyChannel) _ANSI_ARGS_((Tcl_Channel channel, int mask)); /* 194 */
Tcl_Obj * (*tcl_ObjGetVar2) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags)); /* 195 */
Tcl_Obj * (*tcl_ObjSetVar2) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags)); /* 196 */
Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp *interp, int argc, CONST84 char **argv, int flags)); /* 197 */
Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *fileName, CONST char *modeString, int permissions)); /* 198 */
Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp *interp, int port, CONST char *address, CONST char *myaddr, int myport, int async)); /* 199 */
Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp *interp, int port, CONST char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData)); /* 200 */
void (*tcl_Preserve) _ANSI_ARGS_((ClientData data)); /* 201 */
void (*tcl_PrintDouble) _ANSI_ARGS_((Tcl_Interp *interp, double value, char *dst)); /* 202 */
int (*tcl_PutEnv) _ANSI_ARGS_((CONST char *assignment)); /* 203 */
CONST84_RETURN char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp *interp)); /* 204 */
void (*tcl_QueueEvent) _ANSI_ARGS_((Tcl_Event *evPtr, Tcl_QueuePosition position)); /* 205 */
int (*tcl_Read) _ANSI_ARGS_((Tcl_Channel chan, char *bufPtr, int toRead)); /* 206 */
void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
int (*tcl_RecordAndEval) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *cmd, int flags)); /* 208 */
int (*tcl_RecordAndEvalObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags)); /* 209 */
void (*tcl_RegisterChannel) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan)); /* 210 */
void (*tcl_RegisterObjType) _ANSI_ARGS_((Tcl_ObjType *typePtr)); /* 211 */
Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *pattern)); /* 212 */
int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_RegExp regexp, CONST char *text, CONST char *start)); /* 213 */
int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *text, CONST char *pattern)); /* 214 */
void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr)); /* 215 */
void (*tcl_Release) _ANSI_ARGS_((ClientData clientData)); /* 216 */
void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp *interp)); /* 217 */
int (*tcl_ScanElement) _ANSI_ARGS_((CONST char *src, int *flagPtr)); /* 218 */
int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char *src, int length, int *flagPtr)); /* 219 */
int (*tcl_SeekOld) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */
int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */
int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */
void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, Tcl_InterpDeleteProc *proc, ClientData clientData)); /* 223 */
void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */
int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan, CONST char *optionName, CONST char *newValue)); /* 225 */
int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *cmdName, CONST Tcl_CmdInfo *infoPtr)); /* 226 */
void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */
void (*tcl_SetErrorCode) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 228 */
void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time *timePtr)); /* 229 */
void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc *panicProc)); /* 230 */
int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp *interp, int depth)); /* 231 */
void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc)); /* 232 */
int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *errorObjPtr)); /* 234 */
void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultObjPtr)); /* 235 */
void (*tcl_SetStdChannel) _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 236 */
CONST84_RETURN char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, CONST char *newValue, int flags)); /* 237 */
CONST84_RETURN char * (*tcl_SetVar2) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *part1, CONST char *part2, CONST char *newValue, int flags)); /* 238 */
CONST84_RETURN char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */
CONST84_RETURN char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */
void (*tcl_SourceRCFile) _ANSI_ARGS_((Tcl_Interp *interp)); /* 241 */
int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *listStr, int *argcPtr, CONST84 char ***argvPtr)); /* 242 */
void (*tcl_SplitPath) _ANSI_ARGS_((CONST char *path, int *argcPtr, CONST84 char ***argvPtr)); /* 243 */
void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)); /* 244 */
int (*tcl_StringMatch) _ANSI_ARGS_((CONST char *str, CONST char *pattern)); /* 245 */
int (*tcl_TellOld) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */
int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData)); /* 247 */
int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData)); /* 248 */
char * (*tcl_TranslateFileName) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, Tcl_DString *bufferPtr)); /* 249 */
int (*tcl_Ungets) _ANSI_ARGS_((Tcl_Channel chan, CONST char *str, int len, int atHead)); /* 250 */
void (*tcl_UnlinkVar) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName)); /* 251 */
int (*tcl_UnregisterChannel) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan)); /* 252 */
int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, int flags)); /* 253 */
int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags)); /* 254 */
void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData)); /* 255 */
void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData)); /* 256 */
void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName)); /* 257 */
int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *frameName, CONST char *varName, CONST char *localName, int flags)); /* 258 */
int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *frameName, CONST char *part1, CONST char *part2, CONST char *localName, int flags)); /* 259 */
int (*tcl_VarEval) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 260 */
ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)); /* 261 */
ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)); /* 262 */
int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char *s, int slen)); /* 263 */
void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], CONST char *message)); /* 264 */
int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char *fileName)); /* 265 */
void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char *file, int line)); /* 266 */
void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp *interp, va_list argList)); /* 267 */
void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj *objPtr, va_list argList)); /* 268 */
char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable *tablePtr)); /* 269 */
CONST84_RETURN char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *start, CONST84 char **termPtr)); /* 270 */
CONST84_RETURN char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, CONST char *version, int exact)); /* 271 */
CONST84_RETURN char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, CONST char *version, int exact, ClientData *clientDataPtr)); /* 272 */
int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, CONST char *version)); /* 273 */
CONST84_RETURN char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, CONST char *version, int exact)); /* 274 */
void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp *interp, va_list argList)); /* 275 */
int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp *interp, va_list argList)); /* 276 */
Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int *statPtr, int options)); /* 277 */
void (*tcl_PanicVA) _ANSI_ARGS_((CONST char *format, va_list argList)); /* 278 */
void (*tcl_GetVersion) _ANSI_ARGS_((int *major, int *minor, int *patchLevel, int *type)); /* 279 */
void (*tcl_InitMemory) _ANSI_ARGS_((Tcl_Interp *interp)); /* 280 */
Tcl_Channel (*tcl_StackChannel) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan)); /* 281 */
int (*tcl_UnstackChannel) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan)); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 283 */
void (*tcl_SetMainLoop) _ANSI_ARGS_((Tcl_MainLoopProc *proc)); /* 284 */
VOID *reserved285;
void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr)); /* 286 */
Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType *typePtr)); /* 287 */
void (*tcl_CreateThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc *proc, ClientData clientData)); /* 288 */
void (*tcl_DeleteThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc *proc, ClientData clientData)); /* 289 */
void (*tcl_DiscardResult) _ANSI_ARGS_((Tcl_SavedResult *statePtr)); /* 290 */
int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, int numBytes, int flags)); /* 291 */
int (*tcl_EvalObjv) _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 292 */
int (*tcl_EvalObjEx) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)); /* 293 */
void (*tcl_ExitThread) _ANSI_ARGS_((int status)); /* 294 */
int (*tcl_ExternalToUtf) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Encoding encoding, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); /* 295 */
char * (*tcl_ExternalToUtfDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char *src, int srcLen, Tcl_DString *dsPtr)); /* 296 */
void (*tcl_FinalizeThread) _ANSI_ARGS_((void)); /* 297 */
void (*tcl_FinalizeNotifier) _ANSI_ARGS_((ClientData clientData)); /* 298 */
void (*tcl_FreeEncoding) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 299 */
Tcl_ThreadId (*tcl_GetCurrentThread) _ANSI_ARGS_((void)); /* 300 */
Tcl_Encoding (*tcl_GetEncoding) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); /* 301 */
CONST84_RETURN char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */
void (*tcl_GetEncodingNames) _ANSI_ARGS_((Tcl_Interp *interp)); /* 303 */
int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, CONST VOID *tablePtr, int offset, CONST char *msg, int flags, int *indexPtr)); /* 304 */
VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr, int size)); /* 305 */
Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags)); /* 306 */
ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */
void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex *mutexPtr)); /* 308 */
void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex *mutexPtr)); /* 309 */
void (*tcl_ConditionNotify) _ANSI_ARGS_((Tcl_Condition *condPtr)); /* 310 */
void (*tcl_ConditionWait) _ANSI_ARGS_((Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, Tcl_Time *timePtr)); /* 311 */
int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char *src, int length)); /* 312 */
int (*tcl_ReadChars) _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag)); /* 313 */
void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_SavedResult *statePtr)); /* 314 */
void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_SavedResult *statePtr)); /* 315 */
int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); /* 316 */
Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *part1, CONST char *part2, Tcl_Obj *newValuePtr, int flags)); /* 317 */
void (*tcl_ThreadAlert) _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 318 */
void (*tcl_ThreadQueueEvent) _ANSI_ARGS_((Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position)); /* 319 */
Tcl_UniChar (*tcl_UniCharAtIndex) _ANSI_ARGS_((CONST char *src, int index)); /* 320 */
Tcl_UniChar (*tcl_UniCharToLower) _ANSI_ARGS_((int ch)); /* 321 */
Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */
Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */
int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char *buf)); /* 324 */
CONST84_RETURN char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char *src, int index)); /* 325 */
int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char *src, int length)); /* 326 */
int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char *src, int *readPtr, char *dst)); /* 327 */
CONST84_RETURN char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char *src, int ch)); /* 328 */
CONST84_RETURN char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char *src, int ch)); /* 329 */
CONST84_RETURN char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char *src)); /* 330 */
CONST84_RETURN char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char *src, CONST char *start)); /* 331 */
int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Encoding encoding, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); /* 332 */
char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char *src, int srcLen, Tcl_DString *dsPtr)); /* 333 */
int (*tcl_UtfToLower) _ANSI_ARGS_((char *src)); /* 334 */
int (*tcl_UtfToTitle) _ANSI_ARGS_((char *src)); /* 335 */
int (*tcl_UtfToUniChar) _ANSI_ARGS_((CONST char *src, Tcl_UniChar *chPtr)); /* 336 */
int (*tcl_UtfToUpper) _ANSI_ARGS_((char *src)); /* 337 */
int (*tcl_WriteChars) _ANSI_ARGS_((Tcl_Channel chan, CONST char *src, int srcLen)); /* 338 */
int (*tcl_WriteObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj *objPtr)); /* 339 */
char * (*tcl_GetString) _ANSI_ARGS_((Tcl_Obj *objPtr)); /* 340 */
CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */
void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((CONST char *path)); /* 342 */
void (*tcl_AlertNotifier) _ANSI_ARGS_((ClientData clientData)); /* 343 */
void (*tcl_ServiceModeHook) _ANSI_ARGS_((int mode)); /* 344 */
int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */
int (*tcl_UniCharIsAlpha) _ANSI_ARGS_((int ch)); /* 346 */
int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */
int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */
int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */
int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */
int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */
int (*tcl_UniCharLen) _ANSI_ARGS_((CONST Tcl_UniChar *uniStr)); /* 352 */
int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct, unsigned long numChars)); /* 353 */
char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr)); /* 354 */
Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char *src, int length, Tcl_DString *dsPtr)); /* 355 */
Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *patObj, int flags)); /* 356 */
Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count)); /* 357 */
void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse *parsePtr)); /* 358 */
void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, CONST char *command, int length)); /* 359 */
int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)); /* 360 */
int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *start, int numBytes, int nested, Tcl_Parse *parsePtr)); /* 361 */
int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr)); /* 362 */
int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)); /* 363 */
int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append)); /* 364 */
char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *cwdPtr)); /* 365 */
int (*tcl_Chdir) _ANSI_ARGS_((CONST char *dirName)); /* 366 */
int (*tcl_Access) _ANSI_ARGS_((CONST char *path, int mode)); /* 367 */
int (*tcl_Stat) _ANSI_ARGS_((CONST char *path, struct stat *bufPtr)); /* 368 */
int (*tcl_UtfNcmp) _ANSI_ARGS_((CONST char *s1, CONST char *s2, unsigned long n)); /* 369 */
int (*tcl_UtfNcasecmp) _ANSI_ARGS_((CONST char *s1, CONST char *s2, unsigned long n)); /* 370 */
int (*tcl_StringCaseMatch) _ANSI_ARGS_((CONST char *str, CONST char *pattern, int nocase)); /* 371 */
int (*tcl_UniCharIsControl) _ANSI_ARGS_((int ch)); /* 372 */
int (*tcl_UniCharIsGraph) _ANSI_ARGS_((int ch)); /* 373 */
int (*tcl_UniCharIsPrint) _ANSI_ARGS_((int ch)); /* 374 */
int (*tcl_UniCharIsPunct) _ANSI_ARGS_((int ch)); /* 375 */
int (*tcl_RegExpExecObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags)); /* 376 */
void (*tcl_RegExpGetInfo) _ANSI_ARGS_((Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr)); /* 377 */
Tcl_Obj * (*tcl_NewUnicodeObj) _ANSI_ARGS_((CONST Tcl_UniChar *unicode, int numChars)); /* 378 */
void (*tcl_SetUnicodeObj) _ANSI_ARGS_((Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int numChars)); /* 379 */
int (*tcl_GetCharLength) _ANSI_ARGS_((Tcl_Obj *objPtr)); /* 380 */
Tcl_UniChar (*tcl_GetUniChar) _ANSI_ARGS_((Tcl_Obj *objPtr, int index)); /* 381 */
Tcl_UniChar * (*tcl_GetUnicode) _ANSI_ARGS_((Tcl_Obj *objPtr)); /* 382 */
Tcl_Obj * (*tcl_GetRange) _ANSI_ARGS_((Tcl_Obj *objPtr, int first, int last)); /* 383 */
void (*tcl_AppendUnicodeToObj) _ANSI_ARGS_((Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int length)); /* 384 */
int (*tcl_RegExpMatchObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj)); /* 385 */
void (*tcl_SetNotifier) _ANSI_ARGS_((Tcl_NotifierProcs *notifierProcPtr)); /* 386 */
Tcl_Mutex * (*tcl_GetAllocMutex) _ANSI_ARGS_((void)); /* 387 */
int (*tcl_GetChannelNames) _ANSI_ARGS_((Tcl_Interp *interp)); /* 388 */
int (*tcl_GetChannelNamesEx) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *pattern)); /* 389 */
int (*tcl_ProcObjCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /* 390 */
void (*tcl_ConditionFinalize) _ANSI_ARGS_((Tcl_Condition *condPtr)); /* 391 */
void (*tcl_MutexFinalize) _ANSI_ARGS_((Tcl_Mutex *mutex)); /* 392 */
int (*tcl_CreateThread) _ANSI_ARGS_((Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags)); /* 393 */
int (*tcl_ReadRaw) _ANSI_ARGS_((Tcl_Channel chan, char *dst, int bytesToRead)); /* 394 */
int (*tcl_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, CONST char *src, int srcLen)); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 396 */
int (*tcl_ChannelBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 397 */
CONST84_RETURN char * (*tcl_ChannelName) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 398 */
Tcl_ChannelTypeVersion (*tcl_ChannelVersion) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 399 */
Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 400 */
Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 401 */
Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 402 */
Tcl_DriverInputProc * (*tcl_ChannelInputProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 403 */
Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 404 */
Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 405 */
Tcl_DriverSetOptionProc * (*tcl_ChannelSetOptionProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 406 */
Tcl_DriverGetOptionProc * (*tcl_ChannelGetOptionProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 407 */
Tcl_DriverWatchProc * (*tcl_ChannelWatchProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 408 */
Tcl_DriverGetHandleProc * (*tcl_ChannelGetHandleProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 409 */
Tcl_DriverFlushProc * (*tcl_ChannelFlushProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 410 */
Tcl_DriverHandlerProc * (*tcl_ChannelHandlerProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 411 */
int (*tcl_JoinThread) _ANSI_ARGS_((Tcl_ThreadId threadId, int *result)); /* 412 */
int (*tcl_IsChannelShared) _ANSI_ARGS_((Tcl_Channel channel)); /* 413 */
int (*tcl_IsChannelRegistered) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel)); /* 414 */
void (*tcl_CutChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 415 */
void (*tcl_SpliceChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 416 */
void (*tcl_ClearChannelHandlers) _ANSI_ARGS_((Tcl_Channel channel)); /* 417 */
int (*tcl_IsChannelExisting) _ANSI_ARGS_((CONST char *channelName)); /* 418 */
int (*tcl_UniCharNcasecmp) _ANSI_ARGS_((CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct, unsigned long numChars)); /* 419 */
int (*tcl_UniCharCaseMatch) _ANSI_ARGS_((CONST Tcl_UniChar *uniStr, CONST Tcl_UniChar *uniPattern, int nocase)); /* 420 */
Tcl_HashEntry * (*tcl_FindHashEntry) _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key)); /* 421 */
Tcl_HashEntry * (*tcl_CreateHashEntry) _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key, int *newPtr)); /* 422 */
void (*tcl_InitCustomHashTable) _ANSI_ARGS_((Tcl_HashTable *tablePtr, int keyType, Tcl_HashKeyType *typePtr)); /* 423 */
void (*tcl_InitObjHashTable) _ANSI_ARGS_((Tcl_HashTable *tablePtr)); /* 424 */
ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData)); /* 425 */
int (*tcl_TraceCommand) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData)); /* 426 */
void (*tcl_UntraceCommand) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData)); /* 427 */
char * (*tcl_AttemptAlloc) _ANSI_ARGS_((unsigned int size)); /* 428 */
char * (*tcl_AttemptDbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char *file, int line)); /* 429 */
char * (*tcl_AttemptRealloc) _ANSI_ARGS_((char *ptr, unsigned int size)); /* 430 */
char * (*tcl_AttemptDbCkrealloc) _ANSI_ARGS_((char *ptr, unsigned int size, CONST char *file, int line)); /* 431 */
int (*tcl_AttemptSetObjLength) _ANSI_ARGS_((Tcl_Obj *objPtr, int length)); /* 432 */
Tcl_ThreadId (*tcl_GetChannelThread) _ANSI_ARGS_((Tcl_Channel channel)); /* 433 */
Tcl_UniChar * (*tcl_GetUnicodeFromObj) _ANSI_ARGS_((Tcl_Obj *objPtr, int *lengthPtr)); /* 434 */
int (*tcl_GetMathFuncInfo) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr)); /* 435 */
Tcl_Obj * (*tcl_ListMathFuncs) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *pattern)); /* 436 */
Tcl_Obj * (*tcl_SubstObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)); /* 437 */
int (*tcl_DetachChannel) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel channel)); /* 438 */
int (*tcl_IsStandardChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 439 */
int (*tcl_FSCopyFile) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)); /* 440 */
int (*tcl_FSCopyDirectory) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)); /* 441 */
int (*tcl_FSCreateDirectory) _ANSI_ARGS_((Tcl_Obj *pathPtr)); /* 442 */
int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj *pathPtr)); /* 443 */
int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, CONST char *sym1, CONST char *sym2, Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr)); /* 444 */
int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)); /* 445 */
Tcl_Obj * (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction)); /* 446 */
int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr)); /* 447 */
int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)); /* 448 */
int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); /* 449 */
int (*tcl_FSUtime) _ANSI_ARGS_((Tcl_Obj *pathPtr, struct utimbuf *tval)); /* 450 */
int (*tcl_FSFileAttrsGet) _ANSI_ARGS_((Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)); /* 451 */
int (*tcl_FSFileAttrsSet) _ANSI_ARGS_((Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr)); /* 452 */
CONST char ** (*tcl_FSFileAttrStrings) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)); /* 453 */
int (*tcl_FSStat) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); /* 454 */
int (*tcl_FSAccess) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode)); /* 455 */
Tcl_Channel (*tcl_FSOpenFileChannel) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, CONST char *modeString, int permissions)); /* 456 */
Tcl_Obj * (*tcl_FSGetCwd) _ANSI_ARGS_((Tcl_Interp *interp)); /* 457 */
int (*tcl_FSChdir) _ANSI_ARGS_((Tcl_Obj *pathPtr)); /* 458 */
int (*tcl_FSConvertToPathType) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); /* 459 */
Tcl_Obj * (*tcl_FSJoinPath) _ANSI_ARGS_((Tcl_Obj *listObj, int elements)); /* 460 */
Tcl_Obj * (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj *pathPtr, int *lenPtr)); /* 461 */
int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj *firstPtr, Tcl_Obj *secondPtr)); /* 462 */
Tcl_Obj * (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); /* 463 */
Tcl_Obj * (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj *pathPtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */
ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Filesystem *fsPtr)); /* 465 */
Tcl_Obj * (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); /* 466 */
int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *fileName)); /* 467 */
Tcl_Obj * (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Filesystem *fromFilesystem, ClientData clientData)); /* 468 */
CONST char * (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj *pathPtr)); /* 469 */
Tcl_Obj * (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj *pathPtr)); /* 470 */
Tcl_Obj * (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj *pathPtr)); /* 471 */
Tcl_Obj * (*tcl_FSListVolumes) _ANSI_ARGS_((void)); /* 472 */
int (*tcl_FSRegister) _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem *fsPtr)); /* 473 */
int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem *fsPtr)); /* 474 */
ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem *fsPtr)); /* 475 */
CONST char * (*tcl_FSGetTranslatedStringPath) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); /* 476 */
Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) _ANSI_ARGS_((Tcl_Obj *pathPtr)); /* 477 */
Tcl_PathType (*tcl_FSGetPathType) _ANSI_ARGS_((Tcl_Obj *pathPtr)); /* 478 */
int (*tcl_OutputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 479 */
void (*tcl_FSMountsChanged) _ANSI_ARGS_((Tcl_Filesystem *fsPtr)); /* 480 */
int (*tcl_EvalTokensStandard) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count)); /* 481 */
void (*tcl_GetTime) _ANSI_ARGS_((Tcl_Time *timeBuf)); /* 482 */
Tcl_Trace (*tcl_CreateObjTrace) _ANSI_ARGS_((Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc)); /* 483 */
int (*tcl_GetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, Tcl_CmdInfo *infoPtr)); /* 484 */
int (*tcl_SetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, CONST Tcl_CmdInfo *infoPtr)); /* 485 */
Tcl_Obj * (*tcl_DbNewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue, CONST char *file, int line)); /* 486 */
int (*tcl_GetWideIntFromObj) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideInt *widePtr)); /* 487 */
Tcl_Obj * (*tcl_NewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue)); /* 488 */
void (*tcl_SetWideIntObj) _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_WideInt wideValue)); /* 489 */
Tcl_StatBuf * (*tcl_AllocStatBuf) _ANSI_ARGS_((void)); /* 490 */
Tcl_WideInt (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt offset, int mode)); /* 491 */
Tcl_WideInt (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 492 */
Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 493 */
VOID *reserved494;
VOID *reserved495;
VOID *reserved496;
VOID *reserved497;
VOID *reserved498;
VOID *reserved499;
VOID *reserved500;
VOID *reserved501;
VOID *reserved502;
VOID *reserved503;
VOID *reserved504;
VOID *reserved505;
VOID *reserved506;
VOID *reserved507;
VOID *reserved508;
VOID *reserved509;
VOID *reserved510;
VOID *reserved511;
VOID *reserved512;
VOID *reserved513;
VOID *reserved514;
VOID *reserved515;
VOID *reserved516;
VOID *reserved517;
VOID *reserved518;
VOID *reserved519;
VOID *reserved520;
VOID *reserved521;
VOID *reserved522;
VOID *reserved523;
VOID *reserved524;
VOID *reserved525;
VOID *reserved526;
VOID *reserved527;
VOID *reserved528;
VOID *reserved529;
VOID *reserved530;
VOID *reserved531;
VOID *reserved532;
VOID *reserved533;
VOID *reserved534;
VOID *reserved535;
VOID *reserved536;
VOID *reserved537;
VOID *reserved538;
VOID *reserved539;
VOID *reserved540;
VOID *reserved541;
VOID *reserved542;
VOID *reserved543;
VOID *reserved544;
VOID *reserved545;
VOID *reserved546;
VOID *reserved547;
VOID *reserved548;
VOID *reserved549;
VOID *reserved550;
VOID *reserved551;
VOID *reserved552;
VOID *reserved553;
Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) _ANSI_ARGS_((Tcl_ChannelType *chanTypePtr)); /* 554 */
VOID *reserved555;
VOID *reserved556;
VOID *reserved557;
VOID *reserved558;
VOID *reserved559;
VOID *reserved560;
VOID *reserved561;
VOID *reserved562;
VOID *reserved563;
VOID *reserved564;
VOID *reserved565;
VOID *reserved566;
VOID *reserved567;
VOID *reserved568;
VOID *reserved569;
VOID *reserved570;
VOID *reserved571;
VOID *reserved572;
int (*tcl_PkgRequireProc) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, int objc, Tcl_Obj *CONST objv[], ClientData *clientDataPtr)); /* 573 */
VOID *reserved574;
VOID *reserved575;
VOID *reserved576;
VOID *reserved577;
VOID *reserved578;
VOID *reserved579;
VOID *reserved580;
VOID *reserved581;
VOID *reserved582;
VOID *reserved583;
VOID *reserved584;
VOID *reserved585;
VOID *reserved586;
VOID *reserved587;
VOID *reserved588;
VOID *reserved589;
VOID *reserved590;
VOID *reserved591;
VOID *reserved592;
VOID *reserved593;
VOID *reserved594;
VOID *reserved595;
VOID *reserved596;
VOID *reserved597;
VOID *reserved598;
VOID *reserved599;
VOID *reserved600;
VOID *reserved601;
VOID *reserved602;
VOID *reserved603;
VOID *reserved604;
VOID *reserved605;
VOID *reserved606;
VOID *reserved607;
VOID *reserved608;
VOID *reserved609;
VOID *reserved610;
VOID *reserved611;
VOID *reserved612;
VOID *reserved613;
VOID *reserved614;
VOID *reserved615;
VOID *reserved616;
VOID *reserved617;
VOID *reserved618;
VOID *reserved619;
VOID *reserved620;
VOID *reserved621;
VOID *reserved622;
VOID *reserved623;
VOID *reserved624;
VOID *reserved625;
VOID *reserved626;
VOID *reserved627;
VOID *reserved628;
VOID *reserved629;
void (*tclUnusedStubEntry) _ANSI_ARGS_((void)); /* 630 */
} TclStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
/*
* Inline function declarations:
*/
#ifndef Tcl_PkgProvideEx
#define Tcl_PkgProvideEx \
(tclStubsPtr->tcl_PkgProvideEx) /* 0 */
#endif
#ifndef Tcl_PkgRequireEx
#define Tcl_PkgRequireEx \
(tclStubsPtr->tcl_PkgRequireEx) /* 1 */
#endif
#ifndef Tcl_Panic
#define Tcl_Panic \
(tclStubsPtr->tcl_Panic) /* 2 */
#endif
#ifndef Tcl_Alloc
#define Tcl_Alloc \
(tclStubsPtr->tcl_Alloc) /* 3 */
#endif
#ifndef Tcl_Free
#define Tcl_Free \
(tclStubsPtr->tcl_Free) /* 4 */
#endif
#ifndef Tcl_Realloc
#define Tcl_Realloc \
(tclStubsPtr->tcl_Realloc) /* 5 */
#endif
#ifndef Tcl_DbCkalloc
#define Tcl_DbCkalloc \
(tclStubsPtr->tcl_DbCkalloc) /* 6 */
#endif
#ifndef Tcl_DbCkfree
#define Tcl_DbCkfree \
(tclStubsPtr->tcl_DbCkfree) /* 7 */
#endif
#ifndef Tcl_DbCkrealloc
#define Tcl_DbCkrealloc \
(tclStubsPtr->tcl_DbCkrealloc) /* 8 */
#endif
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
#ifndef Tcl_CreateFileHandler
#define Tcl_CreateFileHandler \
(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
#endif
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
#ifndef Tcl_CreateFileHandler
#define Tcl_CreateFileHandler \
(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
#endif
#endif /* MACOSX */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
#ifndef Tcl_DeleteFileHandler
#define Tcl_DeleteFileHandler \
(tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
#endif
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
#ifndef Tcl_DeleteFileHandler
#define Tcl_DeleteFileHandler \
(tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
#endif
#endif /* MACOSX */
#ifndef Tcl_SetTimer
#define Tcl_SetTimer \
(tclStubsPtr->tcl_SetTimer) /* 11 */
#endif
#ifndef Tcl_Sleep
#define Tcl_Sleep \
(tclStubsPtr->tcl_Sleep) /* 12 */
#endif
#ifndef Tcl_WaitForEvent
#define Tcl_WaitForEvent \
(tclStubsPtr->tcl_WaitForEvent) /* 13 */
#endif
#ifndef Tcl_AppendAllObjTypes
#define Tcl_AppendAllObjTypes \
(tclStubsPtr->tcl_AppendAllObjTypes) /* 14 */
#endif
#ifndef Tcl_AppendStringsToObj
#define Tcl_AppendStringsToObj \
(tclStubsPtr->tcl_AppendStringsToObj) /* 15 */
#endif
#ifndef Tcl_AppendToObj
#define Tcl_AppendToObj \
(tclStubsPtr->tcl_AppendToObj) /* 16 */
#endif
#ifndef Tcl_ConcatObj
#define Tcl_ConcatObj \
(tclStubsPtr->tcl_ConcatObj) /* 17 */
#endif
#ifndef Tcl_ConvertToType
#define Tcl_ConvertToType \
(tclStubsPtr->tcl_ConvertToType) /* 18 */
#endif
#ifndef Tcl_DbDecrRefCount
#define Tcl_DbDecrRefCount \
(tclStubsPtr->tcl_DbDecrRefCount) /* 19 */
#endif
#ifndef Tcl_DbIncrRefCount
#define Tcl_DbIncrRefCount \
(tclStubsPtr->tcl_DbIncrRefCount) /* 20 */
#endif
#ifndef Tcl_DbIsShared
#define Tcl_DbIsShared \
(tclStubsPtr->tcl_DbIsShared) /* 21 */
#endif
#ifndef Tcl_DbNewBooleanObj
#define Tcl_DbNewBooleanObj \
(tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */
#endif
#ifndef Tcl_DbNewByteArrayObj
#define Tcl_DbNewByteArrayObj \
(tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */
#endif
#ifndef Tcl_DbNewDoubleObj
#define Tcl_DbNewDoubleObj \
(tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */
#endif
#ifndef Tcl_DbNewListObj
#define Tcl_DbNewListObj \
(tclStubsPtr->tcl_DbNewListObj) /* 25 */
#endif
#ifndef Tcl_DbNewLongObj
#define Tcl_DbNewLongObj \
(tclStubsPtr->tcl_DbNewLongObj) /* 26 */
#endif
#ifndef Tcl_DbNewObj
#define Tcl_DbNewObj \
(tclStubsPtr->tcl_DbNewObj) /* 27 */
#endif
#ifndef Tcl_DbNewStringObj
#define Tcl_DbNewStringObj \
(tclStubsPtr->tcl_DbNewStringObj) /* 28 */
#endif
#ifndef Tcl_DuplicateObj
#define Tcl_DuplicateObj \
(tclStubsPtr->tcl_DuplicateObj) /* 29 */
#endif
#ifndef TclFreeObj
#define TclFreeObj \
(tclStubsPtr->tclFreeObj) /* 30 */
#endif
#ifndef Tcl_GetBoolean
#define Tcl_GetBoolean \
(tclStubsPtr->tcl_GetBoolean) /* 31 */
#endif
#ifndef Tcl_GetBooleanFromObj
#define Tcl_GetBooleanFromObj \
(tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */
#endif
#ifndef Tcl_GetByteArrayFromObj
#define Tcl_GetByteArrayFromObj \
(tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */
#endif
#ifndef Tcl_GetDouble
#define Tcl_GetDouble \
(tclStubsPtr->tcl_GetDouble) /* 34 */
#endif
#ifndef Tcl_GetDoubleFromObj
#define Tcl_GetDoubleFromObj \
(tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */
#endif
#ifndef Tcl_GetIndexFromObj
#define Tcl_GetIndexFromObj \
(tclStubsPtr->tcl_GetIndexFromObj) /* 36 */
#endif
#ifndef Tcl_GetInt
#define Tcl_GetInt \
(tclStubsPtr->tcl_GetInt) /* 37 */
#endif
#ifndef Tcl_GetIntFromObj
#define Tcl_GetIntFromObj \
(tclStubsPtr->tcl_GetIntFromObj) /* 38 */
#endif
#ifndef Tcl_GetLongFromObj
#define Tcl_GetLongFromObj \
(tclStubsPtr->tcl_GetLongFromObj) /* 39 */
#endif
#ifndef Tcl_GetObjType
#define Tcl_GetObjType \
(tclStubsPtr->tcl_GetObjType) /* 40 */
#endif
#ifndef Tcl_GetStringFromObj
#define Tcl_GetStringFromObj \
(tclStubsPtr->tcl_GetStringFromObj) /* 41 */
#endif
#ifndef Tcl_InvalidateStringRep
#define Tcl_InvalidateStringRep \
(tclStubsPtr->tcl_InvalidateStringRep) /* 42 */
#endif
#ifndef Tcl_ListObjAppendList
#define Tcl_ListObjAppendList \
(tclStubsPtr->tcl_ListObjAppendList) /* 43 */
#endif
#ifndef Tcl_ListObjAppendElement
#define Tcl_ListObjAppendElement \
(tclStubsPtr->tcl_ListObjAppendElement) /* 44 */
#endif
#ifndef Tcl_ListObjGetElements
#define Tcl_ListObjGetElements \
(tclStubsPtr->tcl_ListObjGetElements) /* 45 */
#endif
#ifndef Tcl_ListObjIndex
#define Tcl_ListObjIndex \
(tclStubsPtr->tcl_ListObjIndex) /* 46 */
#endif
#ifndef Tcl_ListObjLength
#define Tcl_ListObjLength \
(tclStubsPtr->tcl_ListObjLength) /* 47 */
#endif
#ifndef Tcl_ListObjReplace
#define Tcl_ListObjReplace \
(tclStubsPtr->tcl_ListObjReplace) /* 48 */
#endif
#ifndef Tcl_NewBooleanObj
#define Tcl_NewBooleanObj \
(tclStubsPtr->tcl_NewBooleanObj) /* 49 */
#endif
#ifndef Tcl_NewByteArrayObj
#define Tcl_NewByteArrayObj \
(tclStubsPtr->tcl_NewByteArrayObj) /* 50 */
#endif
#ifndef Tcl_NewDoubleObj
#define Tcl_NewDoubleObj \
(tclStubsPtr->tcl_NewDoubleObj) /* 51 */
#endif
#ifndef Tcl_NewIntObj
#define Tcl_NewIntObj \
(tclStubsPtr->tcl_NewIntObj) /* 52 */
#endif
#ifndef Tcl_NewListObj
#define Tcl_NewListObj \
(tclStubsPtr->tcl_NewListObj) /* 53 */
#endif
#ifndef Tcl_NewLongObj
#define Tcl_NewLongObj \
(tclStubsPtr->tcl_NewLongObj) /* 54 */
#endif
#ifndef Tcl_NewObj
#define Tcl_NewObj \
(tclStubsPtr->tcl_NewObj) /* 55 */
#endif
#ifndef Tcl_NewStringObj
#define Tcl_NewStringObj \
(tclStubsPtr->tcl_NewStringObj) /* 56 */
#endif
#ifndef Tcl_SetBooleanObj
#define Tcl_SetBooleanObj \
(tclStubsPtr->tcl_SetBooleanObj) /* 57 */
#endif
#ifndef Tcl_SetByteArrayLength
#define Tcl_SetByteArrayLength \
(tclStubsPtr->tcl_SetByteArrayLength) /* 58 */
#endif
#ifndef Tcl_SetByteArrayObj
#define Tcl_SetByteArrayObj \
(tclStubsPtr->tcl_SetByteArrayObj) /* 59 */
#endif
#ifndef Tcl_SetDoubleObj
#define Tcl_SetDoubleObj \
(tclStubsPtr->tcl_SetDoubleObj) /* 60 */
#endif
#ifndef Tcl_SetIntObj
#define Tcl_SetIntObj \
(tclStubsPtr->tcl_SetIntObj) /* 61 */
#endif
#ifndef Tcl_SetListObj
#define Tcl_SetListObj \
(tclStubsPtr->tcl_SetListObj) /* 62 */
#endif
#ifndef Tcl_SetLongObj
#define Tcl_SetLongObj \
(tclStubsPtr->tcl_SetLongObj) /* 63 */
#endif
#ifndef Tcl_SetObjLength
#define Tcl_SetObjLength \
(tclStubsPtr->tcl_SetObjLength) /* 64 */
#endif
#ifndef Tcl_SetStringObj
#define Tcl_SetStringObj \
(tclStubsPtr->tcl_SetStringObj) /* 65 */
#endif
#ifndef Tcl_AddErrorInfo
#define Tcl_AddErrorInfo \
(tclStubsPtr->tcl_AddErrorInfo) /* 66 */
#endif
#ifndef Tcl_AddObjErrorInfo
#define Tcl_AddObjErrorInfo \
(tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */
#endif
#ifndef Tcl_AllowExceptions
#define Tcl_AllowExceptions \
(tclStubsPtr->tcl_AllowExceptions) /* 68 */
#endif
#ifndef Tcl_AppendElement
#define Tcl_AppendElement \
(tclStubsPtr->tcl_AppendElement) /* 69 */
#endif
#ifndef Tcl_AppendResult
#define Tcl_AppendResult \
(tclStubsPtr->tcl_AppendResult) /* 70 */
#endif
#ifndef Tcl_AsyncCreate
#define Tcl_AsyncCreate \
(tclStubsPtr->tcl_AsyncCreate) /* 71 */
#endif
#ifndef Tcl_AsyncDelete
#define Tcl_AsyncDelete \
(tclStubsPtr->tcl_AsyncDelete) /* 72 */
#endif
#ifndef Tcl_AsyncInvoke
#define Tcl_AsyncInvoke \
(tclStubsPtr->tcl_AsyncInvoke) /* 73 */
#endif
#ifndef Tcl_AsyncMark
#define Tcl_AsyncMark \
(tclStubsPtr->tcl_AsyncMark) /* 74 */
#endif
#ifndef Tcl_AsyncReady
#define Tcl_AsyncReady \
(tclStubsPtr->tcl_AsyncReady) /* 75 */
#endif
#ifndef Tcl_BackgroundError
#define Tcl_BackgroundError \
(tclStubsPtr->tcl_BackgroundError) /* 76 */
#endif
#ifndef Tcl_Backslash
#define Tcl_Backslash \
(tclStubsPtr->tcl_Backslash) /* 77 */
#endif
#ifndef Tcl_BadChannelOption
#define Tcl_BadChannelOption \
(tclStubsPtr->tcl_BadChannelOption) /* 78 */
#endif
#ifndef Tcl_CallWhenDeleted
#define Tcl_CallWhenDeleted \
(tclStubsPtr->tcl_CallWhenDeleted) /* 79 */
#endif
#ifndef Tcl_CancelIdleCall
#define Tcl_CancelIdleCall \
(tclStubsPtr->tcl_CancelIdleCall) /* 80 */
#endif
#ifndef Tcl_Close
#define Tcl_Close \
(tclStubsPtr->tcl_Close) /* 81 */
#endif
#ifndef Tcl_CommandComplete
#define Tcl_CommandComplete \
(tclStubsPtr->tcl_CommandComplete) /* 82 */
#endif
#ifndef Tcl_Concat
#define Tcl_Concat \
(tclStubsPtr->tcl_Concat) /* 83 */
#endif
#ifndef Tcl_ConvertElement
#define Tcl_ConvertElement \
(tclStubsPtr->tcl_ConvertElement) /* 84 */
#endif
#ifndef Tcl_ConvertCountedElement
#define Tcl_ConvertCountedElement \
(tclStubsPtr->tcl_ConvertCountedElement) /* 85 */
#endif
#ifndef Tcl_CreateAlias
#define Tcl_CreateAlias \
(tclStubsPtr->tcl_CreateAlias) /* 86 */
#endif
#ifndef Tcl_CreateAliasObj
#define Tcl_CreateAliasObj \
(tclStubsPtr->tcl_CreateAliasObj) /* 87 */
#endif
#ifndef Tcl_CreateChannel
#define Tcl_CreateChannel \
(tclStubsPtr->tcl_CreateChannel) /* 88 */
#endif
#ifndef Tcl_CreateChannelHandler
#define Tcl_CreateChannelHandler \
(tclStubsPtr->tcl_CreateChannelHandler) /* 89 */
#endif
#ifndef Tcl_CreateCloseHandler
#define Tcl_CreateCloseHandler \
(tclStubsPtr->tcl_CreateCloseHandler) /* 90 */
#endif
#ifndef Tcl_CreateCommand
#define Tcl_CreateCommand \
(tclStubsPtr->tcl_CreateCommand) /* 91 */
#endif
#ifndef Tcl_CreateEventSource
#define Tcl_CreateEventSource \
(tclStubsPtr->tcl_CreateEventSource) /* 92 */
#endif
#ifndef Tcl_CreateExitHandler
#define Tcl_CreateExitHandler \
(tclStubsPtr->tcl_CreateExitHandler) /* 93 */
#endif
#ifndef Tcl_CreateInterp
#define Tcl_CreateInterp \
(tclStubsPtr->tcl_CreateInterp) /* 94 */
#endif
#ifndef Tcl_CreateMathFunc
#define Tcl_CreateMathFunc \
(tclStubsPtr->tcl_CreateMathFunc) /* 95 */
#endif
#ifndef Tcl_CreateObjCommand
#define Tcl_CreateObjCommand \
(tclStubsPtr->tcl_CreateObjCommand) /* 96 */
#endif
#ifndef Tcl_CreateSlave
#define Tcl_CreateSlave \
(tclStubsPtr->tcl_CreateSlave) /* 97 */
#endif
#ifndef Tcl_CreateTimerHandler
#define Tcl_CreateTimerHandler \
(tclStubsPtr->tcl_CreateTimerHandler) /* 98 */
#endif
#ifndef Tcl_CreateTrace
#define Tcl_CreateTrace \
(tclStubsPtr->tcl_CreateTrace) /* 99 */
#endif
#ifndef Tcl_DeleteAssocData
#define Tcl_DeleteAssocData \
(tclStubsPtr->tcl_DeleteAssocData) /* 100 */
#endif
#ifndef Tcl_DeleteChannelHandler
#define Tcl_DeleteChannelHandler \
(tclStubsPtr->tcl_DeleteChannelHandler) /* 101 */
#endif
#ifndef Tcl_DeleteCloseHandler
#define Tcl_DeleteCloseHandler \
(tclStubsPtr->tcl_DeleteCloseHandler) /* 102 */
#endif
#ifndef Tcl_DeleteCommand
#define Tcl_DeleteCommand \
(tclStubsPtr->tcl_DeleteCommand) /* 103 */
#endif
#ifndef Tcl_DeleteCommandFromToken
#define Tcl_DeleteCommandFromToken \
(tclStubsPtr->tcl_DeleteCommandFromToken) /* 104 */
#endif
#ifndef Tcl_DeleteEvents
#define Tcl_DeleteEvents \
(tclStubsPtr->tcl_DeleteEvents) /* 105 */
#endif
#ifndef Tcl_DeleteEventSource
#define Tcl_DeleteEventSource \
(tclStubsPtr->tcl_DeleteEventSource) /* 106 */
#endif
#ifndef Tcl_DeleteExitHandler
#define Tcl_DeleteExitHandler \
(tclStubsPtr->tcl_DeleteExitHandler) /* 107 */
#endif
#ifndef Tcl_DeleteHashEntry
#define Tcl_DeleteHashEntry \
(tclStubsPtr->tcl_DeleteHashEntry) /* 108 */
#endif
#ifndef Tcl_DeleteHashTable
#define Tcl_DeleteHashTable \
(tclStubsPtr->tcl_DeleteHashTable) /* 109 */
#endif
#ifndef Tcl_DeleteInterp
#define Tcl_DeleteInterp \
(tclStubsPtr->tcl_DeleteInterp) /* 110 */
#endif
#ifndef Tcl_DetachPids
#define Tcl_DetachPids \
(tclStubsPtr->tcl_DetachPids) /* 111 */
#endif
#ifndef Tcl_DeleteTimerHandler
#define Tcl_DeleteTimerHandler \
(tclStubsPtr->tcl_DeleteTimerHandler) /* 112 */
#endif
#ifndef Tcl_DeleteTrace
#define Tcl_DeleteTrace \
(tclStubsPtr->tcl_DeleteTrace) /* 113 */
#endif
#ifndef Tcl_DontCallWhenDeleted
#define Tcl_DontCallWhenDeleted \
(tclStubsPtr->tcl_DontCallWhenDeleted) /* 114 */
#endif
#ifndef Tcl_DoOneEvent
#define Tcl_DoOneEvent \
(tclStubsPtr->tcl_DoOneEvent) /* 115 */
#endif
#ifndef Tcl_DoWhenIdle
#define Tcl_DoWhenIdle \
(tclStubsPtr->tcl_DoWhenIdle) /* 116 */
#endif
#ifndef Tcl_DStringAppend
#define Tcl_DStringAppend \
(tclStubsPtr->tcl_DStringAppend) /* 117 */
#endif
#ifndef Tcl_DStringAppendElement
#define Tcl_DStringAppendElement \
(tclStubsPtr->tcl_DStringAppendElement) /* 118 */
#endif
#ifndef Tcl_DStringEndSublist
#define Tcl_DStringEndSublist \
(tclStubsPtr->tcl_DStringEndSublist) /* 119 */
#endif
#ifndef Tcl_DStringFree
#define Tcl_DStringFree \
(tclStubsPtr->tcl_DStringFree) /* 120 */
#endif
#ifndef Tcl_DStringGetResult
#define Tcl_DStringGetResult \
(tclStubsPtr->tcl_DStringGetResult) /* 121 */
#endif
#ifndef Tcl_DStringInit
#define Tcl_DStringInit \
(tclStubsPtr->tcl_DStringInit) /* 122 */
#endif
#ifndef Tcl_DStringResult
#define Tcl_DStringResult \
(tclStubsPtr->tcl_DStringResult) /* 123 */
#endif
#ifndef Tcl_DStringSetLength
#define Tcl_DStringSetLength \
(tclStubsPtr->tcl_DStringSetLength) /* 124 */
#endif
#ifndef Tcl_DStringStartSublist
#define Tcl_DStringStartSublist \
(tclStubsPtr->tcl_DStringStartSublist) /* 125 */
#endif
#ifndef Tcl_Eof
#define Tcl_Eof \
(tclStubsPtr->tcl_Eof) /* 126 */
#endif
#ifndef Tcl_ErrnoId
#define Tcl_ErrnoId \
(tclStubsPtr->tcl_ErrnoId) /* 127 */
#endif
#ifndef Tcl_ErrnoMsg
#define Tcl_ErrnoMsg \
(tclStubsPtr->tcl_ErrnoMsg) /* 128 */
#endif
#ifndef Tcl_Eval
#define Tcl_Eval \
(tclStubsPtr->tcl_Eval) /* 129 */
#endif
#ifndef Tcl_EvalFile
#define Tcl_EvalFile \
(tclStubsPtr->tcl_EvalFile) /* 130 */
#endif
#ifndef Tcl_EvalObj
#define Tcl_EvalObj \
(tclStubsPtr->tcl_EvalObj) /* 131 */
#endif
#ifndef Tcl_EventuallyFree
#define Tcl_EventuallyFree \
(tclStubsPtr->tcl_EventuallyFree) /* 132 */
#endif
#ifndef Tcl_Exit
#define Tcl_Exit \
(tclStubsPtr->tcl_Exit) /* 133 */
#endif
#ifndef Tcl_ExposeCommand
#define Tcl_ExposeCommand \
(tclStubsPtr->tcl_ExposeCommand) /* 134 */
#endif
#ifndef Tcl_ExprBoolean
#define Tcl_ExprBoolean \
(tclStubsPtr->tcl_ExprBoolean) /* 135 */
#endif
#ifndef Tcl_ExprBooleanObj
#define Tcl_ExprBooleanObj \
(tclStubsPtr->tcl_ExprBooleanObj) /* 136 */
#endif
#ifndef Tcl_ExprDouble
#define Tcl_ExprDouble \
(tclStubsPtr->tcl_ExprDouble) /* 137 */
#endif
#ifndef Tcl_ExprDoubleObj
#define Tcl_ExprDoubleObj \
(tclStubsPtr->tcl_ExprDoubleObj) /* 138 */
#endif
#ifndef Tcl_ExprLong
#define Tcl_ExprLong \
(tclStubsPtr->tcl_ExprLong) /* 139 */
#endif
#ifndef Tcl_ExprLongObj
#define Tcl_ExprLongObj \
(tclStubsPtr->tcl_ExprLongObj) /* 140 */
#endif
#ifndef Tcl_ExprObj
#define Tcl_ExprObj \
(tclStubsPtr->tcl_ExprObj) /* 141 */
#endif
#ifndef Tcl_ExprString
#define Tcl_ExprString \
(tclStubsPtr->tcl_ExprString) /* 142 */
#endif
#ifndef Tcl_Finalize
#define Tcl_Finalize \
(tclStubsPtr->tcl_Finalize) /* 143 */
#endif
#ifndef Tcl_FindExecutable
#define Tcl_FindExecutable \
(tclStubsPtr->tcl_FindExecutable) /* 144 */
#endif
#ifndef Tcl_FirstHashEntry
#define Tcl_FirstHashEntry \
(tclStubsPtr->tcl_FirstHashEntry) /* 145 */
#endif
#ifndef Tcl_Flush
#define Tcl_Flush \
(tclStubsPtr->tcl_Flush) /* 146 */
#endif
#ifndef Tcl_FreeResult
#define Tcl_FreeResult \
(tclStubsPtr->tcl_FreeResult) /* 147 */
#endif
#ifndef Tcl_GetAlias
#define Tcl_GetAlias \
(tclStubsPtr->tcl_GetAlias) /* 148 */
#endif
#ifndef Tcl_GetAliasObj
#define Tcl_GetAliasObj \
(tclStubsPtr->tcl_GetAliasObj) /* 149 */
#endif
#ifndef Tcl_GetAssocData
#define Tcl_GetAssocData \
(tclStubsPtr->tcl_GetAssocData) /* 150 */
#endif
#ifndef Tcl_GetChannel
#define Tcl_GetChannel \
(tclStubsPtr->tcl_GetChannel) /* 151 */
#endif
#ifndef Tcl_GetChannelBufferSize
#define Tcl_GetChannelBufferSize \
(tclStubsPtr->tcl_GetChannelBufferSize) /* 152 */
#endif
#ifndef Tcl_GetChannelHandle
#define Tcl_GetChannelHandle \
(tclStubsPtr->tcl_GetChannelHandle) /* 153 */
#endif
#ifndef Tcl_GetChannelInstanceData
#define Tcl_GetChannelInstanceData \
(tclStubsPtr->tcl_GetChannelInstanceData) /* 154 */
#endif
#ifndef Tcl_GetChannelMode
#define Tcl_GetChannelMode \
(tclStubsPtr->tcl_GetChannelMode) /* 155 */
#endif
#ifndef Tcl_GetChannelName
#define Tcl_GetChannelName \
(tclStubsPtr->tcl_GetChannelName) /* 156 */
#endif
#ifndef Tcl_GetChannelOption
#define Tcl_GetChannelOption \
(tclStubsPtr->tcl_GetChannelOption) /* 157 */
#endif
#ifndef Tcl_GetChannelType
#define Tcl_GetChannelType \
(tclStubsPtr->tcl_GetChannelType) /* 158 */
#endif
#ifndef Tcl_GetCommandInfo
#define Tcl_GetCommandInfo \
(tclStubsPtr->tcl_GetCommandInfo) /* 159 */
#endif
#ifndef Tcl_GetCommandName
#define Tcl_GetCommandName \
(tclStubsPtr->tcl_GetCommandName) /* 160 */
#endif
#ifndef Tcl_GetErrno
#define Tcl_GetErrno \
(tclStubsPtr->tcl_GetErrno) /* 161 */
#endif
#ifndef Tcl_GetHostName
#define Tcl_GetHostName \
(tclStubsPtr->tcl_GetHostName) /* 162 */
#endif
#ifndef Tcl_GetInterpPath
#define Tcl_GetInterpPath \
(tclStubsPtr->tcl_GetInterpPath) /* 163 */
#endif
#ifndef Tcl_GetMaster
#define Tcl_GetMaster \
(tclStubsPtr->tcl_GetMaster) /* 164 */
#endif
#ifndef Tcl_GetNameOfExecutable
#define Tcl_GetNameOfExecutable \
(tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */
#endif
#ifndef Tcl_GetObjResult
#define Tcl_GetObjResult \
(tclStubsPtr->tcl_GetObjResult) /* 166 */
#endif
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
#ifndef Tcl_GetOpenFile
#define Tcl_GetOpenFile \
(tclStubsPtr->tcl_GetOpenFile) /* 167 */
#endif
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
#ifndef Tcl_GetOpenFile
#define Tcl_GetOpenFile \
(tclStubsPtr->tcl_GetOpenFile) /* 167 */
#endif
#endif /* MACOSX */
#ifndef Tcl_GetPathType
#define Tcl_GetPathType \
(tclStubsPtr->tcl_GetPathType) /* 168 */
#endif
#ifndef Tcl_Gets
#define Tcl_Gets \
(tclStubsPtr->tcl_Gets) /* 169 */
#endif
#ifndef Tcl_GetsObj
#define Tcl_GetsObj \
(tclStubsPtr->tcl_GetsObj) /* 170 */
#endif
#ifndef Tcl_GetServiceMode
#define Tcl_GetServiceMode \
(tclStubsPtr->tcl_GetServiceMode) /* 171 */
#endif
#ifndef Tcl_GetSlave
#define Tcl_GetSlave \
(tclStubsPtr->tcl_GetSlave) /* 172 */
#endif
#ifndef Tcl_GetStdChannel
#define Tcl_GetStdChannel \
(tclStubsPtr->tcl_GetStdChannel) /* 173 */
#endif
#ifndef Tcl_GetStringResult
#define Tcl_GetStringResult \
(tclStubsPtr->tcl_GetStringResult) /* 174 */
#endif
#ifndef Tcl_GetVar
#define Tcl_GetVar \
(tclStubsPtr->tcl_GetVar) /* 175 */
#endif
#ifndef Tcl_GetVar2
#define Tcl_GetVar2 \
(tclStubsPtr->tcl_GetVar2) /* 176 */
#endif
#ifndef Tcl_GlobalEval
#define Tcl_GlobalEval \
(tclStubsPtr->tcl_GlobalEval) /* 177 */
#endif
#ifndef Tcl_GlobalEvalObj
#define Tcl_GlobalEvalObj \
(tclStubsPtr->tcl_GlobalEvalObj) /* 178 */
#endif
#ifndef Tcl_HideCommand
#define Tcl_HideCommand \
(tclStubsPtr->tcl_HideCommand) /* 179 */
#endif
#ifndef Tcl_Init
#define Tcl_Init \
(tclStubsPtr->tcl_Init) /* 180 */
#endif
#ifndef Tcl_InitHashTable
#define Tcl_InitHashTable \
(tclStubsPtr->tcl_InitHashTable) /* 181 */
#endif
#ifndef Tcl_InputBlocked
#define Tcl_InputBlocked \
(tclStubsPtr->tcl_InputBlocked) /* 182 */
#endif
#ifndef Tcl_InputBuffered
#define Tcl_InputBuffered \
(tclStubsPtr->tcl_InputBuffered) /* 183 */
#endif
#ifndef Tcl_InterpDeleted
#define Tcl_InterpDeleted \
(tclStubsPtr->tcl_InterpDeleted) /* 184 */
#endif
#ifndef Tcl_IsSafe
#define Tcl_IsSafe \
(tclStubsPtr->tcl_IsSafe) /* 185 */
#endif
#ifndef Tcl_JoinPath
#define Tcl_JoinPath \
(tclStubsPtr->tcl_JoinPath) /* 186 */
#endif
#ifndef Tcl_LinkVar
#define Tcl_LinkVar \
(tclStubsPtr->tcl_LinkVar) /* 187 */
#endif
/* Slot 188 is reserved */
#ifndef Tcl_MakeFileChannel
#define Tcl_MakeFileChannel \
(tclStubsPtr->tcl_MakeFileChannel) /* 189 */
#endif
#ifndef Tcl_MakeSafe
#define Tcl_MakeSafe \
(tclStubsPtr->tcl_MakeSafe) /* 190 */
#endif
#ifndef Tcl_MakeTcpClientChannel
#define Tcl_MakeTcpClientChannel \
(tclStubsPtr->tcl_MakeTcpClientChannel) /* 191 */
#endif
#ifndef Tcl_Merge
#define Tcl_Merge \
(tclStubsPtr->tcl_Merge) /* 192 */
#endif
#ifndef Tcl_NextHashEntry
#define Tcl_NextHashEntry \
(tclStubsPtr->tcl_NextHashEntry) /* 193 */
#endif
#ifndef Tcl_NotifyChannel
#define Tcl_NotifyChannel \
(tclStubsPtr->tcl_NotifyChannel) /* 194 */
#endif
#ifndef Tcl_ObjGetVar2
#define Tcl_ObjGetVar2 \
(tclStubsPtr->tcl_ObjGetVar2) /* 195 */
#endif
#ifndef Tcl_ObjSetVar2
#define Tcl_ObjSetVar2 \
(tclStubsPtr->tcl_ObjSetVar2) /* 196 */
#endif
#ifndef Tcl_OpenCommandChannel
#define Tcl_OpenCommandChannel \
(tclStubsPtr->tcl_OpenCommandChannel) /* 197 */
#endif
#ifndef Tcl_OpenFileChannel
#define Tcl_OpenFileChannel \
(tclStubsPtr->tcl_OpenFileChannel) /* 198 */
#endif
#ifndef Tcl_OpenTcpClient
#define Tcl_OpenTcpClient \
(tclStubsPtr->tcl_OpenTcpClient) /* 199 */
#endif
#ifndef Tcl_OpenTcpServer
#define Tcl_OpenTcpServer \
(tclStubsPtr->tcl_OpenTcpServer) /* 200 */
#endif
#ifndef Tcl_Preserve
#define Tcl_Preserve \
(tclStubsPtr->tcl_Preserve) /* 201 */
#endif
#ifndef Tcl_PrintDouble
#define Tcl_PrintDouble \
(tclStubsPtr->tcl_PrintDouble) /* 202 */
#endif
#ifndef Tcl_PutEnv
#define Tcl_PutEnv \
(tclStubsPtr->tcl_PutEnv) /* 203 */
#endif
#ifndef Tcl_PosixError
#define Tcl_PosixError \
(tclStubsPtr->tcl_PosixError) /* 204 */
#endif
#ifndef Tcl_QueueEvent
#define Tcl_QueueEvent \
(tclStubsPtr->tcl_QueueEvent) /* 205 */
#endif
#ifndef Tcl_Read
#define Tcl_Read \
(tclStubsPtr->tcl_Read) /* 206 */
#endif
#ifndef Tcl_ReapDetachedProcs
#define Tcl_ReapDetachedProcs \
(tclStubsPtr->tcl_ReapDetachedProcs) /* 207 */
#endif
#ifndef Tcl_RecordAndEval
#define Tcl_RecordAndEval \
(tclStubsPtr->tcl_RecordAndEval) /* 208 */
#endif
#ifndef Tcl_RecordAndEvalObj
#define Tcl_RecordAndEvalObj \
(tclStubsPtr->tcl_RecordAndEvalObj) /* 209 */
#endif
#ifndef Tcl_RegisterChannel
#define Tcl_RegisterChannel \
(tclStubsPtr->tcl_RegisterChannel) /* 210 */
#endif
#ifndef Tcl_RegisterObjType
#define Tcl_RegisterObjType \
(tclStubsPtr->tcl_RegisterObjType) /* 211 */
#endif
#ifndef Tcl_RegExpCompile
#define Tcl_RegExpCompile \
(tclStubsPtr->tcl_RegExpCompile) /* 212 */
#endif
#ifndef Tcl_RegExpExec
#define Tcl_RegExpExec \
(tclStubsPtr->tcl_RegExpExec) /* 213 */
#endif
#ifndef Tcl_RegExpMatch
#define Tcl_RegExpMatch \
(tclStubsPtr->tcl_RegExpMatch) /* 214 */
#endif
#ifndef Tcl_RegExpRange
#define Tcl_RegExpRange \
(tclStubsPtr->tcl_RegExpRange) /* 215 */
#endif
#ifndef Tcl_Release
#define Tcl_Release \
(tclStubsPtr->tcl_Release) /* 216 */
#endif
#ifndef Tcl_ResetResult
#define Tcl_ResetResult \
(tclStubsPtr->tcl_ResetResult) /* 217 */
#endif
#ifndef Tcl_ScanElement
#define Tcl_ScanElement \
(tclStubsPtr->tcl_ScanElement) /* 218 */
#endif
#ifndef Tcl_ScanCountedElement
#define Tcl_ScanCountedElement \
(tclStubsPtr->tcl_ScanCountedElement) /* 219 */
#endif
#ifndef Tcl_SeekOld
#define Tcl_SeekOld \
(tclStubsPtr->tcl_SeekOld) /* 220 */
#endif
#ifndef Tcl_ServiceAll
#define Tcl_ServiceAll \
(tclStubsPtr->tcl_ServiceAll) /* 221 */
#endif
#ifndef Tcl_ServiceEvent
#define Tcl_ServiceEvent \
(tclStubsPtr->tcl_ServiceEvent) /* 222 */
#endif
#ifndef Tcl_SetAssocData
#define Tcl_SetAssocData \
(tclStubsPtr->tcl_SetAssocData) /* 223 */
#endif
#ifndef Tcl_SetChannelBufferSize
#define Tcl_SetChannelBufferSize \
(tclStubsPtr->tcl_SetChannelBufferSize) /* 224 */
#endif
#ifndef Tcl_SetChannelOption
#define Tcl_SetChannelOption \
(tclStubsPtr->tcl_SetChannelOption) /* 225 */
#endif
#ifndef Tcl_SetCommandInfo
#define Tcl_SetCommandInfo \
(tclStubsPtr->tcl_SetCommandInfo) /* 226 */
#endif
#ifndef Tcl_SetErrno
#define Tcl_SetErrno \
(tclStubsPtr->tcl_SetErrno) /* 227 */
#endif
#ifndef Tcl_SetErrorCode
#define Tcl_SetErrorCode \
(tclStubsPtr->tcl_SetErrorCode) /* 228 */
#endif
#ifndef Tcl_SetMaxBlockTime
#define Tcl_SetMaxBlockTime \
(tclStubsPtr->tcl_SetMaxBlockTime) /* 229 */
#endif
#ifndef Tcl_SetPanicProc
#define Tcl_SetPanicProc \
(tclStubsPtr->tcl_SetPanicProc) /* 230 */
#endif
#ifndef Tcl_SetRecursionLimit
#define Tcl_SetRecursionLimit \
(tclStubsPtr->tcl_SetRecursionLimit) /* 231 */
#endif
#ifndef Tcl_SetResult
#define Tcl_SetResult \
(tclStubsPtr->tcl_SetResult) /* 232 */
#endif
#ifndef Tcl_SetServiceMode
#define Tcl_SetServiceMode \
(tclStubsPtr->tcl_SetServiceMode) /* 233 */
#endif
#ifndef Tcl_SetObjErrorCode
#define Tcl_SetObjErrorCode \
(tclStubsPtr->tcl_SetObjErrorCode) /* 234 */
#endif
#ifndef Tcl_SetObjResult
#define Tcl_SetObjResult \
(tclStubsPtr->tcl_SetObjResult) /* 235 */
#endif
#ifndef Tcl_SetStdChannel
#define Tcl_SetStdChannel \
(tclStubsPtr->tcl_SetStdChannel) /* 236 */
#endif
#ifndef Tcl_SetVar
#define Tcl_SetVar \
(tclStubsPtr->tcl_SetVar) /* 237 */
#endif
#ifndef Tcl_SetVar2
#define Tcl_SetVar2 \
(tclStubsPtr->tcl_SetVar2) /* 238 */
#endif
#ifndef Tcl_SignalId
#define Tcl_SignalId \
(tclStubsPtr->tcl_SignalId) /* 239 */
#endif
#ifndef Tcl_SignalMsg
#define Tcl_SignalMsg \
(tclStubsPtr->tcl_SignalMsg) /* 240 */
#endif
#ifndef Tcl_SourceRCFile
#define Tcl_SourceRCFile \
(tclStubsPtr->tcl_SourceRCFile) /* 241 */
#endif
#ifndef Tcl_SplitList
#define Tcl_SplitList \
(tclStubsPtr->tcl_SplitList) /* 242 */
#endif
#ifndef Tcl_SplitPath
#define Tcl_SplitPath \
(tclStubsPtr->tcl_SplitPath) /* 243 */
#endif
#ifndef Tcl_StaticPackage
#define Tcl_StaticPackage \
(tclStubsPtr->tcl_StaticPackage) /* 244 */
#endif
#ifndef Tcl_StringMatch
#define Tcl_StringMatch \
(tclStubsPtr->tcl_StringMatch) /* 245 */
#endif
#ifndef Tcl_TellOld
#define Tcl_TellOld \
(tclStubsPtr->tcl_TellOld) /* 246 */
#endif
#ifndef Tcl_TraceVar
#define Tcl_TraceVar \
(tclStubsPtr->tcl_TraceVar) /* 247 */
#endif
#ifndef Tcl_TraceVar2
#define Tcl_TraceVar2 \
(tclStubsPtr->tcl_TraceVar2) /* 248 */
#endif
#ifndef Tcl_TranslateFileName
#define Tcl_TranslateFileName \
(tclStubsPtr->tcl_TranslateFileName) /* 249 */
#endif
#ifndef Tcl_Ungets
#define Tcl_Ungets \
(tclStubsPtr->tcl_Ungets) /* 250 */
#endif
#ifndef Tcl_UnlinkVar
#define Tcl_UnlinkVar \
(tclStubsPtr->tcl_UnlinkVar) /* 251 */
#endif
#ifndef Tcl_UnregisterChannel
#define Tcl_UnregisterChannel \
(tclStubsPtr->tcl_UnregisterChannel) /* 252 */
#endif
#ifndef Tcl_UnsetVar
#define Tcl_UnsetVar \
(tclStubsPtr->tcl_UnsetVar) /* 253 */
#endif
#ifndef Tcl_UnsetVar2
#define Tcl_UnsetVar2 \
(tclStubsPtr->tcl_UnsetVar2) /* 254 */
#endif
#ifndef Tcl_UntraceVar
#define Tcl_UntraceVar \
(tclStubsPtr->tcl_UntraceVar) /* 255 */
#endif
#ifndef Tcl_UntraceVar2
#define Tcl_UntraceVar2 \
(tclStubsPtr->tcl_UntraceVar2) /* 256 */
#endif
#ifndef Tcl_UpdateLinkedVar
#define Tcl_UpdateLinkedVar \
(tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */
#endif
#ifndef Tcl_UpVar
#define Tcl_UpVar \
(tclStubsPtr->tcl_UpVar) /* 258 */
#endif
#ifndef Tcl_UpVar2
#define Tcl_UpVar2 \
(tclStubsPtr->tcl_UpVar2) /* 259 */
#endif
#ifndef Tcl_VarEval
#define Tcl_VarEval \
(tclStubsPtr->tcl_VarEval) /* 260 */
#endif
#ifndef Tcl_VarTraceInfo
#define Tcl_VarTraceInfo \
(tclStubsPtr->tcl_VarTraceInfo) /* 261 */
#endif
#ifndef Tcl_VarTraceInfo2
#define Tcl_VarTraceInfo2 \
(tclStubsPtr->tcl_VarTraceInfo2) /* 262 */
#endif
#ifndef Tcl_Write
#define Tcl_Write \
(tclStubsPtr->tcl_Write) /* 263 */
#endif
#ifndef Tcl_WrongNumArgs
#define Tcl_WrongNumArgs \
(tclStubsPtr->tcl_WrongNumArgs) /* 264 */
#endif
#ifndef Tcl_DumpActiveMemory
#define Tcl_DumpActiveMemory \
(tclStubsPtr->tcl_DumpActiveMemory) /* 265 */
#endif
#ifndef Tcl_ValidateAllMemory
#define Tcl_ValidateAllMemory \
(tclStubsPtr->tcl_ValidateAllMemory) /* 266 */
#endif
#ifndef Tcl_AppendResultVA
#define Tcl_AppendResultVA \
(tclStubsPtr->tcl_AppendResultVA) /* 267 */
#endif
#ifndef Tcl_AppendStringsToObjVA
#define Tcl_AppendStringsToObjVA \
(tclStubsPtr->tcl_AppendStringsToObjVA) /* 268 */
#endif
#ifndef Tcl_HashStats
#define Tcl_HashStats \
(tclStubsPtr->tcl_HashStats) /* 269 */
#endif
#ifndef Tcl_ParseVar
#define Tcl_ParseVar \
(tclStubsPtr->tcl_ParseVar) /* 270 */
#endif
#ifndef Tcl_PkgPresent
#define Tcl_PkgPresent \
(tclStubsPtr->tcl_PkgPresent) /* 271 */
#endif
#ifndef Tcl_PkgPresentEx
#define Tcl_PkgPresentEx \
(tclStubsPtr->tcl_PkgPresentEx) /* 272 */
#endif
#ifndef Tcl_PkgProvide
#define Tcl_PkgProvide \
(tclStubsPtr->tcl_PkgProvide) /* 273 */
#endif
#ifndef Tcl_PkgRequire
#define Tcl_PkgRequire \
(tclStubsPtr->tcl_PkgRequire) /* 274 */
#endif
#ifndef Tcl_SetErrorCodeVA
#define Tcl_SetErrorCodeVA \
(tclStubsPtr->tcl_SetErrorCodeVA) /* 275 */
#endif
#ifndef Tcl_VarEvalVA
#define Tcl_VarEvalVA \
(tclStubsPtr->tcl_VarEvalVA) /* 276 */
#endif
#ifndef Tcl_WaitPid
#define Tcl_WaitPid \
(tclStubsPtr->tcl_WaitPid) /* 277 */
#endif
#ifndef Tcl_PanicVA
#define Tcl_PanicVA \
(tclStubsPtr->tcl_PanicVA) /* 278 */
#endif
#ifndef Tcl_GetVersion
#define Tcl_GetVersion \
(tclStubsPtr->tcl_GetVersion) /* 279 */
#endif
#ifndef Tcl_InitMemory
#define Tcl_InitMemory \
(tclStubsPtr->tcl_InitMemory) /* 280 */
#endif
#ifndef Tcl_StackChannel
#define Tcl_StackChannel \
(tclStubsPtr->tcl_StackChannel) /* 281 */
#endif
#ifndef Tcl_UnstackChannel
#define Tcl_UnstackChannel \
(tclStubsPtr->tcl_UnstackChannel) /* 282 */
#endif
#ifndef Tcl_GetStackedChannel
#define Tcl_GetStackedChannel \
(tclStubsPtr->tcl_GetStackedChannel) /* 283 */
#endif
#ifndef Tcl_SetMainLoop
#define Tcl_SetMainLoop \
(tclStubsPtr->tcl_SetMainLoop) /* 284 */
#endif
/* Slot 285 is reserved */
#ifndef Tcl_AppendObjToObj
#define Tcl_AppendObjToObj \
(tclStubsPtr->tcl_AppendObjToObj) /* 286 */
#endif
#ifndef Tcl_CreateEncoding
#define Tcl_CreateEncoding \
(tclStubsPtr->tcl_CreateEncoding) /* 287 */
#endif
#ifndef Tcl_CreateThreadExitHandler
#define Tcl_CreateThreadExitHandler \
(tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */
#endif
#ifndef Tcl_DeleteThreadExitHandler
#define Tcl_DeleteThreadExitHandler \
(tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */
#endif
#ifndef Tcl_DiscardResult
#define Tcl_DiscardResult \
(tclStubsPtr->tcl_DiscardResult) /* 290 */
#endif
#ifndef Tcl_EvalEx
#define Tcl_EvalEx \
(tclStubsPtr->tcl_EvalEx) /* 291 */
#endif
#ifndef Tcl_EvalObjv
#define Tcl_EvalObjv \
(tclStubsPtr->tcl_EvalObjv) /* 292 */
#endif
#ifndef Tcl_EvalObjEx
#define Tcl_EvalObjEx \
(tclStubsPtr->tcl_EvalObjEx) /* 293 */
#endif
#ifndef Tcl_ExitThread
#define Tcl_ExitThread \
(tclStubsPtr->tcl_ExitThread) /* 294 */
#endif
#ifndef Tcl_ExternalToUtf
#define Tcl_ExternalToUtf \
(tclStubsPtr->tcl_ExternalToUtf) /* 295 */
#endif
#ifndef Tcl_ExternalToUtfDString
#define Tcl_ExternalToUtfDString \
(tclStubsPtr->tcl_ExternalToUtfDString) /* 296 */
#endif
#ifndef Tcl_FinalizeThread
#define Tcl_FinalizeThread \
(tclStubsPtr->tcl_FinalizeThread) /* 297 */
#endif
#ifndef Tcl_FinalizeNotifier
#define Tcl_FinalizeNotifier \
(tclStubsPtr->tcl_FinalizeNotifier) /* 298 */
#endif
#ifndef Tcl_FreeEncoding
#define Tcl_FreeEncoding \
(tclStubsPtr->tcl_FreeEncoding) /* 299 */
#endif
#ifndef Tcl_GetCurrentThread
#define Tcl_GetCurrentThread \
(tclStubsPtr->tcl_GetCurrentThread) /* 300 */
#endif
#ifndef Tcl_GetEncoding
#define Tcl_GetEncoding \
(tclStubsPtr->tcl_GetEncoding) /* 301 */
#endif
#ifndef Tcl_GetEncodingName
#define Tcl_GetEncodingName \
(tclStubsPtr->tcl_GetEncodingName) /* 302 */
#endif
#ifndef Tcl_GetEncodingNames
#define Tcl_GetEncodingNames \
(tclStubsPtr->tcl_GetEncodingNames) /* 303 */
#endif
#ifndef Tcl_GetIndexFromObjStruct
#define Tcl_GetIndexFromObjStruct \
(tclStubsPtr->tcl_GetIndexFromObjStruct) /* 304 */
#endif
#ifndef Tcl_GetThreadData
#define Tcl_GetThreadData \
(tclStubsPtr->tcl_GetThreadData) /* 305 */
#endif
#ifndef Tcl_GetVar2Ex
#define Tcl_GetVar2Ex \
(tclStubsPtr->tcl_GetVar2Ex) /* 306 */
#endif
#ifndef Tcl_InitNotifier
#define Tcl_InitNotifier \
(tclStubsPtr->tcl_InitNotifier) /* 307 */
#endif
#ifndef Tcl_MutexLock
#define Tcl_MutexLock \
(tclStubsPtr->tcl_MutexLock) /* 308 */
#endif
#ifndef Tcl_MutexUnlock
#define Tcl_MutexUnlock \
(tclStubsPtr->tcl_MutexUnlock) /* 309 */
#endif
#ifndef Tcl_ConditionNotify
#define Tcl_ConditionNotify \
(tclStubsPtr->tcl_ConditionNotify) /* 310 */
#endif
#ifndef Tcl_ConditionWait
#define Tcl_ConditionWait \
(tclStubsPtr->tcl_ConditionWait) /* 311 */
#endif
#ifndef Tcl_NumUtfChars
#define Tcl_NumUtfChars \
(tclStubsPtr->tcl_NumUtfChars) /* 312 */
#endif
#ifndef Tcl_ReadChars
#define Tcl_ReadChars \
(tclStubsPtr->tcl_ReadChars) /* 313 */
#endif
#ifndef Tcl_RestoreResult
#define Tcl_RestoreResult \
(tclStubsPtr->tcl_RestoreResult) /* 314 */
#endif
#ifndef Tcl_SaveResult
#define Tcl_SaveResult \
(tclStubsPtr->tcl_SaveResult) /* 315 */
#endif
#ifndef Tcl_SetSystemEncoding
#define Tcl_SetSystemEncoding \
(tclStubsPtr->tcl_SetSystemEncoding) /* 316 */
#endif
#ifndef Tcl_SetVar2Ex
#define Tcl_SetVar2Ex \
(tclStubsPtr->tcl_SetVar2Ex) /* 317 */
#endif
#ifndef Tcl_ThreadAlert
#define Tcl_ThreadAlert \
(tclStubsPtr->tcl_ThreadAlert) /* 318 */
#endif
#ifndef Tcl_ThreadQueueEvent
#define Tcl_ThreadQueueEvent \
(tclStubsPtr->tcl_ThreadQueueEvent) /* 319 */
#endif
#ifndef Tcl_UniCharAtIndex
#define Tcl_UniCharAtIndex \
(tclStubsPtr->tcl_UniCharAtIndex) /* 320 */
#endif
#ifndef Tcl_UniCharToLower
#define Tcl_UniCharToLower \
(tclStubsPtr->tcl_UniCharToLower) /* 321 */
#endif
#ifndef Tcl_UniCharToTitle
#define Tcl_UniCharToTitle \
(tclStubsPtr->tcl_UniCharToTitle) /* 322 */
#endif
#ifndef Tcl_UniCharToUpper
#define Tcl_UniCharToUpper \
(tclStubsPtr->tcl_UniCharToUpper) /* 323 */
#endif
#ifndef Tcl_UniCharToUtf
#define Tcl_UniCharToUtf \
(tclStubsPtr->tcl_UniCharToUtf) /* 324 */
#endif
#ifndef Tcl_UtfAtIndex
#define Tcl_UtfAtIndex \
(tclStubsPtr->tcl_UtfAtIndex) /* 325 */
#endif
#ifndef Tcl_UtfCharComplete
#define Tcl_UtfCharComplete \
(tclStubsPtr->tcl_UtfCharComplete) /* 326 */
#endif
#ifndef Tcl_UtfBackslash
#define Tcl_UtfBackslash \
(tclStubsPtr->tcl_UtfBackslash) /* 327 */
#endif
#ifndef Tcl_UtfFindFirst
#define Tcl_UtfFindFirst \
(tclStubsPtr->tcl_UtfFindFirst) /* 328 */
#endif
#ifndef Tcl_UtfFindLast
#define Tcl_UtfFindLast \
(tclStubsPtr->tcl_UtfFindLast) /* 329 */
#endif
#ifndef Tcl_UtfNext
#define Tcl_UtfNext \
(tclStubsPtr->tcl_UtfNext) /* 330 */
#endif
#ifndef Tcl_UtfPrev
#define Tcl_UtfPrev \
(tclStubsPtr->tcl_UtfPrev) /* 331 */
#endif
#ifndef Tcl_UtfToExternal
#define Tcl_UtfToExternal \
(tclStubsPtr->tcl_UtfToExternal) /* 332 */
#endif
#ifndef Tcl_UtfToExternalDString
#define Tcl_UtfToExternalDString \
(tclStubsPtr->tcl_UtfToExternalDString) /* 333 */
#endif
#ifndef Tcl_UtfToLower
#define Tcl_UtfToLower \
(tclStubsPtr->tcl_UtfToLower) /* 334 */
#endif
#ifndef Tcl_UtfToTitle
#define Tcl_UtfToTitle \
(tclStubsPtr->tcl_UtfToTitle) /* 335 */
#endif
#ifndef Tcl_UtfToUniChar
#define Tcl_UtfToUniChar \
(tclStubsPtr->tcl_UtfToUniChar) /* 336 */
#endif
#ifndef Tcl_UtfToUpper
#define Tcl_UtfToUpper \
(tclStubsPtr->tcl_UtfToUpper) /* 337 */
#endif
#ifndef Tcl_WriteChars
#define Tcl_WriteChars \
(tclStubsPtr->tcl_WriteChars) /* 338 */
#endif
#ifndef Tcl_WriteObj
#define Tcl_WriteObj \
(tclStubsPtr->tcl_WriteObj) /* 339 */
#endif
#ifndef Tcl_GetString
#define Tcl_GetString \
(tclStubsPtr->tcl_GetString) /* 340 */
#endif
#ifndef Tcl_GetDefaultEncodingDir
#define Tcl_GetDefaultEncodingDir \
(tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */
#endif
#ifndef Tcl_SetDefaultEncodingDir
#define Tcl_SetDefaultEncodingDir \
(tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */
#endif
#ifndef Tcl_AlertNotifier
#define Tcl_AlertNotifier \
(tclStubsPtr->tcl_AlertNotifier) /* 343 */
#endif
#ifndef Tcl_ServiceModeHook
#define Tcl_ServiceModeHook \
(tclStubsPtr->tcl_ServiceModeHook) /* 344 */
#endif
#ifndef Tcl_UniCharIsAlnum
#define Tcl_UniCharIsAlnum \
(tclStubsPtr->tcl_UniCharIsAlnum) /* 345 */
#endif
#ifndef Tcl_UniCharIsAlpha
#define Tcl_UniCharIsAlpha \
(tclStubsPtr->tcl_UniCharIsAlpha) /* 346 */
#endif
#ifndef Tcl_UniCharIsDigit
#define Tcl_UniCharIsDigit \
(tclStubsPtr->tcl_UniCharIsDigit) /* 347 */
#endif
#ifndef Tcl_UniCharIsLower
#define Tcl_UniCharIsLower \
(tclStubsPtr->tcl_UniCharIsLower) /* 348 */
#endif
#ifndef Tcl_UniCharIsSpace
#define Tcl_UniCharIsSpace \
(tclStubsPtr->tcl_UniCharIsSpace) /* 349 */
#endif
#ifndef Tcl_UniCharIsUpper
#define Tcl_UniCharIsUpper \
(tclStubsPtr->tcl_UniCharIsUpper) /* 350 */
#endif
#ifndef Tcl_UniCharIsWordChar
#define Tcl_UniCharIsWordChar \
(tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */
#endif
#ifndef Tcl_UniCharLen
#define Tcl_UniCharLen \
(tclStubsPtr->tcl_UniCharLen) /* 352 */
#endif
#ifndef Tcl_UniCharNcmp
#define Tcl_UniCharNcmp \
(tclStubsPtr->tcl_UniCharNcmp) /* 353 */
#endif
#ifndef Tcl_UniCharToUtfDString
#define Tcl_UniCharToUtfDString \
(tclStubsPtr->tcl_UniCharToUtfDString) /* 354 */
#endif
#ifndef Tcl_UtfToUniCharDString
#define Tcl_UtfToUniCharDString \
(tclStubsPtr->tcl_UtfToUniCharDString) /* 355 */
#endif
#ifndef Tcl_GetRegExpFromObj
#define Tcl_GetRegExpFromObj \
(tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */
#endif
#ifndef Tcl_EvalTokens
#define Tcl_EvalTokens \
(tclStubsPtr->tcl_EvalTokens) /* 357 */
#endif
#ifndef Tcl_FreeParse
#define Tcl_FreeParse \
(tclStubsPtr->tcl_FreeParse) /* 358 */
#endif
#ifndef Tcl_LogCommandInfo
#define Tcl_LogCommandInfo \
(tclStubsPtr->tcl_LogCommandInfo) /* 359 */
#endif
#ifndef Tcl_ParseBraces
#define Tcl_ParseBraces \
(tclStubsPtr->tcl_ParseBraces) /* 360 */
#endif
#ifndef Tcl_ParseCommand
#define Tcl_ParseCommand \
(tclStubsPtr->tcl_ParseCommand) /* 361 */
#endif
#ifndef Tcl_ParseExpr
#define Tcl_ParseExpr \
(tclStubsPtr->tcl_ParseExpr) /* 362 */
#endif
#ifndef Tcl_ParseQuotedString
#define Tcl_ParseQuotedString \
(tclStubsPtr->tcl_ParseQuotedString) /* 363 */
#endif
#ifndef Tcl_ParseVarName
#define Tcl_ParseVarName \
(tclStubsPtr->tcl_ParseVarName) /* 364 */
#endif
#ifndef Tcl_GetCwd
#define Tcl_GetCwd \
(tclStubsPtr->tcl_GetCwd) /* 365 */
#endif
#ifndef Tcl_Chdir
#define Tcl_Chdir \
(tclStubsPtr->tcl_Chdir) /* 366 */
#endif
#ifndef Tcl_Access
#define Tcl_Access \
(tclStubsPtr->tcl_Access) /* 367 */
#endif
#ifndef Tcl_Stat
#define Tcl_Stat \
(tclStubsPtr->tcl_Stat) /* 368 */
#endif
#ifndef Tcl_UtfNcmp
#define Tcl_UtfNcmp \
(tclStubsPtr->tcl_UtfNcmp) /* 369 */
#endif
#ifndef Tcl_UtfNcasecmp
#define Tcl_UtfNcasecmp \
(tclStubsPtr->tcl_UtfNcasecmp) /* 370 */
#endif
#ifndef Tcl_StringCaseMatch
#define Tcl_StringCaseMatch \
(tclStubsPtr->tcl_StringCaseMatch) /* 371 */
#endif
#ifndef Tcl_UniCharIsControl
#define Tcl_UniCharIsControl \
(tclStubsPtr->tcl_UniCharIsControl) /* 372 */
#endif
#ifndef Tcl_UniCharIsGraph
#define Tcl_UniCharIsGraph \
(tclStubsPtr->tcl_UniCharIsGraph) /* 373 */
#endif
#ifndef Tcl_UniCharIsPrint
#define Tcl_UniCharIsPrint \
(tclStubsPtr->tcl_UniCharIsPrint) /* 374 */
#endif
#ifndef Tcl_UniCharIsPunct
#define Tcl_UniCharIsPunct \
(tclStubsPtr->tcl_UniCharIsPunct) /* 375 */
#endif
#ifndef Tcl_RegExpExecObj
#define Tcl_RegExpExecObj \
(tclStubsPtr->tcl_RegExpExecObj) /* 376 */
#endif
#ifndef Tcl_RegExpGetInfo
#define Tcl_RegExpGetInfo \
(tclStubsPtr->tcl_RegExpGetInfo) /* 377 */
#endif
#ifndef Tcl_NewUnicodeObj
#define Tcl_NewUnicodeObj \
(tclStubsPtr->tcl_NewUnicodeObj) /* 378 */
#endif
#ifndef Tcl_SetUnicodeObj
#define Tcl_SetUnicodeObj \
(tclStubsPtr->tcl_SetUnicodeObj) /* 379 */
#endif
#ifndef Tcl_GetCharLength
#define Tcl_GetCharLength \
(tclStubsPtr->tcl_GetCharLength) /* 380 */
#endif
#ifndef Tcl_GetUniChar
#define Tcl_GetUniChar \
(tclStubsPtr->tcl_GetUniChar) /* 381 */
#endif
#ifndef Tcl_GetUnicode
#define Tcl_GetUnicode \
(tclStubsPtr->tcl_GetUnicode) /* 382 */
#endif
#ifndef Tcl_GetRange
#define Tcl_GetRange \
(tclStubsPtr->tcl_GetRange) /* 383 */
#endif
#ifndef Tcl_AppendUnicodeToObj
#define Tcl_AppendUnicodeToObj \
(tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */
#endif
#ifndef Tcl_RegExpMatchObj
#define Tcl_RegExpMatchObj \
(tclStubsPtr->tcl_RegExpMatchObj) /* 385 */
#endif
#ifndef Tcl_SetNotifier
#define Tcl_SetNotifier \
(tclStubsPtr->tcl_SetNotifier) /* 386 */
#endif
#ifndef Tcl_GetAllocMutex
#define Tcl_GetAllocMutex \
(tclStubsPtr->tcl_GetAllocMutex) /* 387 */
#endif
#ifndef Tcl_GetChannelNames
#define Tcl_GetChannelNames \
(tclStubsPtr->tcl_GetChannelNames) /* 388 */
#endif
#ifndef Tcl_GetChannelNamesEx
#define Tcl_GetChannelNamesEx \
(tclStubsPtr->tcl_GetChannelNamesEx) /* 389 */
#endif
#ifndef Tcl_ProcObjCmd
#define Tcl_ProcObjCmd \
(tclStubsPtr->tcl_ProcObjCmd) /* 390 */
#endif
#ifndef Tcl_ConditionFinalize
#define Tcl_ConditionFinalize \
(tclStubsPtr->tcl_ConditionFinalize) /* 391 */
#endif
#ifndef Tcl_MutexFinalize
#define Tcl_MutexFinalize \
(tclStubsPtr->tcl_MutexFinalize) /* 392 */
#endif
#ifndef Tcl_CreateThread
#define Tcl_CreateThread \
(tclStubsPtr->tcl_CreateThread) /* 393 */
#endif
#ifndef Tcl_ReadRaw
#define Tcl_ReadRaw \
(tclStubsPtr->tcl_ReadRaw) /* 394 */
#endif
#ifndef Tcl_WriteRaw
#define Tcl_WriteRaw \
(tclStubsPtr->tcl_WriteRaw) /* 395 */
#endif
#ifndef Tcl_GetTopChannel
#define Tcl_GetTopChannel \
(tclStubsPtr->tcl_GetTopChannel) /* 396 */
#endif
#ifndef Tcl_ChannelBuffered
#define Tcl_ChannelBuffered \
(tclStubsPtr->tcl_ChannelBuffered) /* 397 */
#endif
#ifndef Tcl_ChannelName
#define Tcl_ChannelName \
(tclStubsPtr->tcl_ChannelName) /* 398 */
#endif
#ifndef Tcl_ChannelVersion
#define Tcl_ChannelVersion \
(tclStubsPtr->tcl_ChannelVersion) /* 399 */
#endif
#ifndef Tcl_ChannelBlockModeProc
#define Tcl_ChannelBlockModeProc \
(tclStubsPtr->tcl_ChannelBlockModeProc) /* 400 */
#endif
#ifndef Tcl_ChannelCloseProc
#define Tcl_ChannelCloseProc \
(tclStubsPtr->tcl_ChannelCloseProc) /* 401 */
#endif
#ifndef Tcl_ChannelClose2Proc
#define Tcl_ChannelClose2Proc \
(tclStubsPtr->tcl_ChannelClose2Proc) /* 402 */
#endif
#ifndef Tcl_ChannelInputProc
#define Tcl_ChannelInputProc \
(tclStubsPtr->tcl_ChannelInputProc) /* 403 */
#endif
#ifndef Tcl_ChannelOutputProc
#define Tcl_ChannelOutputProc \
(tclStubsPtr->tcl_ChannelOutputProc) /* 404 */
#endif
#ifndef Tcl_ChannelSeekProc
#define Tcl_ChannelSeekProc \
(tclStubsPtr->tcl_ChannelSeekProc) /* 405 */
#endif
#ifndef Tcl_ChannelSetOptionProc
#define Tcl_ChannelSetOptionProc \
(tclStubsPtr->tcl_ChannelSetOptionProc) /* 406 */
#endif
#ifndef Tcl_ChannelGetOptionProc
#define Tcl_ChannelGetOptionProc \
(tclStubsPtr->tcl_ChannelGetOptionProc) /* 407 */
#endif
#ifndef Tcl_ChannelWatchProc
#define Tcl_ChannelWatchProc \
(tclStubsPtr->tcl_ChannelWatchProc) /* 408 */
#endif
#ifndef Tcl_ChannelGetHandleProc
#define Tcl_ChannelGetHandleProc \
(tclStubsPtr->tcl_ChannelGetHandleProc) /* 409 */
#endif
#ifndef Tcl_ChannelFlushProc
#define Tcl_ChannelFlushProc \
(tclStubsPtr->tcl_ChannelFlushProc) /* 410 */
#endif
#ifndef Tcl_ChannelHandlerProc
#define Tcl_ChannelHandlerProc \
(tclStubsPtr->tcl_ChannelHandlerProc) /* 411 */
#endif
#ifndef Tcl_JoinThread
#define Tcl_JoinThread \
(tclStubsPtr->tcl_JoinThread) /* 412 */
#endif
#ifndef Tcl_IsChannelShared
#define Tcl_IsChannelShared \
(tclStubsPtr->tcl_IsChannelShared) /* 413 */
#endif
#ifndef Tcl_IsChannelRegistered
#define Tcl_IsChannelRegistered \
(tclStubsPtr->tcl_IsChannelRegistered) /* 414 */
#endif
#ifndef Tcl_CutChannel
#define Tcl_CutChannel \
(tclStubsPtr->tcl_CutChannel) /* 415 */
#endif
#ifndef Tcl_SpliceChannel
#define Tcl_SpliceChannel \
(tclStubsPtr->tcl_SpliceChannel) /* 416 */
#endif
#ifndef Tcl_ClearChannelHandlers
#define Tcl_ClearChannelHandlers \
(tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */
#endif
#ifndef Tcl_IsChannelExisting
#define Tcl_IsChannelExisting \
(tclStubsPtr->tcl_IsChannelExisting) /* 418 */
#endif
#ifndef Tcl_UniCharNcasecmp
#define Tcl_UniCharNcasecmp \
(tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */
#endif
#ifndef Tcl_UniCharCaseMatch
#define Tcl_UniCharCaseMatch \
(tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */
#endif
#ifndef Tcl_FindHashEntry
#define Tcl_FindHashEntry \
(tclStubsPtr->tcl_FindHashEntry) /* 421 */
#endif
#ifndef Tcl_CreateHashEntry
#define Tcl_CreateHashEntry \
(tclStubsPtr->tcl_CreateHashEntry) /* 422 */
#endif
#ifndef Tcl_InitCustomHashTable
#define Tcl_InitCustomHashTable \
(tclStubsPtr->tcl_InitCustomHashTable) /* 423 */
#endif
#ifndef Tcl_InitObjHashTable
#define Tcl_InitObjHashTable \
(tclStubsPtr->tcl_InitObjHashTable) /* 424 */
#endif
#ifndef Tcl_CommandTraceInfo
#define Tcl_CommandTraceInfo \
(tclStubsPtr->tcl_CommandTraceInfo) /* 425 */
#endif
#ifndef Tcl_TraceCommand
#define Tcl_TraceCommand \
(tclStubsPtr->tcl_TraceCommand) /* 426 */
#endif
#ifndef Tcl_UntraceCommand
#define Tcl_UntraceCommand \
(tclStubsPtr->tcl_UntraceCommand) /* 427 */
#endif
#ifndef Tcl_AttemptAlloc
#define Tcl_AttemptAlloc \
(tclStubsPtr->tcl_AttemptAlloc) /* 428 */
#endif
#ifndef Tcl_AttemptDbCkalloc
#define Tcl_AttemptDbCkalloc \
(tclStubsPtr->tcl_AttemptDbCkalloc) /* 429 */
#endif
#ifndef Tcl_AttemptRealloc
#define Tcl_AttemptRealloc \
(tclStubsPtr->tcl_AttemptRealloc) /* 430 */
#endif
#ifndef Tcl_AttemptDbCkrealloc
#define Tcl_AttemptDbCkrealloc \
(tclStubsPtr->tcl_AttemptDbCkrealloc) /* 431 */
#endif
#ifndef Tcl_AttemptSetObjLength
#define Tcl_AttemptSetObjLength \
(tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */
#endif
#ifndef Tcl_GetChannelThread
#define Tcl_GetChannelThread \
(tclStubsPtr->tcl_GetChannelThread) /* 433 */
#endif
#ifndef Tcl_GetUnicodeFromObj
#define Tcl_GetUnicodeFromObj \
(tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */
#endif
#ifndef Tcl_GetMathFuncInfo
#define Tcl_GetMathFuncInfo \
(tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */
#endif
#ifndef Tcl_ListMathFuncs
#define Tcl_ListMathFuncs \
(tclStubsPtr->tcl_ListMathFuncs) /* 436 */
#endif
#ifndef Tcl_SubstObj
#define Tcl_SubstObj \
(tclStubsPtr->tcl_SubstObj) /* 437 */
#endif
#ifndef Tcl_DetachChannel
#define Tcl_DetachChannel \
(tclStubsPtr->tcl_DetachChannel) /* 438 */
#endif
#ifndef Tcl_IsStandardChannel
#define Tcl_IsStandardChannel \
(tclStubsPtr->tcl_IsStandardChannel) /* 439 */
#endif
#ifndef Tcl_FSCopyFile
#define Tcl_FSCopyFile \
(tclStubsPtr->tcl_FSCopyFile) /* 440 */
#endif
#ifndef Tcl_FSCopyDirectory
#define Tcl_FSCopyDirectory \
(tclStubsPtr->tcl_FSCopyDirectory) /* 441 */
#endif
#ifndef Tcl_FSCreateDirectory
#define Tcl_FSCreateDirectory \
(tclStubsPtr->tcl_FSCreateDirectory) /* 442 */
#endif
#ifndef Tcl_FSDeleteFile
#define Tcl_FSDeleteFile \
(tclStubsPtr->tcl_FSDeleteFile) /* 443 */
#endif
#ifndef Tcl_FSLoadFile
#define Tcl_FSLoadFile \
(tclStubsPtr->tcl_FSLoadFile) /* 444 */
#endif
#ifndef Tcl_FSMatchInDirectory
#define Tcl_FSMatchInDirectory \
(tclStubsPtr->tcl_FSMatchInDirectory) /* 445 */
#endif
#ifndef Tcl_FSLink
#define Tcl_FSLink \
(tclStubsPtr->tcl_FSLink) /* 446 */
#endif
#ifndef Tcl_FSRemoveDirectory
#define Tcl_FSRemoveDirectory \
(tclStubsPtr->tcl_FSRemoveDirectory) /* 447 */
#endif
#ifndef Tcl_FSRenameFile
#define Tcl_FSRenameFile \
(tclStubsPtr->tcl_FSRenameFile) /* 448 */
#endif
#ifndef Tcl_FSLstat
#define Tcl_FSLstat \
(tclStubsPtr->tcl_FSLstat) /* 449 */
#endif
#ifndef Tcl_FSUtime
#define Tcl_FSUtime \
(tclStubsPtr->tcl_FSUtime) /* 450 */
#endif
#ifndef Tcl_FSFileAttrsGet
#define Tcl_FSFileAttrsGet \
(tclStubsPtr->tcl_FSFileAttrsGet) /* 451 */
#endif
#ifndef Tcl_FSFileAttrsSet
#define Tcl_FSFileAttrsSet \
(tclStubsPtr->tcl_FSFileAttrsSet) /* 452 */
#endif
#ifndef Tcl_FSFileAttrStrings
#define Tcl_FSFileAttrStrings \
(tclStubsPtr->tcl_FSFileAttrStrings) /* 453 */
#endif
#ifndef Tcl_FSStat
#define Tcl_FSStat \
(tclStubsPtr->tcl_FSStat) /* 454 */
#endif
#ifndef Tcl_FSAccess
#define Tcl_FSAccess \
(tclStubsPtr->tcl_FSAccess) /* 455 */
#endif
#ifndef Tcl_FSOpenFileChannel
#define Tcl_FSOpenFileChannel \
(tclStubsPtr->tcl_FSOpenFileChannel) /* 456 */
#endif
#ifndef Tcl_FSGetCwd
#define Tcl_FSGetCwd \
(tclStubsPtr->tcl_FSGetCwd) /* 457 */
#endif
#ifndef Tcl_FSChdir
#define Tcl_FSChdir \
(tclStubsPtr->tcl_FSChdir) /* 458 */
#endif
#ifndef Tcl_FSConvertToPathType
#define Tcl_FSConvertToPathType \
(tclStubsPtr->tcl_FSConvertToPathType) /* 459 */
#endif
#ifndef Tcl_FSJoinPath
#define Tcl_FSJoinPath \
(tclStubsPtr->tcl_FSJoinPath) /* 460 */
#endif
#ifndef Tcl_FSSplitPath
#define Tcl_FSSplitPath \
(tclStubsPtr->tcl_FSSplitPath) /* 461 */
#endif
#ifndef Tcl_FSEqualPaths
#define Tcl_FSEqualPaths \
(tclStubsPtr->tcl_FSEqualPaths) /* 462 */
#endif
#ifndef Tcl_FSGetNormalizedPath
#define Tcl_FSGetNormalizedPath \
(tclStubsPtr->tcl_FSGetNormalizedPath) /* 463 */
#endif
#ifndef Tcl_FSJoinToPath
#define Tcl_FSJoinToPath \
(tclStubsPtr->tcl_FSJoinToPath) /* 464 */
#endif
#ifndef Tcl_FSGetInternalRep
#define Tcl_FSGetInternalRep \
(tclStubsPtr->tcl_FSGetInternalRep) /* 465 */
#endif
#ifndef Tcl_FSGetTranslatedPath
#define Tcl_FSGetTranslatedPath \
(tclStubsPtr->tcl_FSGetTranslatedPath) /* 466 */
#endif
#ifndef Tcl_FSEvalFile
#define Tcl_FSEvalFile \
(tclStubsPtr->tcl_FSEvalFile) /* 467 */
#endif
#ifndef Tcl_FSNewNativePath
#define Tcl_FSNewNativePath \
(tclStubsPtr->tcl_FSNewNativePath) /* 468 */
#endif
#ifndef Tcl_FSGetNativePath
#define Tcl_FSGetNativePath \
(tclStubsPtr->tcl_FSGetNativePath) /* 469 */
#endif
#ifndef Tcl_FSFileSystemInfo
#define Tcl_FSFileSystemInfo \
(tclStubsPtr->tcl_FSFileSystemInfo) /* 470 */
#endif
#ifndef Tcl_FSPathSeparator
#define Tcl_FSPathSeparator \
(tclStubsPtr->tcl_FSPathSeparator) /* 471 */
#endif
#ifndef Tcl_FSListVolumes
#define Tcl_FSListVolumes \
(tclStubsPtr->tcl_FSListVolumes) /* 472 */
#endif
#ifndef Tcl_FSRegister
#define Tcl_FSRegister \
(tclStubsPtr->tcl_FSRegister) /* 473 */
#endif
#ifndef Tcl_FSUnregister
#define Tcl_FSUnregister \
(tclStubsPtr->tcl_FSUnregister) /* 474 */
#endif
#ifndef Tcl_FSData
#define Tcl_FSData \
(tclStubsPtr->tcl_FSData) /* 475 */
#endif
#ifndef Tcl_FSGetTranslatedStringPath
#define Tcl_FSGetTranslatedStringPath \
(tclStubsPtr->tcl_FSGetTranslatedStringPath) /* 476 */
#endif
#ifndef Tcl_FSGetFileSystemForPath
#define Tcl_FSGetFileSystemForPath \
(tclStubsPtr->tcl_FSGetFileSystemForPath) /* 477 */
#endif
#ifndef Tcl_FSGetPathType
#define Tcl_FSGetPathType \
(tclStubsPtr->tcl_FSGetPathType) /* 478 */
#endif
#ifndef Tcl_OutputBuffered
#define Tcl_OutputBuffered \
(tclStubsPtr->tcl_OutputBuffered) /* 479 */
#endif
#ifndef Tcl_FSMountsChanged
#define Tcl_FSMountsChanged \
(tclStubsPtr->tcl_FSMountsChanged) /* 480 */
#endif
#ifndef Tcl_EvalTokensStandard
#define Tcl_EvalTokensStandard \
(tclStubsPtr->tcl_EvalTokensStandard) /* 481 */
#endif
#ifndef Tcl_GetTime
#define Tcl_GetTime \
(tclStubsPtr->tcl_GetTime) /* 482 */
#endif
#ifndef Tcl_CreateObjTrace
#define Tcl_CreateObjTrace \
(tclStubsPtr->tcl_CreateObjTrace) /* 483 */
#endif
#ifndef Tcl_GetCommandInfoFromToken
#define Tcl_GetCommandInfoFromToken \
(tclStubsPtr->tcl_GetCommandInfoFromToken) /* 484 */
#endif
#ifndef Tcl_SetCommandInfoFromToken
#define Tcl_SetCommandInfoFromToken \
(tclStubsPtr->tcl_SetCommandInfoFromToken) /* 485 */
#endif
#ifndef Tcl_DbNewWideIntObj
#define Tcl_DbNewWideIntObj \
(tclStubsPtr->tcl_DbNewWideIntObj) /* 486 */
#endif
#ifndef Tcl_GetWideIntFromObj
#define Tcl_GetWideIntFromObj \
(tclStubsPtr->tcl_GetWideIntFromObj) /* 487 */
#endif
#ifndef Tcl_NewWideIntObj
#define Tcl_NewWideIntObj \
(tclStubsPtr->tcl_NewWideIntObj) /* 488 */
#endif
#ifndef Tcl_SetWideIntObj
#define Tcl_SetWideIntObj \
(tclStubsPtr->tcl_SetWideIntObj) /* 489 */
#endif
#ifndef Tcl_AllocStatBuf
#define Tcl_AllocStatBuf \
(tclStubsPtr->tcl_AllocStatBuf) /* 490 */
#endif
#ifndef Tcl_Seek
#define Tcl_Seek \
(tclStubsPtr->tcl_Seek) /* 491 */
#endif
#ifndef Tcl_Tell
#define Tcl_Tell \
(tclStubsPtr->tcl_Tell) /* 492 */
#endif
#ifndef Tcl_ChannelWideSeekProc
#define Tcl_ChannelWideSeekProc \
(tclStubsPtr->tcl_ChannelWideSeekProc) /* 493 */
#endif
/* Slot 494 is reserved */
/* Slot 495 is reserved */
/* Slot 496 is reserved */
/* Slot 497 is reserved */
/* Slot 498 is reserved */
/* Slot 499 is reserved */
/* Slot 500 is reserved */
/* Slot 501 is reserved */
/* Slot 502 is reserved */
/* Slot 503 is reserved */
/* Slot 504 is reserved */
/* Slot 505 is reserved */
/* Slot 506 is reserved */
/* Slot 507 is reserved */
/* Slot 508 is reserved */
/* Slot 509 is reserved */
/* Slot 510 is reserved */
/* Slot 511 is reserved */
/* Slot 512 is reserved */
/* Slot 513 is reserved */
/* Slot 514 is reserved */
/* Slot 515 is reserved */
/* Slot 516 is reserved */
/* Slot 517 is reserved */
/* Slot 518 is reserved */
/* Slot 519 is reserved */
/* Slot 520 is reserved */
/* Slot 521 is reserved */
/* Slot 522 is reserved */
/* Slot 523 is reserved */
/* Slot 524 is reserved */
/* Slot 525 is reserved */
/* Slot 526 is reserved */
/* Slot 527 is reserved */
/* Slot 528 is reserved */
/* Slot 529 is reserved */
/* Slot 530 is reserved */
/* Slot 531 is reserved */
/* Slot 532 is reserved */
/* Slot 533 is reserved */
/* Slot 534 is reserved */
/* Slot 535 is reserved */
/* Slot 536 is reserved */
/* Slot 537 is reserved */
/* Slot 538 is reserved */
/* Slot 539 is reserved */
/* Slot 540 is reserved */
/* Slot 541 is reserved */
/* Slot 542 is reserved */
/* Slot 543 is reserved */
/* Slot 544 is reserved */
/* Slot 545 is reserved */
/* Slot 546 is reserved */
/* Slot 547 is reserved */
/* Slot 548 is reserved */
/* Slot 549 is reserved */
/* Slot 550 is reserved */
/* Slot 551 is reserved */
/* Slot 552 is reserved */
/* Slot 553 is reserved */
#ifndef Tcl_ChannelThreadActionProc
#define Tcl_ChannelThreadActionProc \
(tclStubsPtr->tcl_ChannelThreadActionProc) /* 554 */
#endif
/* Slot 555 is reserved */
/* Slot 556 is reserved */
/* Slot 557 is reserved */
/* Slot 558 is reserved */
/* Slot 559 is reserved */
/* Slot 560 is reserved */
/* Slot 561 is reserved */
/* Slot 562 is reserved */
/* Slot 563 is reserved */
/* Slot 564 is reserved */
/* Slot 565 is reserved */
/* Slot 566 is reserved */
/* Slot 567 is reserved */
/* Slot 568 is reserved */
/* Slot 569 is reserved */
/* Slot 570 is reserved */
/* Slot 571 is reserved */
/* Slot 572 is reserved */
#ifndef Tcl_PkgRequireProc
#define Tcl_PkgRequireProc \
(tclStubsPtr->tcl_PkgRequireProc) /* 573 */
#endif
/* Slot 574 is reserved */
/* Slot 575 is reserved */
/* Slot 576 is reserved */
/* Slot 577 is reserved */
/* Slot 578 is reserved */
/* Slot 579 is reserved */
/* Slot 580 is reserved */
/* Slot 581 is reserved */
/* Slot 582 is reserved */
/* Slot 583 is reserved */
/* Slot 584 is reserved */
/* Slot 585 is reserved */
/* Slot 586 is reserved */
/* Slot 587 is reserved */
/* Slot 588 is reserved */
/* Slot 589 is reserved */
/* Slot 590 is reserved */
/* Slot 591 is reserved */
/* Slot 592 is reserved */
/* Slot 593 is reserved */
/* Slot 594 is reserved */
/* Slot 595 is reserved */
/* Slot 596 is reserved */
/* Slot 597 is reserved */
/* Slot 598 is reserved */
/* Slot 599 is reserved */
/* Slot 600 is reserved */
/* Slot 601 is reserved */
/* Slot 602 is reserved */
/* Slot 603 is reserved */
/* Slot 604 is reserved */
/* Slot 605 is reserved */
/* Slot 606 is reserved */
/* Slot 607 is reserved */
/* Slot 608 is reserved */
/* Slot 609 is reserved */
/* Slot 610 is reserved */
/* Slot 611 is reserved */
/* Slot 612 is reserved */
/* Slot 613 is reserved */
/* Slot 614 is reserved */
/* Slot 615 is reserved */
/* Slot 616 is reserved */
/* Slot 617 is reserved */
/* Slot 618 is reserved */
/* Slot 619 is reserved */
/* Slot 620 is reserved */
/* Slot 621 is reserved */
/* Slot 622 is reserved */
/* Slot 623 is reserved */
/* Slot 624 is reserved */
/* Slot 625 is reserved */
/* Slot 626 is reserved */
/* Slot 627 is reserved */
/* Slot 628 is reserved */
/* Slot 629 is reserved */
#ifndef TclUnusedStubEntry
#define TclUnusedStubEntry \
(tclStubsPtr->tclUnusedStubEntry) /* 630 */
#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
/* !END!: Do not edit above this line. */
#undef TclUnusedStubEntry
#undef Tcl_PkgPresent
#define Tcl_PkgPresent(interp, name, version, exact) \
Tcl_PkgPresentEx(interp, name, version, exact, NULL)
#undef Tcl_PkgProvide
#define Tcl_PkgProvide(interp, name, version) \
Tcl_PkgProvideEx(interp, name, version, NULL)
#undef Tcl_PkgRequire
#define Tcl_PkgRequire(interp, name, version, exact) \
Tcl_PkgRequireEx(interp, name, version, exact, NULL)
#undef Tcl_GetIndexFromObj
#define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \
Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, \
sizeof(char *), msg, flags, indexPtr)
#undef Tcl_SetVar
#define Tcl_SetVar(interp, varName, newValue, flags) \
Tcl_SetVar2(interp, varName, NULL, newValue, flags)
#undef Tcl_UnsetVar
#define Tcl_UnsetVar(interp, varName, flags) \
Tcl_UnsetVar2(interp, varName, NULL, flags)
#undef Tcl_GetVar
#define Tcl_GetVar(interp, varName, flags) \
Tcl_GetVar2(interp, varName, NULL, flags)
#undef Tcl_TraceVar
#define Tcl_TraceVar(interp, varName, flags, proc, clientData) \
Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData)
#undef Tcl_UntraceVar
#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \
Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData)
#undef Tcl_VarTraceInfo
#define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \
Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData)
#undef Tcl_UpVar
#define Tcl_UpVar(interp, frameName, varName, localName, flags) \
Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags)
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
# if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG)
/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
* we have to make sure that all stub entries on Cygwin64 follow the
* Win64 signature. Cygwin64 stubbed extensions cannot use those stub
* entries any more, they should use the 64-bit alternatives where
* possible. Tcl 9 must find a better solution, but that cannot be done
* without introducing a binary incompatibility.
*/
# undef Tcl_DbNewLongObj
# undef Tcl_GetLongFromObj
# undef Tcl_NewLongObj
# undef Tcl_SetLongObj
# undef Tcl_ExprLong
# undef Tcl_ExprLongObj
# undef Tcl_UniCharNcmp
# undef Tcl_UtfNcmp
# undef Tcl_UtfNcasecmp
# undef Tcl_UniCharNcasecmp
# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj)
# define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj)
# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj)
# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj)
# define Tcl_ExprLong TclExprLong
static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){
int intValue;
int result = tclStubsPtr->tcl_ExprLong(interp, string, (long *)&intValue);
if (result == TCL_OK) *ptr = (long)intValue;
return result;
}
# define Tcl_ExprLongObj TclExprLongObj
static inline int TclExprLongObj(Tcl_Interp *interp, Tcl_Obj *obj, long *ptr){
int intValue;
int result = tclStubsPtr->tcl_ExprLongObj(interp, obj, (long *)&intValue);
if (result == TCL_OK) *ptr = (long)intValue;
return result;
}
# define Tcl_UniCharNcmp(ucs,uct,n) \
((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n))
# define Tcl_UtfNcmp(s1,s2,n) \
((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n))
# define Tcl_UtfNcasecmp(s1,s2,n) \
((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n))
# define Tcl_UniCharNcasecmp(ucs,uct,n) \
((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n))
# endif
#endif
/*
* Deprecated Tcl procedures:
*/
#undef Tcl_EvalObj
#define Tcl_EvalObj(interp,objPtr) \
Tcl_EvalObjEx((interp),(objPtr),0)
#undef Tcl_GlobalEvalObj
#define Tcl_GlobalEvalObj(interp,objPtr) \
Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)
#endif /* _TCLDECLS */
tcl8.4.20/generic/tclScan.c 0000644 0036047 0045461 00000064562 11737050674 014103 0 ustar dgp 771div /*
* tclScan.c --
*
* This file contains the implementation of the "scan" command.
*
* Copyright (c) 1998 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* For strtoll() and strtoull() declarations on some platforms...
*/
#include "tclPort.h"
/*
* Flag values used by Tcl_ScanObjCmd.
*/
#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */
#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */
#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */
#define SCAN_WIDTH 0x8 /* A width value was supplied. */
#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */
#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */
#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */
#define SCAN_XOK 0x80 /* An 'x' is allowed. */
#define SCAN_PTOK 0x100 /* Decimal point is allowed. */
#define SCAN_EXPOK 0x200 /* An exponent is allowed. */
#define SCAN_LONGER 0x400 /* Asked for a wide value. */
/*
* The following structure contains the information associated with
* a character set.
*/
typedef struct CharSet {
int exclude; /* 1 if this is an exclusion set. */
int nchars;
Tcl_UniChar *chars;
int nranges;
struct Range {
Tcl_UniChar start;
Tcl_UniChar end;
} *ranges;
} CharSet;
/*
* Declarations for functions used only in this file.
*/
static char * BuildCharSet _ANSI_ARGS_((CharSet *cset, char *format));
static int CharInSet _ANSI_ARGS_((CharSet *cset, int ch));
static void ReleaseCharSet _ANSI_ARGS_((CharSet *cset));
static int ValidateFormat _ANSI_ARGS_((Tcl_Interp *interp, char *format,
int numVars, int *totalVars));
/*
*----------------------------------------------------------------------
*
* BuildCharSet --
*
* This function examines a character set format specification
* and builds a CharSet containing the individual characters and
* character ranges specified.
*
* Results:
* Returns the next format position.
*
* Side effects:
* Initializes the charset.
*
*----------------------------------------------------------------------
*/
static char *
BuildCharSet(cset, format)
CharSet *cset;
char *format; /* Points to first char of set. */
{
Tcl_UniChar ch, start;
int offset, nranges;
char *end;
memset(cset, 0, sizeof(CharSet));
offset = Tcl_UtfToUniChar(format, &ch);
if (ch == '^') {
cset->exclude = 1;
format += offset;
offset = Tcl_UtfToUniChar(format, &ch);
}
end = format + offset;
/*
* Find the close bracket so we can overallocate the set.
*/
if (ch == ']') {
end += Tcl_UtfToUniChar(end, &ch);
}
nranges = 0;
while (ch != ']') {
if (ch == '-') {
nranges++;
}
end += Tcl_UtfToUniChar(end, &ch);
}
cset->chars = (Tcl_UniChar *) ckalloc(sizeof(Tcl_UniChar)
* (end - format - 1));
if (nranges > 0) {
cset->ranges = (struct Range *) ckalloc(sizeof(struct Range)*nranges);
} else {
cset->ranges = NULL;
}
/*
* Now build the character set.
*/
cset->nchars = cset->nranges = 0;
format += Tcl_UtfToUniChar(format, &ch);
start = ch;
if (ch == ']' || ch == '-') {
cset->chars[cset->nchars++] = ch;
format += Tcl_UtfToUniChar(format, &ch);
}
while (ch != ']') {
if (*format == '-') {
/*
* This may be the first character of a range, so don't add
* it yet.
*/
start = ch;
} else if (ch == '-') {
/*
* Check to see if this is the last character in the set, in which
* case it is not a range and we should add the previous character
* as well as the dash.
*/
if (*format == ']') {
cset->chars[cset->nchars++] = start;
cset->chars[cset->nchars++] = ch;
} else {
format += Tcl_UtfToUniChar(format, &ch);
/*
* Check to see if the range is in reverse order.
*/
if (start < ch) {
cset->ranges[cset->nranges].start = start;
cset->ranges[cset->nranges].end = ch;
} else {
cset->ranges[cset->nranges].start = ch;
cset->ranges[cset->nranges].end = start;
}
cset->nranges++;
}
} else {
cset->chars[cset->nchars++] = ch;
}
format += Tcl_UtfToUniChar(format, &ch);
}
return format;
}
/*
*----------------------------------------------------------------------
*
* CharInSet --
*
* Check to see if a character matches the given set.
*
* Results:
* Returns non-zero if the character matches the given set.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CharInSet(cset, c)
CharSet *cset;
int c; /* Character to test, passed as int because
* of non-ANSI prototypes. */
{
Tcl_UniChar ch = (Tcl_UniChar) c;
int i, match = 0;
for (i = 0; i < cset->nchars; i++) {
if (cset->chars[i] == ch) {
match = 1;
break;
}
}
if (!match) {
for (i = 0; i < cset->nranges; i++) {
if ((cset->ranges[i].start <= ch)
&& (ch <= cset->ranges[i].end)) {
match = 1;
break;
}
}
}
return (cset->exclude ? !match : match);
}
/*
*----------------------------------------------------------------------
*
* ReleaseCharSet --
*
* Free the storage associated with a character set.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
ReleaseCharSet(cset)
CharSet *cset;
{
ckfree((char *)cset->chars);
if (cset->ranges) {
ckfree((char *)cset->ranges);
}
}
/*
*----------------------------------------------------------------------
*
* ValidateFormat --
*
* Parse the format string and verify that it is properly formed
* and that there are exactly enough variables on the command line.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May place an error in the interpreter result.
*
*----------------------------------------------------------------------
*/
static int
ValidateFormat(interp, format, numVars, totalSubs)
Tcl_Interp *interp; /* Current interpreter. */
char *format; /* The format string. */
int numVars; /* The number of variables passed to the
* scan command. */
int *totalSubs; /* The number of variables that will be
* required. */
{
#define STATIC_LIST_SIZE 16
int gotXpg, gotSequential, value, i, flags;
char *end;
Tcl_UniChar ch;
int staticAssign[STATIC_LIST_SIZE];
int *nassign = staticAssign;
int objIndex, xpgSize, nspace = STATIC_LIST_SIZE;
char buf[TCL_UTF_MAX+1];
/*
* Initialize an array that records the number of times a variable
* is assigned to by the format string. We use this to detect if
* a variable is multiply assigned or left unassigned.
*/
if (numVars > nspace) {
nassign = (int*)ckalloc(sizeof(int) * numVars);
nspace = numVars;
}
for (i = 0; i < nspace; i++) {
nassign[i] = 0;
}
xpgSize = objIndex = gotXpg = gotSequential = 0;
while (*format != '\0') {
format += Tcl_UtfToUniChar(format, &ch);
flags = 0;
if (ch != '%') {
continue;
}
format += Tcl_UtfToUniChar(format, &ch);
if (ch == '%') {
continue;
}
if (ch == '*') {
flags |= SCAN_SUPPRESS;
format += Tcl_UtfToUniChar(format, &ch);
goto xpgCheckDone;
}
if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
/*
* Check for an XPG3-style %n$ specification. Note: there
* must not be a mixture of XPG3 specs and non-XPG3 specs
* in the same format string.
*/
value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */
if (*end != '$') {
goto notXpg;
}
format = end+1;
format += Tcl_UtfToUniChar(format, &ch);
gotXpg = 1;
if (gotSequential) {
goto mixedXPG;
}
objIndex = value - 1;
if ((objIndex < 0) || (numVars && (objIndex >= numVars))) {
goto badIndex;
} else if (numVars == 0) {
/*
* In the case where no vars are specified, the user can
* specify %9999$ legally, so we have to consider special
* rules for growing the assign array. 'value' is
* guaranteed to be > 0.
*/
xpgSize = (xpgSize > value) ? xpgSize : value;
}
goto xpgCheckDone;
}
notXpg:
gotSequential = 1;
if (gotXpg) {
mixedXPG:
Tcl_SetResult(interp,
"cannot mix \"%\" and \"%n$\" conversion specifiers",
TCL_STATIC);
goto error;
}
xpgCheckDone:
/*
* Parse any width specifier.
*/
if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
value = strtoul(format-1, &format, 10); /* INTL: "C" locale. */
flags |= SCAN_WIDTH;
format += Tcl_UtfToUniChar(format, &ch);
}
/*
* Handle any size specifier.
*/
switch (ch) {
case 'l':
case 'L':
flags |= SCAN_LONGER;
case 'h':
format += Tcl_UtfToUniChar(format, &ch);
}
if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
goto badIndex;
}
/*
* Handle the various field types.
*/
switch (ch) {
case 'c':
if (flags & SCAN_WIDTH) {
Tcl_SetResult(interp,
"field width may not be specified in %c conversion",
TCL_STATIC);
goto error;
}
/*
* Fall through!
*/
case 'n':
case 's':
if (flags & SCAN_LONGER) {
invalidLonger:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"'l' modifier may not be specified in %", buf,
" conversion", NULL);
goto error;
}
/*
* Fall through!
*/
case 'd':
case 'e':
case 'f':
case 'g':
case 'i':
case 'o':
case 'u':
case 'x':
break;
/*
* Bracket terms need special checking
*/
case '[':
if (flags & SCAN_LONGER) {
goto invalidLonger;
}
if (*format == '\0') {
goto badSet;
}
format += Tcl_UtfToUniChar(format, &ch);
if (ch == '^') {
if (*format == '\0') {
goto badSet;
}
format += Tcl_UtfToUniChar(format, &ch);
}
if (ch == ']') {
if (*format == '\0') {
goto badSet;
}
format += Tcl_UtfToUniChar(format, &ch);
}
while (ch != ']') {
if (*format == '\0') {
goto badSet;
}
format += Tcl_UtfToUniChar(format, &ch);
}
break;
badSet:
Tcl_SetResult(interp, "unmatched [ in format string",
TCL_STATIC);
goto error;
default:
{
char buf[TCL_UTF_MAX+1];
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad scan conversion character \"", buf, "\"", NULL);
goto error;
}
}
if (!(flags & SCAN_SUPPRESS)) {
if (objIndex >= nspace) {
/*
* Expand the nassign buffer. If we are using XPG specifiers,
* make sure that we grow to a large enough size. xpgSize is
* guaranteed to be at least one larger than objIndex.
*/
value = nspace;
if (xpgSize) {
nspace = xpgSize;
} else {
nspace += STATIC_LIST_SIZE;
}
if (nassign == staticAssign) {
nassign = (void *)ckalloc(nspace * sizeof(int));
for (i = 0; i < STATIC_LIST_SIZE; ++i) {
nassign[i] = staticAssign[i];
}
} else {
nassign = (void *)ckrealloc((void *)nassign,
nspace * sizeof(int));
}
for (i = value; i < nspace; i++) {
nassign[i] = 0;
}
}
nassign[objIndex]++;
objIndex++;
}
}
/*
* Verify that all of the variable were assigned exactly once.
*/
if (numVars == 0) {
if (xpgSize) {
numVars = xpgSize;
} else {
numVars = objIndex;
}
}
if (totalSubs) {
*totalSubs = numVars;
}
for (i = 0; i < numVars; i++) {
if (nassign[i] > 1) {
Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC);
goto error;
} else if (!xpgSize && (nassign[i] == 0)) {
/*
* If the space is empty, and xpgSize is 0 (means XPG wasn't
* used, and/or numVars != 0), then too many vars were given
*/
Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", TCL_STATIC);
goto error;
}
}
if (nassign != staticAssign) {
ckfree((char *)nassign);
}
return TCL_OK;
badIndex:
if (gotXpg) {
Tcl_SetResult(interp, "\"%n$\" argument index out of range",
TCL_STATIC);
} else {
Tcl_SetResult(interp,
"different numbers of variable names and field specifiers",
TCL_STATIC);
}
error:
if (nassign != staticAssign) {
ckfree((char *)nassign);
}
return TCL_ERROR;
#undef STATIC_LIST_SIZE
}
/*
*----------------------------------------------------------------------
*
* Tcl_ScanObjCmd --
*
* This procedure is invoked to process the "scan" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ScanObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *format;
int numVars, nconversions, totalVars = -1;
int objIndex, offset, i, result, code;
long value;
char *string, *end, *baseString;
char op = 0;
int base = 0;
int underflow = 0;
size_t width;
long (*fn)() = NULL;
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt (*lfn)() = NULL;
Tcl_WideInt wideValue;
#endif
Tcl_UniChar ch, sch;
Tcl_Obj **objs = NULL, *objPtr = NULL;
int flags;
char buf[513]; /* Temporary buffer to hold scanned
* number strings before they are
* passed to strtoul. */
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"string format ?varName varName ...?");
return TCL_ERROR;
}
format = Tcl_GetStringFromObj(objv[2], NULL);
numVars = objc-3;
/*
* Check for errors in the format string.
*/
if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Allocate space for the result objects.
*/
if (totalVars > 0) {
objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * totalVars);
for (i = 0; i < totalVars; i++) {
objs[i] = NULL;
}
}
string = Tcl_GetStringFromObj(objv[1], NULL);
baseString = string;
/*
* Iterate over the format string filling in the result objects until
* we reach the end of input, the end of the format string, or there
* is a mismatch.
*/
objIndex = 0;
nconversions = 0;
while (*format != '\0') {
format += Tcl_UtfToUniChar(format, &ch);
flags = 0;
/*
* If we see whitespace in the format, skip whitespace in the string.
*/
if (Tcl_UniCharIsSpace(ch)) {
offset = Tcl_UtfToUniChar(string, &sch);
while (Tcl_UniCharIsSpace(sch)) {
if (*string == '\0') {
goto done;
}
string += offset;
offset = Tcl_UtfToUniChar(string, &sch);
}
continue;
}
if (ch != '%') {
literal:
if (*string == '\0') {
underflow = 1;
goto done;
}
string += Tcl_UtfToUniChar(string, &sch);
if (ch != sch) {
goto done;
}
continue;
}
format += Tcl_UtfToUniChar(format, &ch);
if (ch == '%') {
goto literal;
}
/*
* Check for assignment suppression ('*') or an XPG3-style
* assignment ('%n$').
*/
if (ch == '*') {
flags |= SCAN_SUPPRESS;
format += Tcl_UtfToUniChar(format, &ch);
} else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */
if (*end == '$') {
format = end+1;
format += Tcl_UtfToUniChar(format, &ch);
objIndex = (int) value - 1;
}
}
/*
* Parse any width specifier.
*/
if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
width = strtoul(format-1, &format, 10); /* INTL: "C" locale. */
format += Tcl_UtfToUniChar(format, &ch);
} else {
width = 0;
}
/*
* Handle any size specifier.
*/
switch (ch) {
case 'l':
case 'L':
flags |= SCAN_LONGER;
/*
* Fall through so we skip to the next character.
*/
case 'h':
format += Tcl_UtfToUniChar(format, &ch);
}
/*
* Handle the various field types.
*/
switch (ch) {
case 'n':
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewIntObj(string - baseString);
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
}
nconversions++;
continue;
case 'd':
op = 'i';
base = 10;
fn = (long (*)())strtol;
#ifndef TCL_WIDE_INT_IS_LONG
lfn = (Tcl_WideInt (*)())strtoll;
#endif
break;
case 'i':
op = 'i';
base = 0;
fn = (long (*)())strtol;
#ifndef TCL_WIDE_INT_IS_LONG
lfn = (Tcl_WideInt (*)())strtoll;
#endif
break;
case 'o':
op = 'i';
base = 8;
fn = (long (*)())strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
lfn = (Tcl_WideInt (*)())strtoull;
#endif
break;
case 'x':
op = 'i';
base = 16;
fn = (long (*)())strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
lfn = (Tcl_WideInt (*)())strtoull;
#endif
break;
case 'u':
op = 'i';
base = 10;
flags |= SCAN_UNSIGNED;
fn = (long (*)())strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
lfn = (Tcl_WideInt (*)())strtoull;
#endif
break;
case 'f':
case 'e':
case 'g':
op = 'f';
break;
case 's':
op = 's';
break;
case 'c':
op = 'c';
flags |= SCAN_NOSKIP;
break;
case '[':
op = '[';
flags |= SCAN_NOSKIP;
break;
}
/*
* At this point, we will need additional characters from the
* string to proceed.
*/
if (*string == '\0') {
underflow = 1;
goto done;
}
/*
* Skip any leading whitespace at the beginning of a field unless
* the format suppresses this behavior.
*/
if (!(flags & SCAN_NOSKIP)) {
while (*string != '\0') {
offset = Tcl_UtfToUniChar(string, &sch);
if (!Tcl_UniCharIsSpace(sch)) {
break;
}
string += offset;
}
if (*string == '\0') {
underflow = 1;
goto done;
}
}
/*
* Perform the requested scanning operation.
*/
switch (op) {
case 's':
/*
* Scan a string up to width characters or whitespace.
*/
if (width == 0) {
width = (size_t) ~0;
}
end = string;
while (*end != '\0') {
offset = Tcl_UtfToUniChar(end, &sch);
if (Tcl_UniCharIsSpace(sch)) {
break;
}
end += offset;
if (--width == 0) {
break;
}
}
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewStringObj(string, end-string);
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
}
string = end;
break;
case '[': {
CharSet cset;
if (width == 0) {
width = (size_t) ~0;
}
end = string;
format = BuildCharSet(&cset, format);
while (*end != '\0') {
offset = Tcl_UtfToUniChar(end, &sch);
if (!CharInSet(&cset, (int)sch)) {
break;
}
end += offset;
if (--width == 0) {
break;
}
}
ReleaseCharSet(&cset);
if (string == end) {
/*
* Nothing matched the range, stop processing
*/
goto done;
}
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewStringObj(string, end-string);
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
}
string = end;
break;
}
case 'c':
/*
* Scan a single Unicode character.
*/
string += Tcl_UtfToUniChar(string, &sch);
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewIntObj((int)sch);
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
}
break;
case 'i':
/*
* Scan an unsigned or signed integer.
*/
if ((width == 0) || (width > sizeof(buf) - 1)) {
width = sizeof(buf) - 1;
}
flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO;
for (end = buf; width > 0; width--) {
switch (*string) {
/*
* The 0 digit has special meaning at the beginning of
* a number. If we are unsure of the base, it
* indicates that we are in base 8 or base 16 (if it is
* followed by an 'x').
*
* 8.1 - 8.3.4 incorrectly handled 0x... base-16
* cases for %x by not reading the 0x as the
* auto-prelude for base-16. [Bug #495213]
*/
case '0':
if (base == 0) {
base = 8;
flags |= SCAN_XOK;
}
if (base == 16) {
flags |= SCAN_XOK;
}
if (flags & SCAN_NOZERO) {
flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS
| SCAN_NOZERO);
} else {
flags &= ~(SCAN_SIGNOK | SCAN_XOK
| SCAN_NODIGITS);
}
goto addToInt;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7':
if (base == 0) {
base = 10;
}
flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
goto addToInt;
case '8': case '9':
if (base == 0) {
base = 10;
}
if (base <= 8) {
break;
}
flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
goto addToInt;
case 'A': case 'B': case 'C':
case 'D': case 'E': case 'F':
case 'a': case 'b': case 'c':
case 'd': case 'e': case 'f':
if (base <= 10) {
break;
}
flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
goto addToInt;
case '+': case '-':
if (flags & SCAN_SIGNOK) {
flags &= ~SCAN_SIGNOK;
goto addToInt;
}
break;
case 'x': case 'X':
if ((flags & SCAN_XOK) && (end == buf+1)) {
base = 16;
flags &= ~SCAN_XOK;
goto addToInt;
}
break;
}
/*
* We got an illegal character so we are done accumulating.
*/
break;
addToInt:
/*
* Add the character to the temporary buffer.
*/
*end++ = *string++;
if (*string == '\0') {
break;
}
}
/*
* Check to see if we need to back up because we only got a
* sign or a trailing x after a 0.
*/
if (flags & SCAN_NODIGITS) {
if (*string == '\0') {
underflow = 1;
}
goto done;
} else if (end[-1] == 'x' || end[-1] == 'X') {
end--;
string--;
}
/*
* Scan the value from the temporary buffer. If we are
* returning a large unsigned value, we have to convert it back
* to a string since Tcl only supports signed values.
*/
if (!(flags & SCAN_SUPPRESS)) {
*end = '\0';
#ifndef TCL_WIDE_INT_IS_LONG
if (flags & SCAN_LONGER) {
wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base);
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
/* INTL: ISO digit */
sprintf(buf, "%" TCL_LL_MODIFIER "u",
(Tcl_WideUInt)wideValue);
objPtr = Tcl_NewStringObj(buf, -1);
} else {
objPtr = Tcl_NewWideIntObj(wideValue);
}
} else {
#endif /* !TCL_WIDE_INT_IS_LONG */
value = (long) (*fn)(buf, NULL, base);
if ((flags & SCAN_UNSIGNED) && (value < 0)) {
sprintf(buf, "%lu", value); /* INTL: ISO digit */
objPtr = Tcl_NewStringObj(buf, -1);
} else if ((flags & SCAN_LONGER)
|| (unsigned long) value > UINT_MAX) {
objPtr = Tcl_NewLongObj(value);
} else {
objPtr = Tcl_NewIntObj(value);
}
#ifndef TCL_WIDE_INT_IS_LONG
}
#endif
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
}
break;
case 'f':
/*
* Scan a floating point number
*/
if ((width == 0) || (width > sizeof(buf) - 1)) {
width = sizeof(buf) - 1;
}
flags &= ~SCAN_LONGER;
flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK;
for (end = buf; width > 0; width--) {
switch (*string) {
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
case '8': case '9':
flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS);
goto addToFloat;
case '+': case '-':
if (flags & SCAN_SIGNOK) {
flags &= ~SCAN_SIGNOK;
goto addToFloat;
}
break;
case '.':
if (flags & SCAN_PTOK) {
flags &= ~(SCAN_SIGNOK | SCAN_PTOK);
goto addToFloat;
}
break;
case 'e': case 'E':
/*
* An exponent is not allowed until there has
* been at least one digit.
*/
if ((flags & (SCAN_NODIGITS | SCAN_EXPOK))
== SCAN_EXPOK) {
flags = (flags & ~(SCAN_EXPOK|SCAN_PTOK))
| SCAN_SIGNOK | SCAN_NODIGITS;
goto addToFloat;
}
break;
}
/*
* We got an illegal character so we are done accumulating.
*/
break;
addToFloat:
/*
* Add the character to the temporary buffer.
*/
*end++ = *string++;
if (*string == '\0') {
break;
}
}
/*
* Check to see if we need to back up because we saw a
* trailing 'e' or sign.
*/
if (flags & SCAN_NODIGITS) {
if (flags & SCAN_EXPOK) {
/*
* There were no digits at all so scanning has
* failed and we are done.
*/
if (*string == '\0') {
underflow = 1;
}
goto done;
}
/*
* We got a bad exponent ('e' and maybe a sign).
*/
end--;
string--;
if (*end != 'e' && *end != 'E') {
end--;
string--;
}
}
/*
* Scan the value from the temporary buffer.
*/
if (!(flags & SCAN_SUPPRESS)) {
double dvalue;
*end = '\0';
dvalue = strtod(buf, NULL);
objPtr = Tcl_NewDoubleObj(dvalue);
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
}
break;
}
nconversions++;
}
done:
result = 0;
code = TCL_OK;
if (numVars) {
/*
* In this case, variables were specified (classic scan)
*/
for (i = 0; i < totalVars; i++) {
if (objs[i] != NULL) {
Tcl_Obj *tmpPtr;
result++;
tmpPtr = Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0);
Tcl_DecrRefCount(objs[i]);
if (tmpPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't set variable \"",
Tcl_GetString(objv[i+3]), "\"", (char *) NULL);
code = TCL_ERROR;
}
}
}
} else {
/*
* Here no vars were specified, we want a list returned (inline scan)
*/
objPtr = Tcl_NewObj();
for (i = 0; i < totalVars; i++) {
if (objs[i] != NULL) {
Tcl_ListObjAppendElement(NULL, objPtr, objs[i]);
Tcl_DecrRefCount(objs[i]);
} else {
/*
* More %-specifiers than matching chars, so we
* just spit out empty strings for these
*/
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj());
}
}
}
if (objs != NULL) {
ckfree((char*) objs);
}
if (code == TCL_OK) {
if (underflow && (nconversions == 0)) {
if (numVars) {
objPtr = Tcl_NewIntObj(-1);
} else {
if (objPtr) {
Tcl_SetListObj(objPtr, 0, NULL);
} else {
objPtr = Tcl_NewObj();
}
}
} else if (numVars) {
objPtr = Tcl_NewIntObj(result);
}
Tcl_SetObjResult(interp, objPtr);
}
return code;
}
tcl8.4.20/generic/tclInt.h 0000644 0036047 0045461 00000321303 12052456744 013742 0 ustar dgp 771div /*
* tclInt.h --
*
* Declarations of things used internally by the Tcl interpreter.
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1993-1997 Lucent Technologies.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2007 Daniel A. Steffen
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _TCLINT
#define _TCLINT
/*
* Common include files needed by most of the Tcl source files are
* included here, so that system-dependent personalizations for the
* include files only have to be made in once place. This results
* in a few extra includes, but greater modularity. The order of
* the three groups of #includes is important. For example, stdio.h
* is needed by tcl.h, and the _ANSI_ARGS_ declaration in tcl.h is
* needed by stdlib.h in some configurations.
*/
#ifndef _TCL
#include "tcl.h"
#endif
#include
#include
#ifdef NO_LIMITS_H
# include "../compat/limits.h"
#else
# include
#endif
#ifdef NO_STDLIB_H
# include "../compat/stdlib.h"
#else
# include
#endif
#ifdef NO_STRING_H
#include "../compat/string.h"
#else
#include
#endif
/*
* Ensure WORDS_BIGENDIAN is defined correcly:
* Needs to happen here in addition to configure to work with fat compiles on
* Darwin (where configure runs only once for multiple architectures).
*/
#ifdef HAVE_SYS_TYPES_H
# include
#endif
#ifdef HAVE_SYS_PARAM_H
# include
#endif
#ifdef BYTE_ORDER
# ifdef BIG_ENDIAN
# if BYTE_ORDER == BIG_ENDIAN
# undef WORDS_BIGENDIAN
# define WORDS_BIGENDIAN 1
# endif
# endif
# ifdef LITTLE_ENDIAN
# if BYTE_ORDER == LITTLE_ENDIAN
# undef WORDS_BIGENDIAN
# endif
# endif
#endif
/*
* Used to tag functions that are only to be visible within the module being
* built and not outside it (where this is supported by the linker).
*/
#ifndef MODULE_SCOPE
# ifdef __cplusplus
# define MODULE_SCOPE extern "C"
# else
# define MODULE_SCOPE extern
# endif
#endif
#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
# define TCL_STORAGE_CLASS DLLEXPORT
#else
# ifdef USE_TCL_STUBS
# define TCL_STORAGE_CLASS
# else
# define TCL_STORAGE_CLASS DLLIMPORT
# endif
#endif
/*
* The following procedures allow namespaces to be customized to
* support special name resolution rules for commands/variables.
*
*/
struct Tcl_ResolvedVarInfo;
typedef Tcl_Var (Tcl_ResolveRuntimeVarProc) _ANSI_ARGS_((
Tcl_Interp* interp, struct Tcl_ResolvedVarInfo *vinfoPtr));
typedef void (Tcl_ResolveVarDeleteProc) _ANSI_ARGS_((
struct Tcl_ResolvedVarInfo *vinfoPtr));
/*
* The following structure encapsulates the routines needed to resolve a
* variable reference at runtime. Any variable specific state will typically
* be appended to this structure.
*/
typedef struct Tcl_ResolvedVarInfo {
Tcl_ResolveRuntimeVarProc *fetchProc;
Tcl_ResolveVarDeleteProc *deleteProc;
} Tcl_ResolvedVarInfo;
typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
Tcl_Interp* interp, CONST84 char* name, int length,
Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr));
typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
Tcl_Interp* interp, CONST84 char* name, Tcl_Namespace *context,
int flags, Tcl_Var *rPtr));
typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp,
CONST84 char* name, Tcl_Namespace *context, int flags,
Tcl_Command *rPtr));
typedef struct Tcl_ResolverInfo {
Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name
* resolution. */
Tcl_ResolveVarProc *varResProc; /* Procedure handling variable name
* resolution for variables that
* can only be handled at runtime. */
Tcl_ResolveCompiledVarProc *compiledVarResProc;
/* Procedure handling variable name
* resolution at compile time. */
} Tcl_ResolverInfo;
/*
*----------------------------------------------------------------
* Data structures related to namespaces.
*----------------------------------------------------------------
*/
/*
* The structure below defines a namespace.
* Note: the first five fields must match exactly the fields in a
* Tcl_Namespace structure (see tcl.h). If you change one, be sure to
* change the other.
*/
typedef struct Namespace {
char *name; /* The namespace's simple (unqualified)
* name. This contains no ::'s. The name of
* the global namespace is "" although "::"
* is an synonym. */
char *fullName; /* The namespace's fully qualified name.
* This starts with ::. */
ClientData clientData; /* An arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Procedure invoked when deleting the
* namespace to, e.g., free clientData. */
struct Namespace *parentPtr; /* Points to the namespace that contains
* this one. NULL if this is the global
* namespace. */
Tcl_HashTable childTable; /* Contains any child namespaces. Indexed
* by strings; values have type
* (Namespace *). */
long nsId; /* Unique id for the namespace. */
Tcl_Interp *interp; /* The interpreter containing this
* namespace. */
int flags; /* OR-ed combination of the namespace
* status flags NS_DYING and NS_DEAD
* listed below. */
int activationCount; /* Number of "activations" or active call
* frames for this namespace that are on
* the Tcl call stack. The namespace won't
* be freed until activationCount becomes
* zero. */
int refCount; /* Count of references by namespaceName *
* objects. The namespace can't be freed
* until refCount becomes zero. */
Tcl_HashTable cmdTable; /* Contains all the commands currently
* registered in the namespace. Indexed by
* strings; values have type (Command *).
* Commands imported by Tcl_Import have
* Command structures that point (via an
* ImportedCmdRef structure) to the
* Command structure in the source
* namespace's command table. */
Tcl_HashTable varTable; /* Contains all the (global) variables
* currently in this namespace. Indexed
* by strings; values have type (Var *). */
char **exportArrayPtr; /* Points to an array of string patterns
* specifying which commands are exported.
* A pattern may include "string match"
* style wildcard characters to specify
* multiple commands; however, no namespace
* qualifiers are allowed. NULL if no
* export patterns are registered. */
int numExportPatterns; /* Number of export patterns currently
* registered using "namespace export". */
int maxExportPatterns; /* Mumber of export patterns for which
* space is currently allocated. */
int cmdRefEpoch; /* Incremented if a newly added command
* shadows a command for which this
* namespace has already cached a Command *
* pointer; this causes all its cached
* Command* pointers to be invalidated. */
int resolverEpoch; /* Incremented whenever (a) the name resolution
* rules change for this namespace or (b) a
* newly added command shadows a command that
* is compiled to bytecodes.
* This invalidates all byte codes compiled
* in the namespace, causing the code to be
* recompiled under the new rules.*/
Tcl_ResolveCmdProc *cmdResProc;
/* If non-null, this procedure overrides
* the usual command resolution mechanism
* in Tcl. This procedure is invoked
* within Tcl_FindCommand to resolve all
* command references within the namespace. */
Tcl_ResolveVarProc *varResProc;
/* If non-null, this procedure overrides
* the usual variable resolution mechanism
* in Tcl. This procedure is invoked
* within Tcl_FindNamespaceVar to resolve all
* variable references within the namespace
* at runtime. */
Tcl_ResolveCompiledVarProc *compiledVarResProc;
/* If non-null, this procedure overrides
* the usual variable resolution mechanism
* in Tcl. This procedure is invoked
* within LookupCompiledLocal to resolve
* variable references within the namespace
* at compile time. */
} Namespace;
/*
* Flags used to represent the status of a namespace:
*
* NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the
* namespace but there are still active call frames on the Tcl
* stack that refer to the namespace. When the last call frame
* referring to it has been popped, it's variables and command
* will be destroyed and it will be marked "dead" (NS_DEAD).
* The namespace can no longer be looked up by name.
* NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the
* namespace and no call frames still refer to it. Its
* variables and command have already been destroyed. This bit
* allows the namespace resolution code to recognize that the
* namespace is "deleted". When the last namespaceName object
* in any byte code code unit that refers to the namespace has
* been freed (i.e., when the namespace's refCount is 0), the
* namespace's storage will be freed.
* NS_KILLED 1 means that TclTeardownNamespace has already been called on
* this namespace and it should not be called again [Bug 1355942]
*/
#define NS_DYING 0x01
#define NS_DEAD 0x02
#define NS_KILLED 0x04
/*
* Flag passed to TclGetNamespaceForQualName to have it create all namespace
* components of a namespace-qualified name that cannot be found. The new
* namespaces are created within their specified parent. Note that this
* flag's value must not conflict with the values of the flags
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, and FIND_ONLY_NS (defined in
* tclNamesp.c).
*/
#define CREATE_NS_IF_UNKNOWN 0x800
/*
*----------------------------------------------------------------
* Data structures related to variables. These are used primarily
* in tclVar.c
*----------------------------------------------------------------
*/
/*
* The following structure defines a variable trace, which is used to
* invoke a specific C procedure whenever certain operations are performed
* on a variable.
*/
typedef struct VarTrace {
Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given
* by flags are performed on variable. */
ClientData clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */
struct VarTrace *nextPtr; /* Next in list of traces associated with
* a particular variable. */
} VarTrace;
/*
* The following structure defines a command trace, which is used to
* invoke a specific C procedure whenever certain operations are performed
* on a command.
*/
typedef struct CommandTrace {
Tcl_CommandTraceProc *traceProc;/* Procedure to call when operations given
* by flags are performed on command. */
ClientData clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
struct CommandTrace *nextPtr; /* Next in list of traces associated with
* a particular command. */
int refCount; /* Used to ensure this structure is
* not deleted too early. Keeps track
* of how many pieces of code have
* a pointer to this structure. */
} CommandTrace;
/*
* When a command trace is active (i.e. its associated procedure is
* executing), one of the following structures is linked into a list
* associated with the command's interpreter. The information in
* the structure is needed in order for Tcl to behave reasonably
* if traces are deleted while traces are active.
*/
typedef struct ActiveCommandTrace {
struct Command *cmdPtr; /* Command that's being traced. */
struct ActiveCommandTrace *nextPtr;
/* Next in list of all active command
* traces for the interpreter, or NULL
* if no more. */
CommandTrace *nextTracePtr; /* Next trace to check after current
* trace procedure returns; if this
* trace gets deleted, must update pointer
* to avoid using free'd memory. */
int reverseScan; /* Boolean set true when the traces
* are scanning in reverse order. */
} ActiveCommandTrace;
/*
* When a variable trace is active (i.e. its associated procedure is
* executing), one of the following structures is linked into a list
* associated with the variable's interpreter. The information in
* the structure is needed in order for Tcl to behave reasonably
* if traces are deleted while traces are active.
*/
typedef struct ActiveVarTrace {
struct Var *varPtr; /* Variable that's being traced. */
struct ActiveVarTrace *nextPtr;
/* Next in list of all active variable
* traces for the interpreter, or NULL
* if no more. */
VarTrace *nextTracePtr; /* Next trace to check after current
* trace procedure returns; if this
* trace gets deleted, must update pointer
* to avoid using free'd memory. */
} ActiveVarTrace;
/*
* The following structure describes an enumerative search in progress on
* an array variable; this are invoked with options to the "array"
* command.
*/
typedef struct ArraySearch {
int id; /* Integer id used to distinguish among
* multiple concurrent searches for the
* same array. */
struct Var *varPtr; /* Pointer to array variable that's being
* searched. */
Tcl_HashSearch search; /* Info kept by the hash module about
* progress through the array. */
Tcl_HashEntry *nextEntry; /* Non-null means this is the next element
* to be enumerated (it's leftover from
* the Tcl_FirstHashEntry call or from
* an "array anymore" command). NULL
* means must call Tcl_NextHashEntry
* to get value to return. */
struct ArraySearch *nextPtr;/* Next in list of all active searches
* for this variable, or NULL if this is
* the last one. */
} ArraySearch;
/*
* The structure below defines a variable, which associates a string name
* with a Tcl_Obj value. These structures are kept in procedure call frames
* (for local variables recognized by the compiler) or in the heap (for
* global variables and any variable not known to the compiler). For each
* Var structure in the heap, a hash table entry holds the variable name and
* a pointer to the Var structure.
*/
typedef struct Var {
union {
Tcl_Obj *objPtr; /* The variable's object value. Used for
* scalar variables and array elements. */
Tcl_HashTable *tablePtr;/* For array variables, this points to
* information about the hash table used
* to implement the associative array.
* Points to malloc-ed data. */
struct Var *linkPtr; /* If this is a global variable being
* referred to in a procedure, or a variable
* created by "upvar", this field points to
* the referenced variable's Var struct. */
} value;
char *name; /* NULL if the variable is in a hashtable,
* otherwise points to the variable's
* name. It is used, e.g., by TclLookupVar
* and "info locals". The storage for the
* characters of the name is not owned by
* the Var and must not be freed when
* freeing the Var. */
Namespace *nsPtr; /* Points to the namespace that contains
* this variable or NULL if the variable is
* a local variable in a Tcl procedure. */
Tcl_HashEntry *hPtr; /* If variable is in a hashtable, either the
* hash table entry that refers to this
* variable or NULL if the variable has been
* detached from its hash table (e.g. an
* array is deleted, but some of its
* elements are still referred to in
* upvars). NULL if the variable is not in a
* hashtable. This is used to delete an
* variable from its hashtable if it is no
* longer needed. */
int refCount; /* Counts number of active uses of this
* variable, not including its entry in the
* call frame or the hash table: 1 for each
* additional variable whose linkPtr points
* here, 1 for each nested trace active on
* variable, and 1 if the variable is a
* namespace variable. This record can't be
* deleted until refCount becomes 0. */
VarTrace *tracePtr; /* First in list of all traces set for this
* variable. */
ArraySearch *searchPtr; /* First in list of all searches active
* for this variable, or NULL if none. */
int flags; /* Miscellaneous bits of information about
* variable. See below for definitions. */
} Var;
/*
* Flag bits for variables. The first three (VAR_SCALAR, VAR_ARRAY, and
* VAR_LINK) are mutually exclusive and give the "type" of the variable.
* VAR_UNDEFINED is independent of the variable's type.
*
* VAR_SCALAR - 1 means this is a scalar variable and not
* an array or link. The "objPtr" field points
* to the variable's value, a Tcl object.
* VAR_ARRAY - 1 means this is an array variable rather
* than a scalar variable or link. The
* "tablePtr" field points to the array's
* hashtable for its elements.
* VAR_LINK - 1 means this Var structure contains a
* pointer to another Var structure that
* either has the real value or is itself
* another VAR_LINK pointer. Variables like
* this come about through "upvar" and "global"
* commands, or through references to variables
* in enclosing namespaces.
* VAR_UNDEFINED - 1 means that the variable is in the process
* of being deleted. An undefined variable
* logically does not exist and survives only
* while it has a trace, or if it is a global
* variable currently being used by some
* procedure.
* VAR_IN_HASHTABLE - 1 means this variable is in a hashtable and
* the Var structure is malloced. 0 if it is
* a local variable that was assigned a slot
* in a procedure frame by the compiler so the
* Var storage is part of the call frame.
* VAR_TRACE_ACTIVE - 1 means that trace processing is currently
* underway for a read or write access, so
* new read or write accesses should not cause
* trace procedures to be called and the
* variable can't be deleted.
* VAR_ARRAY_ELEMENT - 1 means that this variable is an array
* element, so it is not legal for it to be
* an array itself (the VAR_ARRAY flag had
* better not be set).
* VAR_NAMESPACE_VAR - 1 means that this variable was declared
* as a namespace variable. This flag ensures
* it persists until its namespace is
* destroyed or until the variable is unset;
* it will persist even if it has not been
* initialized and is marked undefined.
* The variable's refCount is incremented to
* reflect the "reference" from its namespace.
*
* The following additional flags are used with the CompiledLocal type
* defined below:
*
* VAR_ARGUMENT - 1 means that this variable holds a procedure
* argument.
* VAR_TEMPORARY - 1 if the local variable is an anonymous
* temporary variable. Temporaries have a NULL
* name.
* VAR_RESOLVED - 1 if name resolution has been done for this
* variable.
*/
#define VAR_SCALAR 0x1
#define VAR_ARRAY 0x2
#define VAR_LINK 0x4
#define VAR_UNDEFINED 0x8
#define VAR_IN_HASHTABLE 0x10
#define VAR_TRACE_ACTIVE 0x20
#define VAR_ARRAY_ELEMENT 0x40
#define VAR_NAMESPACE_VAR 0x80
#define VAR_ARGUMENT 0x100
#define VAR_TEMPORARY 0x200
#define VAR_RESOLVED 0x400
/*
* Macros to ensure that various flag bits are set properly for variables.
* The ANSI C "prototypes" for these macros are:
*
* EXTERN void TclSetVarScalar _ANSI_ARGS_((Var *varPtr));
* EXTERN void TclSetVarArray _ANSI_ARGS_((Var *varPtr));
* EXTERN void TclSetVarLink _ANSI_ARGS_((Var *varPtr));
* EXTERN void TclSetVarArrayElement _ANSI_ARGS_((Var *varPtr));
* EXTERN void TclSetVarUndefined _ANSI_ARGS_((Var *varPtr));
* EXTERN void TclClearVarUndefined _ANSI_ARGS_((Var *varPtr));
*/
#define TclSetVarScalar(varPtr) \
(varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_SCALAR
#define TclSetVarArray(varPtr) \
(varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_LINK)) | VAR_ARRAY
#define TclSetVarLink(varPtr) \
(varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_ARRAY)) | VAR_LINK
#define TclSetVarArrayElement(varPtr) \
(varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT
#define TclSetVarUndefined(varPtr) \
(varPtr)->flags |= VAR_UNDEFINED
#define TclClearVarUndefined(varPtr) \
(varPtr)->flags &= ~VAR_UNDEFINED
/*
* Macros to read various flag bits of variables.
* The ANSI C "prototypes" for these macros are:
*
* EXTERN int TclIsVarScalar _ANSI_ARGS_((Var *varPtr));
* EXTERN int TclIsVarLink _ANSI_ARGS_((Var *varPtr));
* EXTERN int TclIsVarArray _ANSI_ARGS_((Var *varPtr));
* EXTERN int TclIsVarUndefined _ANSI_ARGS_((Var *varPtr));
* EXTERN int TclIsVarArrayElement _ANSI_ARGS_((Var *varPtr));
* EXTERN int TclIsVarTemporary _ANSI_ARGS_((Var *varPtr));
* EXTERN int TclIsVarArgument _ANSI_ARGS_((Var *varPtr));
* EXTERN int TclIsVarResolved _ANSI_ARGS_((Var *varPtr));
*/
#define TclIsVarScalar(varPtr) \
((varPtr)->flags & VAR_SCALAR)
#define TclIsVarLink(varPtr) \
((varPtr)->flags & VAR_LINK)
#define TclIsVarArray(varPtr) \
((varPtr)->flags & VAR_ARRAY)
#define TclIsVarUndefined(varPtr) \
((varPtr)->flags & VAR_UNDEFINED)
#define TclIsVarArrayElement(varPtr) \
((varPtr)->flags & VAR_ARRAY_ELEMENT)
#define TclIsVarTemporary(varPtr) \
((varPtr)->flags & VAR_TEMPORARY)
#define TclIsVarArgument(varPtr) \
((varPtr)->flags & VAR_ARGUMENT)
#define TclIsVarResolved(varPtr) \
((varPtr)->flags & VAR_RESOLVED)
/*
*----------------------------------------------------------------
* Data structures related to procedures. These are used primarily
* in tclProc.c, tclCompile.c, and tclExecute.c.
*----------------------------------------------------------------
*/
/*
* Forward declaration to prevent an error when the forward reference to
* Command is encountered in the Proc and ImportRef types declared below.
*/
struct Command;
/*
* The variable-length structure below describes a local variable of a
* procedure that was recognized by the compiler. These variables have a
* name, an element in the array of compiler-assigned local variables in the
* procedure's call frame, and various other items of information. If the
* local variable is a formal argument, it may also have a default value.
* The compiler can't recognize local variables whose names are
* expressions (these names are only known at runtime when the expressions
* are evaluated) or local variables that are created as a result of an
* "upvar" or "uplevel" command. These other local variables are kept
* separately in a hash table in the call frame.
*/
typedef struct CompiledLocal {
struct CompiledLocal *nextPtr;
/* Next compiler-recognized local variable
* for this procedure, or NULL if this is
* the last local. */
int nameLength; /* The number of characters in local
* variable's name. Used to speed up
* variable lookups. */
int frameIndex; /* Index in the array of compiler-assigned
* variables in the procedure call frame. */
int flags; /* Flag bits for the local variable. Same as
* the flags for the Var structure above,
* although only VAR_SCALAR, VAR_ARRAY,
* VAR_LINK, VAR_ARGUMENT, VAR_TEMPORARY, and
* VAR_RESOLVED make sense. */
Tcl_Obj *defValuePtr; /* Pointer to the default value of an
* argument, if any. NULL if not an argument
* or, if an argument, no default value. */
Tcl_ResolvedVarInfo *resolveInfo;
/* Customized variable resolution info
* supplied by the Tcl_ResolveCompiledVarProc
* associated with a namespace. Each variable
* is marked by a unique ClientData tag
* during compilation, and that same tag
* is used to find the variable at runtime. */
char name[4]; /* Name of the local variable starts here.
* If the name is NULL, this will just be
* '\0'. The actual size of this field will
* be large enough to hold the name. MUST
* BE THE LAST FIELD IN THE STRUCTURE! */
} CompiledLocal;
/*
* The structure below defines a command procedure, which consists of a
* collection of Tcl commands plus information about arguments and other
* local variables recognized at compile time.
*/
typedef struct Proc {
struct Interp *iPtr; /* Interpreter for which this command
* is defined. */
int refCount; /* Reference count: 1 if still present
* in command table plus 1 for each call
* to the procedure that is currently
* active. This structure can be freed
* when refCount becomes zero. */
struct Command *cmdPtr; /* Points to the Command structure for
* this procedure. This is used to get
* the namespace in which to execute
* the procedure. */
Tcl_Obj *bodyPtr; /* Points to the ByteCode object for
* procedure's body command. */
int numArgs; /* Number of formal parameters. */
int numCompiledLocals; /* Count of local variables recognized by
* the compiler including arguments and
* temporaries. */
CompiledLocal *firstLocalPtr; /* Pointer to first of the procedure's
* compiler-allocated local variables, or
* NULL if none. The first numArgs entries
* in this list describe the procedure's
* formal arguments. */
CompiledLocal *lastLocalPtr; /* Pointer to the last allocated local
* variable or NULL if none. This has
* frame index (numCompiledLocals-1). */
} Proc;
/*
* The structure below defines a command trace. This is used to allow Tcl
* clients to find out whenever a command is about to be executed.
*/
typedef struct Trace {
int level; /* Only trace commands at nesting level
* less than or equal to this. */
Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
ClientData clientData; /* Arbitrary value to pass to proc. */
struct Trace *nextPtr; /* Next in list of traces for this interp. */
int flags; /* Flags governing the trace - see
* Tcl_CreateObjTrace for details */
Tcl_CmdObjTraceDeleteProc* delProc;
/* Procedure to call when trace is deleted */
} Trace;
/*
* When an interpreter trace is active (i.e. its associated procedure
* is executing), one of the following structures is linked into a list
* associated with the interpreter. The information in the structure
* is needed in order for Tcl to behave reasonably if traces are
* deleted while traces are active.
*/
typedef struct ActiveInterpTrace {
struct ActiveInterpTrace *nextPtr;
/* Next in list of all active command
* traces for the interpreter, or NULL
* if no more. */
Trace *nextTracePtr; /* Next trace to check after current
* trace procedure returns; if this
* trace gets deleted, must update pointer
* to avoid using free'd memory. */
int reverseScan; /* Boolean set true when the traces
* are scanning in reverse order. */
} ActiveInterpTrace;
/*
* The structure below defines an entry in the assocData hash table which
* is associated with an interpreter. The entry contains a pointer to a
* function to call when the interpreter is deleted, and a pointer to
* a user-defined piece of data.
*/
typedef struct AssocData {
Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */
ClientData clientData; /* Value to pass to proc. */
} AssocData;
/*
* The structure below defines a call frame. A call frame defines a naming
* context for a procedure call: its local naming scope (for local
* variables) and its global naming scope (a namespace, perhaps the global
* :: namespace). A call frame can also define the naming context for a
* namespace eval or namespace inscope command: the namespace in which the
* command's code should execute. The Tcl_CallFrame structures exist only
* while procedures or namespace eval/inscope's are being executed, and
* provide a kind of Tcl call stack.
*
* WARNING!! The structure definition must be kept consistent with the
* Tcl_CallFrame structure in tcl.h. If you change one, change the other.
*/
typedef struct CallFrame {
Namespace *nsPtr; /* Points to the namespace used to resolve
* commands and global variables. */
int isProcCallFrame; /* If nonzero, the frame was pushed to
* execute a Tcl procedure and may have
* local vars. If 0, the frame was pushed
* to execute a namespace command and var
* references are treated as references to
* namespace vars; varTablePtr and
* compiledLocals are ignored. */
int objc; /* This and objv below describe the
* arguments for this procedure call. */
Tcl_Obj *CONST *objv; /* Array of argument objects. */
struct CallFrame *callerPtr;
/* Value of interp->framePtr when this
* procedure was invoked (i.e. next higher
* in stack of all active procedures). */
struct CallFrame *callerVarPtr;
/* Value of interp->varFramePtr when this
* procedure was invoked (i.e. determines
* variable scoping within caller). Same
* as callerPtr unless an "uplevel" command
* or something equivalent was active in
* the caller). */
int level; /* Level of this procedure, for "uplevel"
* purposes (i.e. corresponds to nesting of
* callerVarPtr's, not callerPtr's). 1 for
* outermost procedure, 0 for top-level. */
Proc *procPtr; /* Points to the structure defining the
* called procedure. Used to get information
* such as the number of compiled local
* variables (local variables assigned
* entries ["slots"] in the compiledLocals
* array below). */
Tcl_HashTable *varTablePtr; /* Hash table containing local variables not
* recognized by the compiler, or created at
* execution time through, e.g., upvar.
* Initially NULL and created if needed. */
int numCompiledLocals; /* Count of local variables recognized by
* the compiler including arguments. */
Var* compiledLocals; /* Points to the array of local variables
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
} CallFrame;
#ifdef TCL_TIP280
/*
* TIP #280
* The structure below defines a command frame. A command frame
* provides location information for all commands executing a tcl
* script (source, eval, uplevel, procedure bodies, ...). The runtime
* structure essentially contains the stack trace as it would be if
* the currently executing command were to throw an error.
*
* For commands where it makes sense it refers to the associated
* CallFrame as well.
*
* The structures are chained in a single list, with the top of the
* stack anchored in the Interp structure.
*
* Instances can be allocated on the C stack, or the heap, the former
* making cleanup a bit simpler.
*/
typedef struct CmdFrame {
/* General data. Always available. */
int type; /* Values see below */
int level; /* #Frames in stack, prevent O(n) scan of list */
int* line; /* Lines the words of the command start on */
int nline;
CallFrame* framePtr; /* Procedure activation record, may be NULL */
struct CmdFrame* nextPtr; /* Link to calling frame */
/* Data needed for Eval vs TEBC
*
* EXECUTION CONTEXTS and usage of CmdFrame
*
* Field TEBC EvalEx EvalObjEx
* ======= ==== ====== =========
* level yes yes yes
* type BC/PREBC SRC/EVAL EVAL_LIST
* line0 yes yes yes
* framePtr yes yes yes
* ======= ==== ====== =========
*
* ======= ==== ====== ========= union data
* line1 - yes -
* line3 - yes -
* path - yes -
* ------- ---- ------ ---------
* codePtr yes - -
* pc yes - -
* ======= ==== ====== =========
*
* ======= ==== ====== ========= | union cmd
* listPtr - - yes |
* ------- ---- ------ --------- |
* cmd yes yes - |
* cmdlen yes yes - |
* ------- ---- ------ --------- |
*/
union {
struct {
Tcl_Obj* path; /* Path of the sourced file the command
* is in. */
} eval;
struct {
CONST void* codePtr; /* Byte code currently executed */
CONST char* pc; /* and instruction pointer. */
} tebc;
} data;
union {
struct {
CONST char* cmd; /* The executed command, if possible */
int len; /* And its length */
} str;
Tcl_Obj* listPtr; /* Tcl_EvalObjEx, cmd list */
} cmd;
} CmdFrame;
/* The following macros define the allowed values for the type field
* of the CmdFrame structure above. Some of the values occur only in
* the extended location data referenced via the 'baseLocPtr'.
*
* TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx.
* TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list
* optimization path of EvalObjEx.
* TCL_LOCATION_BC : Frame is for bytecode.
* TCL_LOCATION_PREBC : Frame is for precompiled bytecode.
* TCL_LOCATION_SOURCE : Frame is for a script evaluated by EvalEx,
* from a sourced file.
* TCL_LOCATION_PROC : Frame is for bytecode of a procedure.
*
* A TCL_LOCATION_BC type in a frame can be overridden by _SOURCE and
* _PROC types, per the context of the byte code in execution.
*/
#define TCL_LOCATION_EVAL (0) /* Location in a dynamic eval script */
#define TCL_LOCATION_EVAL_LIST (1) /* Location in a dynamic eval script, list-path */
#define TCL_LOCATION_BC (2) /* Location in byte code */
#define TCL_LOCATION_PREBC (3) /* Location in precompiled byte code, no location */
#define TCL_LOCATION_SOURCE (4) /* Location in a file */
#define TCL_LOCATION_PROC (5) /* Location in a dynamic proc */
#define TCL_LOCATION_LAST (6) /* Number of values in the enum */
typedef struct CFWord {
CmdFrame* framePtr; /* CmdFrame to acess */
int word; /* Index of the word in the command */
int refCount; /* #times the word is on the stack */
} CFWord;
typedef struct CFWordBC {
CmdFrame* framePtr; /* CmdFrame to acess */
int pc; /* Instruction pointer of a command in ExtCmdLoc.loc[.] */
int word; /* Index of word in ExtCmdLoc.loc[cmd]->{line,literal}[.] */
struct CFWordBC* prevPtr;
} CFWordBC;
/*
* Structure to record the locations of invisible continuation lines in
* literal scripts, as character offset from the beginning of the script. Both
* compiler and direct evaluator use this information to adjust their line
* counters when tracking through the script, because when it is invoked the
* continuation line marker as a whole has been removed already, meaning that
* the \n which was part of it is gone as well, breaking regular line
* tracking.
*
* These structures are allocated and filled by both the function
* EvalTokensStandard() in the file "tclBasic.c" and its caller EvalEx(), and
* stored in the thread-global hashtable "lineCLPtr" in file "tclObj.c". They
* are used by the functions TclSetByteCodeFromAny() and TclCompileScript(),
* both found in the file "tclCompile.c". Their memory is released by the
* function TclFreeObj(), in the file "tclObj.c", and also by the function
* TclThreadFinalizeObjects(), in the same file.
*/
#define CLL_END (-1)
typedef struct ContLineLoc {
int num; /* Number of entries in loc, not counting the final -1
* marker entry */
int loc[1]; /* Table of locations, as character offsets. The table is
* allocated as part of the structure, i.e. the loc array
* extends behind the nominal end of the structure. An entry
* containing the value CLL_END is put after the last
* location, as end-marker/sentinel. */
} ContLineLoc;
#endif /* TCL_TIP280 */
/*
*----------------------------------------------------------------
* Data structures and procedures related to TclHandles, which
* are a very lightweight method of preserving enough information
* to determine if an arbitrary malloc'd block has been deleted.
*----------------------------------------------------------------
*/
typedef VOID **TclHandle;
/*
*----------------------------------------------------------------
* Data structures related to expressions. These are used only in
* tclExpr.c.
*----------------------------------------------------------------
*/
/*
* The data structure below defines a math function (e.g. sin or hypot)
* for use in Tcl expressions.
*/
#define MAX_MATH_ARGS 5
typedef struct MathFunc {
int builtinFuncIndex; /* If this is a builtin math function, its
* index in the array of builtin functions.
* (tclCompilation.h lists these indices.)
* The value is -1 if this is a new function
* defined by Tcl_CreateMathFunc. The value
* is also -1 if a builtin function is
* replaced by a Tcl_CreateMathFunc call. */
int numArgs; /* Number of arguments for function. */
Tcl_ValueType argTypes[MAX_MATH_ARGS];
/* Acceptable types for each argument. */
Tcl_MathProc *proc; /* Procedure that implements this function.
* NULL if isBuiltinFunc is 1. */
ClientData clientData; /* Additional argument to pass to the
* function when invoking it. NULL if
* isBuiltinFunc is 1. */
} MathFunc;
/*
* These are a thin layer over TclpThreadKeyDataGet and TclpThreadKeyDataSet
* when threads are used, or an emulation if there are no threads. These
* are really internal and Tcl clients should use Tcl_GetThreadData.
*/
EXTERN VOID *TclThreadDataKeyGet _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr));
EXTERN void TclThreadDataKeySet _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr, VOID *data));
/*
* This is a convenience macro used to initialize a thread local storage ptr.
*/
#define TCL_TSD_INIT(keyPtr) (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
/*
*----------------------------------------------------------------
* Data structures related to bytecode compilation and execution.
* These are used primarily in tclCompile.c, tclExecute.c, and
* tclBasic.c.
*----------------------------------------------------------------
*/
/*
* Forward declaration to prevent errors when the forward references to
* Tcl_Parse and CompileEnv are encountered in the procedure type
* CompileProc declared below.
*/
struct CompileEnv;
/*
* The type of procedures called by the Tcl bytecode compiler to compile
* commands. Pointers to these procedures are kept in the Command structure
* describing each command. When a CompileProc returns, the interpreter's
* result is set to error information, if any. In addition, the CompileProc
* returns an integer value, which is one of the following:
*
* TCL_OK Compilation completed normally.
* TCL_ERROR Compilation failed because of an error;
* the interpreter's result describes what went wrong.
* TCL_OUT_LINE_COMPILE Compilation failed because, e.g., the command is
* too complex for effective inline compilation. The
* CompileProc believes the command is legal but
* should be compiled "out of line" by emitting code
* to invoke its command procedure at runtime.
*/
#define TCL_OUT_LINE_COMPILE (TCL_CONTINUE + 1)
typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *compEnvPtr));
/*
* The type of procedure called from the compilation hook point in
* SetByteCodeFromAny.
*/
typedef int (CompileHookProc) _ANSI_ARGS_((Tcl_Interp *interp,
struct CompileEnv *compEnvPtr, ClientData clientData));
/*
* The data structure defining the execution environment for ByteCode's.
* There is one ExecEnv structure per Tcl interpreter. It holds the
* evaluation stack that holds command operands and results. The stack grows
* towards increasing addresses. The "stackTop" member is cached by
* TclExecuteByteCode in a local variable: it must be set before calling
* TclExecuteByteCode and will be restored by TclExecuteByteCode before it
* returns.
*/
typedef struct ExecEnv {
Tcl_Obj **stackPtr; /* Points to the first item in the
* evaluation stack on the heap. */
int stackTop; /* Index of current top of stack; -1 when
* the stack is empty. */
int stackEnd; /* Index of last usable item in stack. */
Tcl_Obj *errorInfo;
Tcl_Obj *errorCode;
} ExecEnv;
/*
* The definitions for the LiteralTable and LiteralEntry structures. Each
* interpreter contains a LiteralTable. It is used to reduce the storage
* needed for all the Tcl objects that hold the literals of scripts compiled
* by the interpreter. A literal's object is shared by all the ByteCodes
* that refer to the literal. Each distinct literal has one LiteralEntry
* entry in the LiteralTable. A literal table is a specialized hash table
* that is indexed by the literal's string representation, which may contain
* null characters.
*
* Note that we reduce the space needed for literals by sharing literal
* objects both within a ByteCode (each ByteCode contains a local
* LiteralTable) and across all an interpreter's ByteCodes (with the
* interpreter's global LiteralTable).
*/
typedef struct LiteralEntry {
struct LiteralEntry *nextPtr; /* Points to next entry in this
* hash bucket or NULL if end of
* chain. */
Tcl_Obj *objPtr; /* Points to Tcl object that
* holds the literal's bytes and
* length. */
int refCount; /* If in an interpreter's global
* literal table, the number of
* ByteCode structures that share
* the literal object; the literal
* entry can be freed when refCount
* drops to 0. If in a local literal
* table, -1. */
} LiteralEntry;
typedef struct LiteralTable {
LiteralEntry **buckets; /* Pointer to bucket array. Each
* element points to first entry in
* bucket's hash chain, or NULL. */
LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small
* tables to avoid mallocs and
* frees. */
int numBuckets; /* Total number of buckets allocated
* at **buckets. */
int numEntries; /* Total number of entries present
* in table. */
int rebuildSize; /* Enlarge table when numEntries
* gets to be this large. */
int mask; /* Mask value used in hashing
* function. */
} LiteralTable;
/*
* The following structure defines for each Tcl interpreter various
* statistics-related information about the bytecode compiler and
* interpreter's operation in that interpreter.
*/
#ifdef TCL_COMPILE_STATS
typedef struct ByteCodeStats {
long numExecutions; /* Number of ByteCodes executed. */
long numCompilations; /* Number of ByteCodes created. */
long numByteCodesFreed; /* Number of ByteCodes destroyed. */
long instructionCount[256]; /* Number of times each instruction was
* executed. */
double totalSrcBytes; /* Total source bytes ever compiled. */
double totalByteCodeBytes; /* Total bytes for all ByteCodes. */
double currentSrcBytes; /* Src bytes for all current ByteCodes. */
double currentByteCodeBytes; /* Code bytes in all current ByteCodes. */
long srcCount[32]; /* Source size distribution: # of srcs of
* size [2**(n-1)..2**n), n in [0..32). */
long byteCodeCount[32]; /* ByteCode size distribution. */
long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */
double currentInstBytes; /* Instruction bytes-current ByteCodes. */
double currentLitBytes; /* Current literal bytes. */
double currentExceptBytes; /* Current exception table bytes. */
double currentAuxBytes; /* Current auxiliary information bytes. */
double currentCmdMapBytes; /* Current src<->code map bytes. */
long numLiteralsCreated; /* Total literal objects ever compiled. */
double totalLitStringBytes; /* Total string bytes in all literals. */
double currentLitStringBytes; /* String bytes in current literals. */
long literalCount[32]; /* Distribution of literal string sizes. */
} ByteCodeStats;
#endif /* TCL_COMPILE_STATS */
/*
*----------------------------------------------------------------
* Data structures related to commands.
*----------------------------------------------------------------
*/
/*
* An imported command is created in an namespace when it imports a "real"
* command from another namespace. An imported command has a Command
* structure that points (via its ClientData value) to the "real" Command
* structure in the source namespace's command table. The real command
* records all the imported commands that refer to it in a list of ImportRef
* structures so that they can be deleted when the real command is deleted. */
typedef struct ImportRef {
struct Command *importedCmdPtr;
/* Points to the imported command created in
* an importing namespace; this command
* redirects its invocations to the "real"
* command. */
struct ImportRef *nextPtr; /* Next element on the linked list of
* imported commands that refer to the
* "real" command. The real command deletes
* these imported commands on this list when
* it is deleted. */
} ImportRef;
/*
* Data structure used as the ClientData of imported commands: commands
* created in an namespace when it imports a "real" command from another
* namespace.
*/
typedef struct ImportedCmdData {
struct Command *realCmdPtr; /* "Real" command that this imported command
* refers to. */
struct Command *selfPtr; /* Pointer to this imported command. Needed
* only when deleting it in order to remove
* it from the real command's linked list of
* imported commands that refer to it. */
} ImportedCmdData;
/*
* A Command structure exists for each command in a namespace. The
* Tcl_Command opaque type actually refers to these structures.
*/
typedef struct Command {
Tcl_HashEntry *hPtr; /* Pointer to the hash table entry that
* refers to this command. The hash table is
* either a namespace's command table or an
* interpreter's hidden command table. This
* pointer is used to get a command's name
* from its Tcl_Command handle. NULL means
* that the hash table entry has been
* removed already (this can happen if
* deleteProc causes the command to be
* deleted or recreated). */
Namespace *nsPtr; /* Points to the namespace containing this
* command. */
int refCount; /* 1 if in command hashtable plus 1 for each
* reference from a CmdName Tcl object
* representing a command's name in a
* ByteCode instruction sequence. This
* structure can be freed when refCount
* becomes zero. */
int cmdEpoch; /* Incremented to invalidate any references
* that point to this command when it is
* renamed, deleted, hidden, or exposed. */
CompileProc *compileProc; /* Procedure called to compile command. NULL
* if no compile proc exists for command. */
Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */
ClientData objClientData; /* Arbitrary value passed to object proc. */
Tcl_CmdProc *proc; /* String-based command procedure. */
ClientData clientData; /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Procedure invoked when deleting command
* to, e.g., free all client data. */
ClientData deleteData; /* Arbitrary value passed to deleteProc. */
int flags; /* Miscellaneous bits of information about
* command. See below for definitions. */
ImportRef *importRefPtr; /* List of each imported Command created in
* another namespace when this command is
* imported. These imported commands
* redirect invocations back to this
* command. The list is used to remove all
* those imported commands when deleting
* this "real" command. */
CommandTrace *tracePtr; /* First in list of all traces set for this
* command. */
} Command;
/*
* Flag bits for commands.
*
* CMD_IS_DELETED - Means that the command is in the process
* of being deleted (its deleteProc is
* currently executing). Other attempts to
* delete the command should be ignored.
* CMD_TRACE_ACTIVE - 1 means that trace processing is currently
* underway for a rename/delete change.
* See the two flags below for which is
* currently being processed.
* CMD_HAS_EXEC_TRACES - 1 means that this command has at least
* one execution trace (as opposed to simple
* delete/rename traces) in its tracePtr list.
* TCL_TRACE_RENAME - A rename trace is in progress. Further
* recursive renames will not be traced.
* TCL_TRACE_DELETE - A delete trace is in progress. Further
* recursive deletes will not be traced.
* (these last two flags are defined in tcl.h)
*/
#define CMD_IS_DELETED 0x1
#define CMD_TRACE_ACTIVE 0x2
#define CMD_HAS_EXEC_TRACES 0x4
/*
*----------------------------------------------------------------
* Data structures related to name resolution procedures.
*----------------------------------------------------------------
*/
/*
* The interpreter keeps a linked list of name resolution schemes.
* The scheme for a namespace is consulted first, followed by the
* list of schemes in an interpreter, followed by the default
* name resolution in Tcl. Schemes are added/removed from the
* interpreter's list by calling Tcl_AddInterpResolver and
* Tcl_RemoveInterpResolver.
*/
typedef struct ResolverScheme {
char *name; /* Name identifying this scheme. */
Tcl_ResolveCmdProc *cmdResProc;
/* Procedure handling command name
* resolution. */
Tcl_ResolveVarProc *varResProc;
/* Procedure handling variable name
* resolution for variables that
* can only be handled at runtime. */
Tcl_ResolveCompiledVarProc *compiledVarResProc;
/* Procedure handling variable name
* resolution at compile time. */
struct ResolverScheme *nextPtr;
/* Pointer to next record in linked list. */
} ResolverScheme;
#ifdef TCL_TIP268
/*
* TIP #268.
* Values for the selection mode, i.e the package require preferences.
*/
enum PkgPreferOptions {
PKG_PREFER_LATEST, PKG_PREFER_STABLE
};
#endif
/*
*----------------------------------------------------------------
* This structure defines an interpreter, which is a collection of
* commands plus other state information related to interpreting
* commands, such as variable storage. Primary responsibility for
* this data structure is in tclBasic.c, but almost every Tcl
* source file uses something in here.
*----------------------------------------------------------------
*/
typedef struct Interp {
/*
* Note: the first three fields must match exactly the fields in
* a Tcl_Interp struct (see tcl.h). If you change one, be sure to
* change the other.
*
* The interpreter's result is held in both the string and the
* objResultPtr fields. These fields hold, respectively, the result's
* string or object value. The interpreter's result is always in the
* result field if that is non-empty, otherwise it is in objResultPtr.
* The two fields are kept consistent unless some C code sets
* interp->result directly. Programs should not access result and
* objResultPtr directly; instead, they should always get and set the
* result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult,
* and Tcl_GetStringResult. See the SetResult man page for details.
*/
char *result; /* If the last command returned a string
* result, this points to it. Should not be
* accessed directly; see comment above. */
Tcl_FreeProc *freeProc; /* Zero means a string result is statically
* allocated. TCL_DYNAMIC means string
* result was allocated with ckalloc and
* should be freed with ckfree. Other values
* give address of procedure to invoke to
* free the string result. Tcl_Eval must
* free it before executing next command. */
int errorLine; /* When TCL_ERROR is returned, this gives
* the line number in the command where the
* error occurred (1 means first line). */
struct TclStubs *stubTable;
/* Pointer to the exported Tcl stub table.
* On previous versions of Tcl this is a
* pointer to the objResultPtr or a pointer
* to a buckets array in a hash table. We
* therefore have to do some careful checking
* before we can use this. */
TclHandle handle; /* Handle used to keep track of when this
* interp is deleted. */
Namespace *globalNsPtr; /* The interpreter's global namespace. */
Tcl_HashTable *hiddenCmdTablePtr;
/* Hash table used by tclBasic.c to keep
* track of hidden commands on a per-interp
* basis. */
ClientData interpInfo; /* Information used by tclInterp.c to keep
* track of master/slave interps on
* a per-interp basis. */
Tcl_HashTable mathFuncTable;/* Contains all the math functions currently
* defined for the interpreter. Indexed by
* strings (function names); values have
* type (MathFunc *). */
/*
* Information related to procedures and variables. See tclProc.c
* and tclVar.c for usage.
*/
int numLevels; /* Keeps track of how many nested calls to
* Tcl_Eval are in progress for this
* interpreter. It's used to delay deletion
* of the table until all Tcl_Eval
* invocations are completed. */
int maxNestingDepth; /* If numLevels exceeds this value then Tcl
* assumes that infinite recursion has
* occurred and it generates an error. */
CallFrame *framePtr; /* Points to top-most in stack of all nested
* procedure invocations. NULL means there
* are no active procedures. */
CallFrame *varFramePtr; /* Points to the call frame whose variables
* are currently in use (same as framePtr
* unless an "uplevel" command is
* executing). NULL means no procedure is
* active or "uplevel 0" is executing. */
ActiveVarTrace *activeVarTracePtr;
/* First in list of active traces for
* interp, or NULL if no active traces. */
int returnCode; /* Completion code to return if current
* procedure exits with TCL_RETURN code. */
char *errorInfo; /* Value to store in errorInfo if returnCode
* is TCL_ERROR. Malloc'ed, may be NULL */
char *errorCode; /* Value to store in errorCode if returnCode
* is TCL_ERROR. Malloc'ed, may be NULL */
/*
* Information used by Tcl_AppendResult to keep track of partial
* results. See Tcl_AppendResult code for details.
*/
char *appendResult; /* Storage space for results generated
* by Tcl_AppendResult. Malloc-ed. NULL
* means not yet allocated. */
int appendAvl; /* Total amount of space available at
* partialResult. */
int appendUsed; /* Number of non-null bytes currently
* stored at partialResult. */
/*
* Information about packages. Used only in tclPkg.c.
*/
Tcl_HashTable packageTable; /* Describes all of the packages loaded
* in or available to this interpreter.
* Keys are package names, values are
* (Package *) pointers. */
char *packageUnknown; /* Command to invoke during "package
* require" commands for packages that
* aren't described in packageTable.
* Malloc'ed, may be NULL. */
/*
* Miscellaneous information:
*/
int cmdCount; /* Total number of times a command procedure
* has been called for this interpreter. */
int evalFlags; /* Flags to control next call to Tcl_Eval.
* Normally zero, but may be set before
* calling Tcl_Eval. See below for valid
* values. */
int termOffset; /* Offset of character just after last one
* compiled or executed by Tcl_EvalObj. */
LiteralTable literalTable; /* Contains LiteralEntry's describing all
* Tcl objects holding literals of scripts
* compiled by the interpreter. Indexed by
* the string representations of literals.
* Used to avoid creating duplicate
* objects. */
int compileEpoch; /* Holds the current "compilation epoch"
* for this interpreter. This is
* incremented to invalidate existing
* ByteCodes when, e.g., a command with a
* compile procedure is redefined. */
Proc *compiledProcPtr; /* If a procedure is being compiled, a
* pointer to its Proc structure; otherwise,
* this is NULL. Set by ObjInterpProc in
* tclProc.c and used by tclCompile.c to
* process local variables appropriately. */
ResolverScheme *resolverPtr;
/* Linked list of name resolution schemes
* added to this interpreter. Schemes
* are added/removed by calling
* Tcl_AddInterpResolvers and
* Tcl_RemoveInterpResolver. */
Tcl_Obj *scriptFile; /* NULL means there is no nested source
* command active; otherwise this points to
* pathPtr of the file being sourced. */
int flags; /* Various flag bits. See below. */
long randSeed; /* Seed used for rand() function. */
Trace *tracePtr; /* List of traces for this interpreter. */
Tcl_HashTable *assocData; /* Hash table for associating data with
* this interpreter. Cleaned up when
* this interpreter is deleted. */
struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode
* execution. Contains a pointer to the
* Tcl evaluation stack. */
Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
char resultSpace[TCL_RESULT_SIZE+1];
/* Static space holding small results. */
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
Tcl_ThreadId threadId; /* ID of thread that owns the interpreter */
ActiveCommandTrace *activeCmdTracePtr;
/* First in list of active command traces for
* interp, or NULL if no active traces. */
ActiveInterpTrace *activeInterpTracePtr;
/* First in list of active traces for
* interp, or NULL if no active traces. */
int tracesForbiddingInline; /* Count of traces (in the list headed by
* tracePtr) that forbid inline bytecode
* compilation */
#ifdef TCL_TIP280
/* TIP #280 */
CmdFrame* cmdFramePtr; /* Points to the command frame containing
* the location information for the current
* command. */
CONST CmdFrame* invokeCmdFramePtr; /* Points to the command frame which is the
* invoking context of the bytecode compiler.
* NULL when the byte code compiler is not
* active */
int invokeWord; /* Index of the word in the command which
* is getting compiled. */
Tcl_HashTable* linePBodyPtr;
/* This table remembers for each
* statically defined procedure the
* location information for its
* body. It is keyed by the address of
* the Proc structure for a procedure.
* The values are "struct CmdFrame*".
*/
Tcl_HashTable* lineBCPtr;
/* This table remembers for each
* ByteCode object the location
* information for its body. It is
* keyed by the address of the Proc
* structure for a procedure. The
* values are "struct ExtCmdLoc*" (See
* tclCompile.h).
*/
Tcl_HashTable* lineLABCPtr;
Tcl_HashTable* lineLAPtr;
/* This table remembers for each
* argument of a command on the
* execution stack the index of the
* argument in the command, and the
* location data of the command. It is
* keyed by the address of the Tcl_Obj
* containing the argument. The values
* are "struct CFWord*" (See
* tclBasic.c). This allows commands
* like uplevel, eval, etc. to find
* location information for their
* arguments, if they are a proper
* literal argument to an invoking
* command. Alt view: An index to the
* CmdFrame stack keyed by command
* argument holders.
*/
ContLineLoc* scriptCLLocPtr;
/* This table points to the location data for
* invisible continuation lines in the script,
* if any. This pointer is set by the function
* TclEvalObjEx() in file "tclBasic.c", and
* used by function ...() in the same file.
* It does for the eval/direct path of script
* execution what CompileEnv.clLoc does for
* the bytecode compiler.
*/
#endif
#ifdef TCL_TIP268
/*
* TIP #268.
* The currently active selection mode,
* i.e the package require preferences.
*/
int packagePrefer; /* Current package selection mode. */
#endif
/*
* Statistical information about the bytecode compiler and interpreter's
* operation.
*/
#ifdef TCL_COMPILE_STATS
ByteCodeStats stats; /* Holds compilation and execution
* statistics for this interpreter. */
#endif /* TCL_COMPILE_STATS */
} Interp;
/*
* EvalFlag bits for Interp structures:
*
* TCL_BRACKET_TERM 1 means that the current script is terminated by
* a close bracket rather than the end of the string.
* TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with
* a code other than TCL_OK or TCL_ERROR; 0 means
* codes other than these should be turned into errors.
*/
#define TCL_BRACKET_TERM 1
#define TCL_ALLOW_EXCEPTIONS 4
#ifdef TCL_TIP280
#define TCL_EVAL_FILE 2
#define TCL_EVAL_CTX 8
#endif
/*
* Flag bits for Interp structures:
*
* DELETED: Non-zero means the interpreter has been deleted:
* don't process any more commands for it, and destroy
* the structure as soon as all nested invocations of
* Tcl_Eval are done.
* ERR_IN_PROGRESS: Non-zero means an error unwind is already in
* progress. Zero means a command proc has been
* invoked since last error occured.
* ERR_ALREADY_LOGGED: Non-zero means information has already been logged
* in $errorInfo for the current Tcl_Eval instance,
* so Tcl_Eval needn't log it (used to implement the
* "error message log" command).
* ERROR_CODE_SET: Non-zero means that Tcl_SetErrorCode has been
* called to record information for the current
* error. Zero means Tcl_Eval must clear the
* errorCode variable if an error is returned.
* EXPR_INITIALIZED: Non-zero means initialization specific to
* expressions has been carried out.
* DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler
* should not compile any commands into an inline
* sequence of instructions. This is set 1, for
* example, when command traces are requested.
* RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the
* interp has not be initialized. This is set 1
* when we first use the rand() or srand() functions.
* SAFE_INTERP: Non zero means that the current interp is a
* safe interp (ie it has only the safe commands
* installed, less priviledge than a regular interp).
* USE_EVAL_DIRECT: Non-zero means don't use the compiler or byte-code
* interpreter; instead, have Tcl_EvalObj call
* Tcl_EvalEx. Used primarily for testing the
* new parser.
* INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently
* active; so no further trace callbacks should be
* invoked.
*/
#define DELETED 1
#define ERR_IN_PROGRESS 2
#define ERR_ALREADY_LOGGED 4
#define ERROR_CODE_SET 8
#define EXPR_INITIALIZED 0x10
#define DONT_COMPILE_CMDS_INLINE 0x20
#define RAND_SEED_INITIALIZED 0x40
#define SAFE_INTERP 0x80
#define USE_EVAL_DIRECT 0x100
#define INTERP_TRACE_IN_PROGRESS 0x200
/*
* Maximum number of levels of nesting permitted in Tcl commands (used
* to catch infinite recursion).
*/
#define MAX_NESTING_DEPTH 1000
/*
* The macro below is used to modify a "char" value (e.g. by casting
* it to an unsigned character) so that it can be used safely with
* macros such as isspace.
*/
#define UCHAR(c) ((unsigned char) (c))
/*
* This macro is used to determine the offset needed to safely allocate any
* data structure in memory. Given a starting offset or size, it "rounds up"
* or "aligns" the offset to the next 8-byte boundary so that any data
* structure can be placed at the resulting offset without fear of an
* alignment error.
*
* WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce
* the wrong result on platforms that allocate addresses that are divisible
* by 4 or 2. Only use it for offsets or sizes.
*/
#define TCL_ALIGN(x) (((int)(x) + 7) & ~7)
/*
* The following enum values are used to specify the runtime platform
* setting of the tclPlatform variable.
*/
typedef enum {
TCL_PLATFORM_UNIX, /* Any Unix-like OS. */
TCL_PLATFORM_WINDOWS=2 /* Any Microsoft Windows OS. */
} TclPlatformType;
/*
* The following enum values are used to indicate the translation
* of a Tcl channel. Declared here so that each platform can define
* TCL_PLATFORM_TRANSLATION to the native translation on that platform
*/
typedef enum TclEolTranslation {
TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */
TCL_TRANSLATE_CR, /* Eol == \r. */
TCL_TRANSLATE_LF, /* Eol == \n. */
TCL_TRANSLATE_CRLF /* Eol == \r\n. */
} TclEolTranslation;
/*
* Flags for TclInvoke:
*
* TCL_INVOKE_HIDDEN Invoke a hidden command; if not set,
* invokes an exposed command.
* TCL_INVOKE_NO_UNKNOWN If set, "unknown" is not invoked if
* the command to be invoked is not found.
* Only has an effect if invoking an exposed
* command, i.e. if TCL_INVOKE_HIDDEN is not
* also set.
* TCL_INVOKE_NO_TRACEBACK Does not record traceback information if
* the invoked command returns an error. Used
* if the caller plans on recording its own
* traceback information.
*/
#define TCL_INVOKE_HIDDEN (1<<0)
#define TCL_INVOKE_NO_UNKNOWN (1<<1)
#define TCL_INVOKE_NO_TRACEBACK (1<<2)
/*
* The structure used as the internal representation of Tcl list
* objects. This is an array of pointers to the element objects. This array
* is grown (reallocated and copied) as necessary to hold all the list's
* element pointers. The array might contain more slots than currently used
* to hold all element pointers. This is done to make append operations
* faster.
*/
typedef struct List {
int maxElemCount; /* Total number of element array slots. */
int elemCount; /* Current number of list elements. */
Tcl_Obj **elements; /* Array of pointers to element objects. */
} List;
/*
* The following types are used for getting and storing platform-specific
* file attributes in tclFCmd.c and the various platform-versions of
* that file. This is done to have as much common code as possible
* in the file attributes code. For more information about the callbacks,
* see TclFileAttrsCmd in tclFCmd.c.
*/
typedef int (TclGetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName, Tcl_Obj **attrObjPtrPtr));
typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp,
int objIndex, Tcl_Obj *fileName, Tcl_Obj *attrObjPtr));
typedef struct TclFileAttrProcs {
TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */
TclSetFileAttrProc *setProc; /* The procedure for setting attrs. */
} TclFileAttrProcs;
/*
* Opaque handle used in pipeline routines to encapsulate platform-dependent
* state.
*/
typedef struct TclFile_ *TclFile;
/*
* Opaque names for platform specific types.
*/
typedef struct TclpTime_t_ *TclpTime_t;
typedef struct TclpTime_t_ *CONST TclpTime_t_CONST;
/*
* The "globParameters" argument of the function TclGlob is an
* or'ed combination of the following values:
*/
#define TCL_GLOBMODE_NO_COMPLAIN 1
#define TCL_GLOBMODE_JOIN 2
#define TCL_GLOBMODE_DIR 4
#define TCL_GLOBMODE_TAILS 8
/*
*----------------------------------------------------------------
* Data structures related to obsolete filesystem hooks
*----------------------------------------------------------------
*/
typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, Tcl_StatBuf *buf));
typedef int (TclAccessProc_) _ANSI_ARGS_((CONST char *path, int mode));
typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *fileName, CONST char *modeString,
int permissions));
/*
*----------------------------------------------------------------
* Data structures related to procedures
*----------------------------------------------------------------
*/
typedef Tcl_CmdProc *TclCmdProcType;
typedef Tcl_ObjCmdProc *TclObjCmdProcType;
/*
*----------------------------------------------------------------
* Variables shared among Tcl modules but not used by the outside world.
*----------------------------------------------------------------
*/
extern Tcl_Time tclBlockTime;
extern int tclBlockTimeSet;
extern char * tclExecutableName;
extern char * tclNativeExecutableName;
extern char * tclDefaultEncodingDir;
extern Tcl_ChannelType tclFileChannelType;
extern char * tclMemDumpFileName;
extern TclPlatformType tclPlatform;
extern Tcl_NotifierProcs tclOriginalNotifier;
/*
* Variables denoting the Tcl object types defined in the core.
*/
extern Tcl_ObjType tclBooleanType;
extern Tcl_ObjType tclByteArrayType;
extern Tcl_ObjType tclByteCodeType;
extern Tcl_ObjType tclDoubleType;
extern Tcl_ObjType tclEndOffsetType;
extern Tcl_ObjType tclIntType;
extern Tcl_ObjType tclListType;
extern Tcl_ObjType tclProcBodyType;
extern Tcl_ObjType tclStringType;
extern Tcl_ObjType tclArraySearchType;
extern Tcl_ObjType tclIndexType;
extern Tcl_ObjType tclNsNameType;
extern Tcl_ObjType tclWideIntType;
/*
* Variables denoting the hash key types defined in the core.
*/
extern Tcl_HashKeyType tclArrayHashKeyType;
extern Tcl_HashKeyType tclOneWordHashKeyType;
extern Tcl_HashKeyType tclStringHashKeyType;
extern Tcl_HashKeyType tclObjHashKeyType;
/*
* The head of the list of free Tcl objects, and the total number of Tcl
* objects ever allocated and freed.
*/
extern Tcl_Obj * tclFreeObjList;
#ifdef TCL_COMPILE_STATS
extern long tclObjsAlloced;
extern long tclObjsFreed;
#define TCL_MAX_SHARED_OBJ_STATS 5
extern long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
#endif /* TCL_COMPILE_STATS */
/*
* Pointer to a heap-allocated string of length zero that the Tcl core uses
* as the value of an empty string representation for an object. This value
* is shared by all new objects allocated by Tcl_NewObj.
*/
extern char * tclEmptyStringRep;
extern char tclEmptyString;
/*
*----------------------------------------------------------------
* Procedures shared among Tcl modules but not used by the outside
* world:
*----------------------------------------------------------------
*/
#ifdef TCL_TIP280
EXTERN void TclAdvanceLines _ANSI_ARGS_((int* line, CONST char* start,
CONST char* end));
EXTERN void TclAdvanceContinuations _ANSI_ARGS_((int* line, int** next,
int loc));
EXTERN ContLineLoc* TclContinuationsEnter _ANSI_ARGS_((Tcl_Obj* objPtr, int num,
int* loc));
EXTERN void TclContinuationsEnterDerived _ANSI_ARGS_((Tcl_Obj* objPtr,
int start, int* clNext));
EXTERN ContLineLoc* TclContinuationsGet _ANSI_ARGS_((Tcl_Obj* objPtr));
EXTERN void TclContinuationsCopy _ANSI_ARGS_((Tcl_Obj* objPtr, Tcl_Obj* originObjPtr));
#endif
EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
EXTERN int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *value));
EXTERN void TclDeleteNamespaceVars _ANSI_ARGS_((Namespace *nsPtr));
#ifdef TCL_TIP280
EXTERN int TclEvalObjEx _ANSI_ARGS_((Tcl_Interp *interp,
register Tcl_Obj *objPtr,
int flags,
CONST CmdFrame* invoker,
int word));
EXTERN void TclArgumentEnter _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* objv[], int objc, CmdFrame* cf));
EXTERN void TclArgumentRelease _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* objv[], int objc));
EXTERN void TclArgumentBCEnter _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* objv[], int objc,
void* codePtr, CmdFrame* cfPtr, int pc));
EXTERN void TclArgumentBCRelease _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* objv[], int objc,
void* codePtr, int pc));
EXTERN void TclArgumentGet _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj,
CmdFrame** cfPtrPtr, int* wordPtr));
#endif
EXTERN void TclExpandTokenArray _ANSI_ARGS_((
Tcl_Parse *parsePtr));
EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[])) ;
EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[])) ;
EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[])) ;
EXTERN void TclCreateLateExitHandler (Tcl_ExitProc * proc,
ClientData clientData);
EXTERN void TclDeleteLateExitHandler (Tcl_ExitProc * proc,
ClientData clientData);
EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void));
EXTERN void TclFinalizeAsync _ANSI_ARGS_((void));
EXTERN void TclFinalizeCompilation _ANSI_ARGS_((void));
EXTERN void TclFinalizeEncodingSubsystem _ANSI_ARGS_((void));
EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void));
EXTERN void TclFinalizeExecution _ANSI_ARGS_((void));
EXTERN void TclFinalizeIOSubsystem _ANSI_ARGS_((void));
EXTERN void TclFinalizeFilesystem _ANSI_ARGS_((void));
EXTERN void TclResetFilesystem _ANSI_ARGS_((void));
EXTERN void TclFinalizeLoad _ANSI_ARGS_((void));
EXTERN void TclFinalizeLock _ANSI_ARGS_((void));
EXTERN void TclFinalizeMemorySubsystem _ANSI_ARGS_((void));
EXTERN void TclFinalizeNotifier _ANSI_ARGS_((void));
EXTERN void TclFinalizeObjects _ANSI_ARGS_((void));
EXTERN void TclFinalizePreserve _ANSI_ARGS_((void));
EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void));
EXTERN void TclFinalizeThreadAlloc _ANSI_ARGS_((void));
EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void));
EXTERN int TclGetEncodingFromObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr));
#ifdef TCL_TIP280
EXTERN void TclGetSrcInfoForPc _ANSI_ARGS_((CmdFrame* cfPtr));
#endif
EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
char *pattern, Tcl_Obj *unquotedPrefix,
int globFlags, Tcl_GlobTypeData* types));
EXTERN void TclInitAlloc _ANSI_ARGS_((void));
EXTERN void TclInitDbCkalloc _ANSI_ARGS_((void));
EXTERN void TclInitEncodingSubsystem _ANSI_ARGS_((void));
EXTERN void TclInitIOSubsystem _ANSI_ARGS_((void));
EXTERN void TclInitNamespaceSubsystem _ANSI_ARGS_((void));
EXTERN void TclInitNotifier _ANSI_ARGS_((void));
EXTERN void TclInitObjSubsystem _ANSI_ARGS_((void));
EXTERN void TclInitSubsystems _ANSI_ARGS_((CONST char *argv0));
EXTERN int TclIsLocalScalar _ANSI_ARGS_((CONST char *src,
int len));
EXTERN int TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id,
int* result));
EXTERN Tcl_Obj * TclLindexList _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* listPtr,
Tcl_Obj* argPtr ));
EXTERN Tcl_Obj * TclLindexFlat _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* listPtr,
int indexCount,
Tcl_Obj *CONST indexArray[]
));
EXTERN Tcl_Obj * TclLsetList _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* listPtr,
Tcl_Obj* indexPtr,
Tcl_Obj* valuePtr
));
EXTERN Tcl_Obj * TclLsetFlat _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* listPtr,
int indexCount,
Tcl_Obj *CONST indexArray[],
Tcl_Obj* valuePtr
));
EXTERN int TclParseBackslash _ANSI_ARGS_((CONST char *src,
int numBytes, int *readPtr, char *dst));
EXTERN int TclParseHex _ANSI_ARGS_((CONST char *src, int numBytes,
Tcl_UniChar *resultPtr));
EXTERN int TclParseInteger _ANSI_ARGS_((CONST char *string,
int numBytes));
EXTERN int TclParseWhiteSpace _ANSI_ARGS_((CONST char *src,
int numBytes, Tcl_Parse *parsePtr, char *typePtr));
#ifdef TCL_TIP280
EXTERN int TclWordKnownAtCompileTime _ANSI_ARGS_((Tcl_Token* token));
#endif
EXTERN int TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename,
int mode));
EXTERN int TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_StatBuf *buf));
EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
EXTERN Tcl_Obj* TclpTempFileName _ANSI_ARGS_((void));
EXTERN Tcl_Obj* TclNewFSPathObj _ANSI_ARGS_((Tcl_Obj *dirPtr,
CONST char *addStrRep, int len));
EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path));
EXTERN void TclpFinalizeCondition _ANSI_ARGS_((
Tcl_Condition *condPtr));
EXTERN void TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
EXTERN void TclpFinalizePipes _ANSI_ARGS_((void));
EXTERN void TclpFinalizeSockets _ANSI_ARGS_((void));
EXTERN void TclpFinalizeThreadData _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr));
EXTERN void TclpFinalizeThreadDataKey _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr));
EXTERN char * TclpFindExecutable _ANSI_ARGS_((
CONST char *argv0));
EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name,
int *lengthPtr));
EXTERN int TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0));
EXTERN void TclpInitLock _ANSI_ARGS_((void));
EXTERN void TclpInitPlatform _ANSI_ARGS_((void));
EXTERN void TclpInitUnlock _ANSI_ARGS_((void));
EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr,
CONST char *sym1, CONST char *sym2,
Tcl_PackageInitProc **proc1Ptr,
Tcl_PackageInitProc **proc2Ptr,
ClientData *clientDataPtr,
Tcl_FSUnloadFileProc **unloadProcPtr));
EXTERN Tcl_Obj* TclpObjListVolumes _ANSI_ARGS_((void));
EXTERN void TclpMasterLock _ANSI_ARGS_((void));
EXTERN void TclpMasterUnlock _ANSI_ARGS_((void));
EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp,
char *separators, Tcl_DString *dirPtr,
char *pattern, char *tail));
EXTERN int TclpObjNormalizePath _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, int nextCheckpoint));
EXTERN int TclpObjCreateDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr));
EXTERN void TclpNativeJoinPath _ANSI_ARGS_((Tcl_Obj *prefix,
char *joining));
EXTERN Tcl_Obj* TclpNativeSplitPath _ANSI_ARGS_((Tcl_Obj *pathPtr,
int *lenPtr));
EXTERN Tcl_PathType TclpGetNativePathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
EXTERN int TclCrossFilesystemCopy _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *source, Tcl_Obj *target));
EXTERN int TclpObjDeleteFile _ANSI_ARGS_((Tcl_Obj *pathPtr));
EXTERN int TclpObjCopyDirectory _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
EXTERN int TclpObjCopyFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr));
EXTERN int TclpObjRemoveDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr,
int recursive, Tcl_Obj **errorPtr));
EXTERN int TclpObjRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr));
EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *resultPtr, Tcl_Obj *pathPtr,
CONST char *pattern, Tcl_GlobTypeData *types));
EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_Obj *toPtr, int linkType));
EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr));
EXTERN Tcl_Obj* TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj*pathPtr));
EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, int mode,
int permissions));
EXTERN void TclpPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *,
format));
EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName,
Tcl_DString *linkPtr));
EXTERN void TclpReleaseFile _ANSI_ARGS_((TclFile file));
EXTERN void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN void TclpUnloadFile _ANSI_ARGS_((Tcl_LoadHandle loadHandle));
EXTERN VOID * TclpThreadDataKeyGet _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr));
EXTERN void TclpThreadDataKeyInit _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr));
EXTERN void TclpThreadDataKeySet _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr, VOID *data));
EXTERN int TclpThreadCreate _ANSI_ARGS_((
Tcl_ThreadId *idPtr,
Tcl_ThreadCreateProc proc,
ClientData clientData,
int stackSize, int flags));
EXTERN void TclpThreadExit _ANSI_ARGS_((int status));
EXTERN void TclRememberCondition _ANSI_ARGS_((Tcl_Condition *mutex));
EXTERN void TclRememberDataKey _ANSI_ARGS_((Tcl_ThreadDataKey *mutex));
EXTERN VOID TclRememberJoinableThread _ANSI_ARGS_((Tcl_ThreadId id));
EXTERN void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex));
EXTERN VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
int result));
EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp,
int result, Tcl_Interp *targetInterp));
EXTERN Tcl_Obj* TclpNativeToNormalized
_ANSI_ARGS_((ClientData clientData));
EXTERN Tcl_Obj* TclpFilesystemPathType
_ANSI_ARGS_((Tcl_Obj* pathObjPtr));
EXTERN Tcl_PackageInitProc* TclpFindSymbol _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_LoadHandle loadHandle, CONST char *symbol));
EXTERN int TclpDlopen _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr,
Tcl_LoadHandle *loadHandle,
Tcl_FSUnloadFileProc **unloadProcPtr));
EXTERN int TclpUtime _ANSI_ARGS_((Tcl_Obj *pathPtr,
struct utimbuf *tval));
#ifdef TCL_LOAD_FROM_MEMORY
EXTERN void* TclpLoadMemoryGetBuffer _ANSI_ARGS_((
Tcl_Interp *interp, int size));
EXTERN int TclpLoadMemory _ANSI_ARGS_((Tcl_Interp *interp,
void *buffer, int size, int codeSize,
Tcl_LoadHandle *loadHandle,
Tcl_FSUnloadFileProc **unloadProcPtr));
#endif
/*
*----------------------------------------------------------------
* Command procedures in the generic core:
*----------------------------------------------------------------
*/
EXTERN int Tcl_AfterObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_AppendObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_BinaryObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_BreakObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_CaseObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_CdObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ClockObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ContinueObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_EncodingObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ErrorObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_EvalObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ExecObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FconfigureObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FcopyObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FileObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FileEventObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FlushObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ForObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ForeachObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FormatObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_GetsObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_GlobalObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_GlobObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_IfObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_IncrObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_InfoObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_InterpObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_JoinObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LappendObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LindexObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LinsertObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LlengthObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ListObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LoadObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LrangeObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LreplaceObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LsearchObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LsetObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp* interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LsortObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_OpenObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_PackageObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_PidObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_PutsObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_PwdObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ReadObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_RegexpObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_RegsubObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_RenameObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ReturnObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ScanObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SeekObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SetObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SplitObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SocketObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SourceObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_StringObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SubstObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SwitchObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_TellObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_TimeObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_TraceObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_UnsetObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_UpdateObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_UplevelObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_UpvarObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_VariableObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_VwaitObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_WhileObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
/*
*----------------------------------------------------------------
* Compilation procedures for commands in the generic core:
*----------------------------------------------------------------
*/
EXTERN int TclCompileAppendCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileLappendCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileLindexCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileListCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileLlengthCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileLsetCmd _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Parse* parsePtr, struct CompileEnv* envPtr));
EXTERN int TclCompileRegexpCmd _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Parse* parsePtr, struct CompileEnv* envPtr));
EXTERN int TclCompileReturnCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileStringCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
/*
* Functions defined in generic/tclVar.c and currenttly exported only
* for use by the bytecode compiler and engine. Some of these could later
* be placed in the public interface.
*/
EXTERN Var * TclLookupArrayElement _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *arrayName, CONST char *elName, CONST int flags,
CONST char *msg, CONST int createPart1,
CONST int createPart2, Var *arrayPtr));
EXTERN Var * TclObjLookupVar _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *part1Ptr, CONST char *part2, int flags,
CONST char *msg, CONST int createPart1,
CONST int createPart2, Var **arrayPtrPtr));
EXTERN Tcl_Obj *TclPtrGetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, CONST char *part1, CONST char *part2,
CONST int flags));
EXTERN Tcl_Obj *TclPtrSetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, CONST char *part1, CONST char *part2,
Tcl_Obj *newValuePtr, CONST int flags));
EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, CONST char *part1, CONST char *part2,
CONST long i, CONST int flags));
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and release Tcl objects.
* TclNewObj(objPtr) creates a new object denoting an empty string.
* TclDecrRefCount(objPtr) decrements the object's reference count,
* and frees the object if its reference count is zero.
* These macros are inline versions of Tcl_NewObj() and
* Tcl_DecrRefCount(). Notice that the names differ in not having
* a "_" after the "Tcl". Notice also that these macros reference
* their argument more than once, so you should avoid calling them
* with an expression that is expensive to compute or has
* side effects. The ANSI C "prototypes" for these macros are:
*
* EXTERN void TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr));
* EXTERN void TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
*
* These macros are defined in terms of two macros that depend on
* memory allocator in use: TclAllocObjStorage, TclFreeObjStorage.
* They are defined below.
*----------------------------------------------------------------
*/
/*
* DTrace object allocation probe macros.
*/
#ifdef USE_DTRACE
#include "tclDTrace.h"
#define TCL_DTRACE_OBJ_CREATE(objPtr) TCL_OBJ_CREATE(objPtr)
#define TCL_DTRACE_OBJ_FREE(objPtr) TCL_OBJ_FREE(objPtr)
#else /* USE_DTRACE */
#define TCL_DTRACE_OBJ_CREATE(objPtr) {}
#define TCL_DTRACE_OBJ_FREE(objPtr) {}
#endif /* USE_DTRACE */
#ifdef TCL_COMPILE_STATS
# define TclIncrObjsAllocated() \
tclObjsAlloced++
# define TclIncrObjsFreed() \
tclObjsFreed++
#else
# define TclIncrObjsAllocated()
# define TclIncrObjsFreed()
#endif /* TCL_COMPILE_STATS */
#define TclNewObj(objPtr) \
TclAllocObjStorage(objPtr); \
TclIncrObjsAllocated(); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TCL_DTRACE_OBJ_CREATE(objPtr)
#ifdef TCL_MEM_DEBUG
# define TclDecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
#else
# define TclDecrRefCount(objPtr) \
if (--(objPtr)->refCount <= 0) { \
TCL_DTRACE_OBJ_FREE(objPtr); \
if (((objPtr)->typePtr != NULL) \
&& ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
(objPtr)->typePtr->freeIntRepProc(objPtr); \
} \
if (((objPtr)->bytes != NULL) \
&& ((objPtr)->bytes != tclEmptyStringRep)) { \
ckfree((char *) (objPtr)->bytes); \
} \
TclFreeObjStorage(objPtr); \
TclIncrObjsFreed(); \
}
#endif
#ifdef TCL_MEM_DEBUG
# define TclAllocObjStorage(objPtr) \
(objPtr) = (Tcl_Obj *) \
Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__)
# define TclFreeObjStorage(objPtr) \
if ((objPtr)->refCount < -1) { \
panic("Reference count for %lx was negative: %s line %d", \
(objPtr), __FILE__, __LINE__); \
} \
ckfree((char *) (objPtr))
# define TclDbNewObj(objPtr, file, line) \
(objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TclIncrObjsAllocated(); \
TCL_DTRACE_OBJ_CREATE(objPtr)
#elif defined(PURIFY)
/*
* The PURIFY mode is like the regular mode, but instead of doing block
* Tcl_Obj allocation and keeping a freed list for efficiency, it always
* allocates and frees a single Tcl_Obj so that tools like Purify can
* better track memory leaks
*/
# define TclAllocObjStorage(objPtr) \
(objPtr) = (Tcl_Obj *) Tcl_Ckalloc(sizeof(Tcl_Obj))
# define TclFreeObjStorage(objPtr) \
ckfree((char *) (objPtr))
#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
/*
* The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's
* from per-thread caches.
*/
EXTERN Tcl_Obj *TclThreadAllocObj _ANSI_ARGS_((void));
EXTERN void TclThreadFreeObj _ANSI_ARGS_((Tcl_Obj *));
EXTERN void TclFreeAllocCache _ANSI_ARGS_((void *));
EXTERN void TclpFreeAllocMutex _ANSI_ARGS_((Tcl_Mutex* mutex));
EXTERN void TclpFreeAllocCache _ANSI_ARGS_((void *));
# define TclAllocObjStorage(objPtr) \
(objPtr) = TclThreadAllocObj()
# define TclFreeObjStorage(objPtr) \
TclThreadFreeObj((objPtr))
#else /* not TCL_MEM_DEBUG */
#if defined(USE_TCLALLOC) && USE_TCLALLOC
MODULE_SCOPE void TclFinalizeAllocSubsystem();
MODULE_SCOPE void TclInitAlloc();
#else
# define USE_TCLALLOC 0
#endif
#ifdef TCL_THREADS
/* declared in tclObj.c */
extern Tcl_Mutex tclObjMutex;
#endif
# define TclAllocObjStorage(objPtr) \
Tcl_MutexLock(&tclObjMutex); \
if (tclFreeObjList == NULL) { \
TclAllocateFreeObjects(); \
} \
(objPtr) = tclFreeObjList; \
tclFreeObjList = (Tcl_Obj *) \
tclFreeObjList->internalRep.otherValuePtr; \
Tcl_MutexUnlock(&tclObjMutex)
# define TclFreeObjStorage(objPtr) \
Tcl_MutexLock(&tclObjMutex); \
(objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \
tclFreeObjList = (objPtr); \
Tcl_MutexUnlock(&tclObjMutex)
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to set a Tcl_Obj's string representation
* to a copy of the "len" bytes starting at "bytePtr". This code
* works even if the byte array contains NULLs as long as the length
* is correct. Because "len" is referenced multiple times, it should
* be as simple an expression as possible. The ANSI C "prototype" for
* this macro is:
*
* EXTERN void TclInitStringRep _ANSI_ARGS_((Tcl_Obj *objPtr,
* char *bytePtr, int len));
*----------------------------------------------------------------
*/
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
(objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
} else { \
(objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \
memcpy((VOID *) (objPtr)->bytes, (VOID *) (bytePtr), \
(unsigned) (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get the string representation's
* byte array pointer from a Tcl_Obj. This is an inline version
* of Tcl_GetString(). The macro's expression result is the string
* rep's byte pointer which might be NULL. The bytes referenced by
* this pointer must not be modified by the caller.
* The ANSI C "prototype" for this macro is:
*
* EXTERN char * TclGetString _ANSI_ARGS_((Tcl_Obj *objPtr));
*----------------------------------------------------------------
*/
#define TclGetString(objPtr) \
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get a Tcl_WideInt value out of
* a Tcl_Obj of the "wideInt" type. Different implementation on
* different platforms depending whether TCL_WIDE_INT_IS_LONG.
*----------------------------------------------------------------
*/
#ifdef TCL_WIDE_INT_IS_LONG
# define TclGetWide(resultVar, objPtr) \
(resultVar) = (objPtr)->internalRep.longValue
# define TclGetLongFromWide(resultVar, objPtr) \
(resultVar) = (objPtr)->internalRep.longValue
#else
# define TclGetWide(resultVar, objPtr) \
(resultVar) = (objPtr)->internalRep.wideValue
# define TclGetLongFromWide(resultVar, objPtr) \
(resultVar) = Tcl_WideAsLong((objPtr)->internalRep.wideValue)
#endif
/*
*----------------------------------------------------------------
* Macro used by the Tcl core get a unicode char from a utf string.
* It checks to see if we have a one-byte utf char before calling
* the real Tcl_UtfToUniChar, as this will save a lot of time for
* primarily ascii string handling. The macro's expression result
* is 1 for the 1-byte case or the result of Tcl_UtfToUniChar.
* The ANSI C "prototype" for this macro is:
*
* EXTERN int TclUtfToUniChar _ANSI_ARGS_((CONST char *string,
* Tcl_UniChar *ch));
*----------------------------------------------------------------
*/
#define TclUtfToUniChar(str, chPtr) \
((((unsigned char) *(str)) < 0xC0) ? \
((*(chPtr) = (Tcl_UniChar) *(str)), 1) \
: Tcl_UtfToUniChar(str, chPtr))
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to compare Unicode strings. On
* big-endian systems we can use the more efficient memcmp, but
* this would not be lexically correct on little-endian systems.
* The ANSI C "prototype" for this macro is:
*
* EXTERN int TclUniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar *cs,
* CONST Tcl_UniChar *ct, unsigned long n));
*----------------------------------------------------------------
*/
#ifdef WORDS_BIGENDIAN
# define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar))
#else /* !WORDS_BIGENDIAN */
# define TclUniCharNcmp Tcl_UniCharNcmp
#endif /* WORDS_BIGENDIAN */
#include "tclIntDecls.h"
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLINT */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclPlatDecls.h 0000644 0036047 0045461 00000006140 12052456744 015062 0 ustar dgp 771div /*
* tclPlatDecls.h --
*
* Declarations of platform specific Tcl APIs.
*
* Copyright (c) 1998-1999 by Scriptics Corporation.
* All rights reserved.
*/
#ifndef _TCLPLATDECLS
#define _TCLPLATDECLS
/*
* TCHAR is needed here for win32, so if it is not defined yet do it here.
* This way, we don't need to include just for one define.
*/
#if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(_TCHAR_DEFINED)
# if defined(_UNICODE)
typedef wchar_t TCHAR;
# else
typedef char TCHAR;
# endif
# define _TCHAR_DEFINED
#endif
/* !BEGIN!: Do not edit below this line. */
/*
* Exported function declarations:
*/
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN TCHAR * Tcl_WinUtfToTChar _ANSI_ARGS_((CONST char *str,
int len, Tcl_DString *dsPtr));
/* 1 */
EXTERN char * Tcl_WinTCharToUtf _ANSI_ARGS_((CONST TCHAR *str,
int len, Tcl_DString *dsPtr));
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
EXTERN int Tcl_MacOSXOpenBundleResources _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *bundleName,
int hasResourceFile, int maxPathLen,
char *libraryPath));
/* 1 */
EXTERN int Tcl_MacOSXOpenVersionedBundleResources _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *bundleName,
CONST char *bundleVersion,
int hasResourceFile, int maxPathLen,
char *libraryPath));
#endif /* MACOSX */
typedef struct TclPlatStubs {
int magic;
struct TclPlatStubHooks *hooks;
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
TCHAR * (*tcl_WinUtfToTChar) _ANSI_ARGS_((CONST char *str, int len, Tcl_DString *dsPtr)); /* 0 */
char * (*tcl_WinTCharToUtf) _ANSI_ARGS_((CONST TCHAR *str, int len, Tcl_DString *dsPtr)); /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
int (*tcl_MacOSXOpenBundleResources) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath)); /* 0 */
int (*tcl_MacOSXOpenVersionedBundleResources) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *bundleName, CONST char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath)); /* 1 */
#endif /* MACOSX */
} TclPlatStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern TclPlatStubs *tclPlatStubsPtr;
#ifdef __cplusplus
}
#endif
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
/*
* Inline function declarations:
*/
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
#ifndef Tcl_WinUtfToTChar
#define Tcl_WinUtfToTChar \
(tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */
#endif
#ifndef Tcl_WinTCharToUtf
#define Tcl_WinTCharToUtf \
(tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */
#endif
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
#ifndef Tcl_MacOSXOpenBundleResources
#define Tcl_MacOSXOpenBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
#endif
#ifndef Tcl_MacOSXOpenVersionedBundleResources
#define Tcl_MacOSXOpenVersionedBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */
#endif
#endif /* MACOSX */
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
/* !END!: Do not edit above this line. */
#endif /* _TCLPLATDECLS */
tcl8.4.20/generic/tclTestProcBodyObj.c 0000644 0036047 0045461 00000021073 12052456744 016220 0 ustar dgp 771div /*
* tclTestProcBodyObj.c --
*
* Implements the "procbodytest" package, which contains commands
* to test creation of Tcl procedures whose body argument is a
* Tcl_Obj of type "procbody" rather than a string.
*
* Copyright (c) 1998 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* name and version of this package
*/
static CONST char packageName[] = "procbodytest";
static CONST char packageVersion[] = "1.0";
/*
* Name of the commands exported by this package
*/
static CONST char procCommand[] = "proc";
/*
* this struct describes an entry in the table of command names and command
* procs
*/
typedef struct CmdTable
{
CONST char *cmdName; /* command name */
Tcl_ObjCmdProc *proc; /* command proc */
int exportIt; /* if 1, export the command */
} CmdTable;
/*
* Declarations for functions defined in this file.
*/
static int ProcBodyTestProcObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int ProcBodyTestInitInternal _ANSI_ARGS_((Tcl_Interp *interp,
int isSafe));
static int RegisterCommand _ANSI_ARGS_((Tcl_Interp* interp,
CONST char *namespace, CONST CmdTable *cmdTablePtr));
int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp * interp));
int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp * interp));
/*
* List of commands to create when the package is loaded; must go after the
* declarations of the enable command procedure.
*/
static CONST CmdTable commands[] =
{
{ procCommand, ProcBodyTestProcObjCmd, 1 },
{ 0, 0, 0 }
};
static CONST CmdTable safeCommands[] =
{
{ procCommand, ProcBodyTestProcObjCmd, 1 },
{ 0, 0, 0 }
};
/*
*----------------------------------------------------------------------
*
* Procbodytest_Init --
*
* This procedure initializes the "procbodytest" package.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Procbodytest_Init(interp)
Tcl_Interp *interp; /* the Tcl interpreter for which the package
* is initialized */
{
return ProcBodyTestInitInternal(interp, 0);
}
/*
*----------------------------------------------------------------------
*
* Procbodytest_SafeInit --
*
* This procedure initializes the "procbodytest" package.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Procbodytest_SafeInit(interp)
Tcl_Interp *interp; /* the Tcl interpreter for which the package
* is initialized */
{
return ProcBodyTestInitInternal(interp, 1);
}
/*
*----------------------------------------------------------------------
*
* RegisterCommand --
*
* This procedure registers a command in the context of the given namespace.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int RegisterCommand(interp, namespace, cmdTablePtr)
Tcl_Interp* interp; /* the Tcl interpreter for which the
* operation is performed */
CONST char *namespace; /* the namespace in which the command
* is registered */
CONST CmdTable *cmdTablePtr; /* the command to register */
{
char buf[128];
if (cmdTablePtr->exportIt) {
sprintf(buf, "namespace eval %s { namespace export %s }",
namespace, cmdTablePtr->cmdName);
if (Tcl_Eval(interp, buf) != TCL_OK)
return TCL_ERROR;
}
sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName);
Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ProcBodyTestInitInternal --
*
* This procedure initializes the Loader package.
* The isSafe flag is 1 if the interpreter is safe, 0 otherwise.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ProcBodyTestInitInternal(interp, isSafe)
Tcl_Interp *interp; /* the Tcl interpreter for which the package
* is initialized */
int isSafe; /* 1 if this is a safe interpreter */
{
CONST CmdTable *cmdTablePtr;
cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0];
for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) {
if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) {
return TCL_ERROR;
}
}
return Tcl_PkgProvide(interp, packageName, packageVersion);
}
/*
*----------------------------------------------------------------------
*
* ProcBodyTestProcObjCmd --
*
* Implements the "procbodytest::proc" command. Here is the command
* description:
* procbodytest::proc newName argList bodyName
* Looks up a procedure called $bodyName and, if the procedure exists,
* constructs a Tcl_Obj of type "procbody" and calls Tcl_ProcObjCmd.
* Arguments:
* newName the name of the procedure to be created
* argList the argument list for the procedure
* bodyName the name of an existing procedure from which the
* body is to be copied.
* This command can be used to trigger the branches in Tcl_ProcObjCmd that
* construct a proc from a "procbody", for example:
* proc a {x} {return $x}
* a 123
* procbodytest::proc b {x} a
* Note the call to "a 123", which is necessary so that the Proc pointer
* for "a" is filled in by the internal compiler; this is a hack.
*
* Results:
* Returns a standard Tcl code.
*
* Side effects:
* A new procedure is created.
* Leaves an error message in the interp's result on error.
*
*----------------------------------------------------------------------
*/
static int
ProcBodyTestProcObjCmd (dummy, interp, objc, objv)
ClientData dummy; /* context; not used */
Tcl_Interp *interp; /* the current interpreter */
int objc; /* argument count */
Tcl_Obj *CONST objv[]; /* arguments */
{
char *fullName;
Tcl_Command procCmd;
Command *cmdPtr;
Proc *procPtr = (Proc *) NULL;
Tcl_Obj *bodyObjPtr;
Tcl_Obj *myobjv[5];
int result;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "newName argsList bodyName");
return TCL_ERROR;
}
/*
* Find the Command pointer to this procedure
*/
fullName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
procCmd = Tcl_FindCommand(interp, fullName, (Tcl_Namespace *) NULL,
TCL_LEAVE_ERR_MSG);
if (procCmd == NULL) {
return TCL_ERROR;
}
cmdPtr = (Command *) procCmd;
/*
* check that this is a procedure and not a builtin command:
* If a procedure, cmdPtr->objProc is either 0 or TclObjInterpProc,
* and cmdPtr->proc is either 0 or TclProcInterpProc.
* Also, the compile proc should be 0, but we don't check for that.
*/
if (((cmdPtr->objProc != NULL)
&& (cmdPtr->objProc != TclGetObjInterpProc()))
|| ((cmdPtr->proc != NULL)
&& (cmdPtr->proc != TclGetInterpProc()))) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"command \"", fullName,
"\" is not a Tcl procedure", (char *) NULL);
return TCL_ERROR;
}
/*
* it is a Tcl procedure: the client data is the Proc structure
*/
if (cmdPtr->objProc != NULL) {
procPtr = (Proc *) cmdPtr->objClientData;
} else if (cmdPtr->proc != NULL) {
procPtr = (Proc *) cmdPtr->clientData;
}
if (procPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"procedure \"", fullName,
"\" does not have a Proc struct!", (char *) NULL);
return TCL_ERROR;
}
/*
* create a new object, initialize our argument vector, call into Tcl
*/
bodyObjPtr = TclNewProcBodyObj(procPtr);
if (bodyObjPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"failed to create a procbody object for procedure \"",
fullName, "\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_IncrRefCount(bodyObjPtr);
myobjv[0] = objv[0];
myobjv[1] = objv[1];
myobjv[2] = objv[2];
myobjv[3] = bodyObjPtr;
myobjv[4] = (Tcl_Obj *) NULL;
result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv);
Tcl_DecrRefCount(bodyObjPtr);
return result;
}
tcl8.4.20/generic/regfree.c 0000644 0036047 0045461 00000004046 11737050674 014122 0 ustar dgp 771div /*
* regfree - free an RE
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*
*
* You might think that this could be incorporated into regcomp.c, and
* that would be a reasonable idea... except that this is a generic
* function (with a generic name), applicable to all compiled REs
* regardless of the size of their characters, whereas the stuff in
* regcomp.c gets compiled once per character size.
*/
#include "regguts.h"
/*
- regfree - free an RE (generic function, punts to RE-specific function)
*
* Ignoring invocation with NULL is a convenience.
*/
VOID
regfree(re)
regex_t *re;
{
if (re == NULL)
return;
(*((struct fns *)re->re_fns)->free)(re);
}
tcl8.4.20/generic/tclThread.c 0000644 0036047 0045461 00000031042 11737050674 014411 0 ustar dgp 771div /*
* tclThread.c --
*
* This file implements Platform independent thread operations.
* Most of the real work is done in the platform dependent files.
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* There are three classes of synchronization objects:
* mutexes, thread data keys, and condition variables.
* The following are used to record the memory used for these
* objects so they can be finalized.
*
* These statics are guarded by the mutex in the caller of
* TclRememberThreadData, e.g., TclpThreadDataKeyInit
*/
typedef struct {
int num; /* Number of objects remembered */
int max; /* Max size of the array */
char **list; /* List of pointers */
} SyncObjRecord;
static SyncObjRecord keyRecord = {0, 0, NULL};
static SyncObjRecord mutexRecord = {0, 0, NULL};
static SyncObjRecord condRecord = {0, 0, NULL};
/*
* Prototypes of functions used only in this file
*/
static void RememberSyncObject _ANSI_ARGS_((char *objPtr,
SyncObjRecord *recPtr));
static void ForgetSyncObject _ANSI_ARGS_((char *objPtr,
SyncObjRecord *recPtr));
/*
* Several functions are #defined to nothing in tcl.h if TCL_THREADS is not
* specified. Here we undo that so the procedures are defined in the
* stubs table.
*/
#ifndef TCL_THREADS
#undef Tcl_MutexLock
#undef Tcl_MutexUnlock
#undef Tcl_MutexFinalize
#undef Tcl_ConditionNotify
#undef Tcl_ConditionWait
#undef Tcl_ConditionFinalize
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_GetThreadData --
*
* This procedure allocates and initializes a chunk of thread
* local storage.
*
* Results:
* A thread-specific pointer to the data structure.
*
* Side effects:
* Will allocate memory the first time this thread calls for
* this chunk of storage.
*
*----------------------------------------------------------------------
*/
VOID *
Tcl_GetThreadData(keyPtr, size)
Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk */
int size; /* Size of storage block */
{
VOID *result;
#ifdef TCL_THREADS
/*
* See if this is the first thread to init this key.
*/
if (*keyPtr == NULL) {
TclpThreadDataKeyInit(keyPtr);
}
/*
* Initialize the key for this thread.
*/
result = TclpThreadDataKeyGet(keyPtr);
if (result == NULL) {
result = (VOID *)ckalloc((size_t)size);
memset(result, 0, (size_t)size);
TclpThreadDataKeySet(keyPtr, result);
}
#else
if (*keyPtr == NULL) {
result = (VOID *)ckalloc((size_t)size);
memset((char *)result, 0, (size_t)size);
*keyPtr = (Tcl_ThreadDataKey)result;
TclRememberDataKey(keyPtr);
}
result = *(VOID **)keyPtr;
#endif
return result;
}
/*
*----------------------------------------------------------------------
*
* TclThreadDataKeyGet --
*
* This procedure returns a pointer to a block of thread local storage.
*
* Results:
* A thread-specific pointer to the data structure, or NULL
* if the memory has not been assigned to this key for this thread.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
VOID *
TclThreadDataKeyGet(keyPtr)
Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
* really (pthread_key_t **) */
{
#ifdef TCL_THREADS
return (VOID *)TclpThreadDataKeyGet(keyPtr);
#else
char *result = *(char **)keyPtr;
return (VOID *)result;
#endif /* TCL_THREADS */
}
/*
*----------------------------------------------------------------------
*
* TclThreadDataKeySet --
*
* This procedure sets a thread local storage pointer.
*
* Results:
* None.
*
* Side effects:
* The assigned value will be returned by TclpThreadDataKeyGet.
*
*----------------------------------------------------------------------
*/
void
TclThreadDataKeySet(keyPtr, data)
Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
* really (pthread_key_t **) */
VOID *data; /* Thread local storage */
{
#ifdef TCL_THREADS
if (*keyPtr == NULL) {
TclpThreadDataKeyInit(keyPtr);
}
TclpThreadDataKeySet(keyPtr, data);
#else
*keyPtr = (Tcl_ThreadDataKey)data;
#endif /* TCL_THREADS */
}
/*
*----------------------------------------------------------------------
*
* RememberSyncObject
*
* Keep a list of (mutexes/condition variable/data key)
* used during finalization.
*
* Assume master lock is held.
*
* Results:
* None.
*
* Side effects:
* Add to the appropriate list.
*
*----------------------------------------------------------------------
*/
static void
RememberSyncObject(objPtr, recPtr)
char *objPtr; /* Pointer to sync object */
SyncObjRecord *recPtr; /* Record of sync objects */
{
char **newList;
int i, j;
/*
* Reuse any free slot in the list.
*/
for (i=0 ; i < recPtr->num ; ++i) {
if (recPtr->list[i] == NULL) {
recPtr->list[i] = objPtr;
return;
}
}
/*
* Grow the list of pointers if necessary, copying only non-NULL
* pointers to the new list.
*/
if (recPtr->num >= recPtr->max) {
recPtr->max += 8;
newList = (char **)ckalloc(recPtr->max * sizeof(char *));
for (i=0, j=0 ; i < recPtr->num ; i++) {
if (recPtr->list[i] != NULL) {
newList[j++] = recPtr->list[i];
}
}
if (recPtr->list != NULL) {
ckfree((char *)recPtr->list);
}
recPtr->list = newList;
recPtr->num = j;
}
recPtr->list[recPtr->num] = objPtr;
recPtr->num++;
}
/*
*----------------------------------------------------------------------
*
* ForgetSyncObject
*
* Remove a single object from the list.
* Assume master lock is held.
*
* Results:
* None.
*
* Side effects:
* Remove from the appropriate list.
*
*----------------------------------------------------------------------
*/
static void
ForgetSyncObject(objPtr, recPtr)
char *objPtr; /* Pointer to sync object */
SyncObjRecord *recPtr; /* Record of sync objects */
{
int i;
for (i=0 ; inum ; i++) {
if (objPtr == recPtr->list[i]) {
recPtr->list[i] = NULL;
return;
}
}
}
/*
*----------------------------------------------------------------------
*
* TclRememberMutex
*
* Keep a list of mutexes used during finalization.
* Assume master lock is held.
*
* Results:
* None.
*
* Side effects:
* Add to the mutex list.
*
*----------------------------------------------------------------------
*/
void
TclRememberMutex(mutexPtr)
Tcl_Mutex *mutexPtr;
{
RememberSyncObject((char *)mutexPtr, &mutexRecord);
}
/*
*----------------------------------------------------------------------
*
* Tcl_MutexFinalize
*
* Finalize a single mutex and remove it from the
* list of remembered objects.
*
* Results:
* None.
*
* Side effects:
* Remove the mutex from the list.
*
*----------------------------------------------------------------------
*/
void
Tcl_MutexFinalize(mutexPtr)
Tcl_Mutex *mutexPtr;
{
#ifdef TCL_THREADS
TclpFinalizeMutex(mutexPtr);
#endif
TclpMasterLock();
ForgetSyncObject((char *)mutexPtr, &mutexRecord);
TclpMasterUnlock();
}
/*
*----------------------------------------------------------------------
*
* TclRememberDataKey
*
* Keep a list of thread data keys used during finalization.
* Assume master lock is held.
*
* Results:
* None.
*
* Side effects:
* Add to the key list.
*
*----------------------------------------------------------------------
*/
void
TclRememberDataKey(keyPtr)
Tcl_ThreadDataKey *keyPtr;
{
RememberSyncObject((char *)keyPtr, &keyRecord);
}
/*
*----------------------------------------------------------------------
*
* TclRememberCondition
*
* Keep a list of condition variables used during finalization.
* Assume master lock is held.
*
* Results:
* None.
*
* Side effects:
* Add to the condition variable list.
*
*----------------------------------------------------------------------
*/
void
TclRememberCondition(condPtr)
Tcl_Condition *condPtr;
{
RememberSyncObject((char *)condPtr, &condRecord);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConditionFinalize
*
* Finalize a single condition variable and remove it from the
* list of remembered objects.
*
* Results:
* None.
*
* Side effects:
* Remove the condition variable from the list.
*
*----------------------------------------------------------------------
*/
void
Tcl_ConditionFinalize(condPtr)
Tcl_Condition *condPtr;
{
#ifdef TCL_THREADS
TclpFinalizeCondition(condPtr);
#endif
TclpMasterLock();
ForgetSyncObject((char *)condPtr, &condRecord);
TclpMasterUnlock();
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeThreadData --
*
* This procedure cleans up the thread-local storage. This is
* called once for each thread.
*
* Results:
* None.
*
* Side effects:
* Frees up all thread local storage.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadData()
{
int i;
Tcl_ThreadDataKey *keyPtr;
TclpMasterLock();
for (i=0 ; itclAccessDeleteProc) /* 1 */
#endif
#ifndef TclAccessInsertProc
#define TclAccessInsertProc \
(tclIntStubsPtr->tclAccessInsertProc) /* 2 */
#endif
#ifndef TclAllocateFreeObjects
#define TclAllocateFreeObjects \
(tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */
#endif
/* Slot 4 is reserved */
#ifndef TclCleanupChildren
#define TclCleanupChildren \
(tclIntStubsPtr->tclCleanupChildren) /* 5 */
#endif
#ifndef TclCleanupCommand
#define TclCleanupCommand \
(tclIntStubsPtr->tclCleanupCommand) /* 6 */
#endif
#ifndef TclCopyAndCollapse
#define TclCopyAndCollapse \
(tclIntStubsPtr->tclCopyAndCollapse) /* 7 */
#endif
#ifndef TclCopyChannel
#define TclCopyChannel \
(tclIntStubsPtr->tclCopyChannel) /* 8 */
#endif
#ifndef TclCreatePipeline
#define TclCreatePipeline \
(tclIntStubsPtr->tclCreatePipeline) /* 9 */
#endif
#ifndef TclCreateProc
#define TclCreateProc \
(tclIntStubsPtr->tclCreateProc) /* 10 */
#endif
#ifndef TclDeleteCompiledLocalVars
#define TclDeleteCompiledLocalVars \
(tclIntStubsPtr->tclDeleteCompiledLocalVars) /* 11 */
#endif
#ifndef TclDeleteVars
#define TclDeleteVars \
(tclIntStubsPtr->tclDeleteVars) /* 12 */
#endif
#ifndef TclDoGlob
#define TclDoGlob \
(tclIntStubsPtr->tclDoGlob) /* 13 */
#endif
#ifndef TclDumpMemoryInfo
#define TclDumpMemoryInfo \
(tclIntStubsPtr->tclDumpMemoryInfo) /* 14 */
#endif
/* Slot 15 is reserved */
#ifndef TclExprFloatError
#define TclExprFloatError \
(tclIntStubsPtr->tclExprFloatError) /* 16 */
#endif
/* Slot 17 is reserved */
/* Slot 18 is reserved */
/* Slot 19 is reserved */
/* Slot 20 is reserved */
/* Slot 21 is reserved */
#ifndef TclFindElement
#define TclFindElement \
(tclIntStubsPtr->tclFindElement) /* 22 */
#endif
#ifndef TclFindProc
#define TclFindProc \
(tclIntStubsPtr->tclFindProc) /* 23 */
#endif
#ifndef TclFormatInt
#define TclFormatInt \
(tclIntStubsPtr->tclFormatInt) /* 24 */
#endif
#ifndef TclFreePackageInfo
#define TclFreePackageInfo \
(tclIntStubsPtr->tclFreePackageInfo) /* 25 */
#endif
/* Slot 26 is reserved */
#ifndef TclGetDate
#define TclGetDate \
(tclIntStubsPtr->tclGetDate) /* 27 */
#endif
#ifndef TclpGetDefaultStdChannel
#define TclpGetDefaultStdChannel \
(tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */
#endif
/* Slot 29 is reserved */
/* Slot 30 is reserved */
#ifndef TclGetExtension
#define TclGetExtension \
(tclIntStubsPtr->tclGetExtension) /* 31 */
#endif
#ifndef TclGetFrame
#define TclGetFrame \
(tclIntStubsPtr->tclGetFrame) /* 32 */
#endif
#ifndef TclGetInterpProc
#define TclGetInterpProc \
(tclIntStubsPtr->tclGetInterpProc) /* 33 */
#endif
#ifndef TclGetIntForIndex
#define TclGetIntForIndex \
(tclIntStubsPtr->tclGetIntForIndex) /* 34 */
#endif
/* Slot 35 is reserved */
#ifndef TclGetLong
#define TclGetLong \
(tclIntStubsPtr->tclGetLong) /* 36 */
#endif
#ifndef TclGetLoadedPackages
#define TclGetLoadedPackages \
(tclIntStubsPtr->tclGetLoadedPackages) /* 37 */
#endif
#ifndef TclGetNamespaceForQualName
#define TclGetNamespaceForQualName \
(tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */
#endif
#ifndef TclGetObjInterpProc
#define TclGetObjInterpProc \
(tclIntStubsPtr->tclGetObjInterpProc) /* 39 */
#endif
#ifndef TclGetOpenMode
#define TclGetOpenMode \
(tclIntStubsPtr->tclGetOpenMode) /* 40 */
#endif
#ifndef TclGetOriginalCommand
#define TclGetOriginalCommand \
(tclIntStubsPtr->tclGetOriginalCommand) /* 41 */
#endif
#ifndef TclpGetUserHome
#define TclpGetUserHome \
(tclIntStubsPtr->tclpGetUserHome) /* 42 */
#endif
#ifndef TclGlobalInvoke
#define TclGlobalInvoke \
(tclIntStubsPtr->tclGlobalInvoke) /* 43 */
#endif
#ifndef TclGuessPackageName
#define TclGuessPackageName \
(tclIntStubsPtr->tclGuessPackageName) /* 44 */
#endif
#ifndef TclHideUnsafeCommands
#define TclHideUnsafeCommands \
(tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */
#endif
#ifndef TclInExit
#define TclInExit \
(tclIntStubsPtr->tclInExit) /* 46 */
#endif
/* Slot 47 is reserved */
/* Slot 48 is reserved */
#ifndef TclIncrVar2
#define TclIncrVar2 \
(tclIntStubsPtr->tclIncrVar2) /* 49 */
#endif
#ifndef TclInitCompiledLocals
#define TclInitCompiledLocals \
(tclIntStubsPtr->tclInitCompiledLocals) /* 50 */
#endif
#ifndef TclInterpInit
#define TclInterpInit \
(tclIntStubsPtr->tclInterpInit) /* 51 */
#endif
#ifndef TclInvoke
#define TclInvoke \
(tclIntStubsPtr->tclInvoke) /* 52 */
#endif
#ifndef TclInvokeObjectCommand
#define TclInvokeObjectCommand \
(tclIntStubsPtr->tclInvokeObjectCommand) /* 53 */
#endif
#ifndef TclInvokeStringCommand
#define TclInvokeStringCommand \
(tclIntStubsPtr->tclInvokeStringCommand) /* 54 */
#endif
#ifndef TclIsProc
#define TclIsProc \
(tclIntStubsPtr->tclIsProc) /* 55 */
#endif
/* Slot 56 is reserved */
/* Slot 57 is reserved */
#ifndef TclLookupVar
#define TclLookupVar \
(tclIntStubsPtr->tclLookupVar) /* 58 */
#endif
/* Slot 59 is reserved */
#ifndef TclNeedSpace
#define TclNeedSpace \
(tclIntStubsPtr->tclNeedSpace) /* 60 */
#endif
#ifndef TclNewProcBodyObj
#define TclNewProcBodyObj \
(tclIntStubsPtr->tclNewProcBodyObj) /* 61 */
#endif
#ifndef TclObjCommandComplete
#define TclObjCommandComplete \
(tclIntStubsPtr->tclObjCommandComplete) /* 62 */
#endif
#ifndef TclObjInterpProc
#define TclObjInterpProc \
(tclIntStubsPtr->tclObjInterpProc) /* 63 */
#endif
#ifndef TclObjInvoke
#define TclObjInvoke \
(tclIntStubsPtr->tclObjInvoke) /* 64 */
#endif
#ifndef TclObjInvokeGlobal
#define TclObjInvokeGlobal \
(tclIntStubsPtr->tclObjInvokeGlobal) /* 65 */
#endif
#ifndef TclOpenFileChannelDeleteProc
#define TclOpenFileChannelDeleteProc \
(tclIntStubsPtr->tclOpenFileChannelDeleteProc) /* 66 */
#endif
#ifndef TclOpenFileChannelInsertProc
#define TclOpenFileChannelInsertProc \
(tclIntStubsPtr->tclOpenFileChannelInsertProc) /* 67 */
#endif
/* Slot 68 is reserved */
#ifndef TclpAlloc
#define TclpAlloc \
(tclIntStubsPtr->tclpAlloc) /* 69 */
#endif
/* Slot 70 is reserved */
/* Slot 71 is reserved */
/* Slot 72 is reserved */
/* Slot 73 is reserved */
#ifndef TclpFree
#define TclpFree \
(tclIntStubsPtr->tclpFree) /* 74 */
#endif
#ifndef TclpGetClicks
#define TclpGetClicks \
(tclIntStubsPtr->tclpGetClicks) /* 75 */
#endif
#ifndef TclpGetSeconds
#define TclpGetSeconds \
(tclIntStubsPtr->tclpGetSeconds) /* 76 */
#endif
#ifndef TclpGetTime
#define TclpGetTime \
(tclIntStubsPtr->tclpGetTime) /* 77 */
#endif
#ifndef TclpGetTimeZone
#define TclpGetTimeZone \
(tclIntStubsPtr->tclpGetTimeZone) /* 78 */
#endif
/* Slot 79 is reserved */
/* Slot 80 is reserved */
#ifndef TclpRealloc
#define TclpRealloc \
(tclIntStubsPtr->tclpRealloc) /* 81 */
#endif
/* Slot 82 is reserved */
/* Slot 83 is reserved */
/* Slot 84 is reserved */
/* Slot 85 is reserved */
/* Slot 86 is reserved */
/* Slot 87 is reserved */
#ifndef TclPrecTraceProc
#define TclPrecTraceProc \
(tclIntStubsPtr->tclPrecTraceProc) /* 88 */
#endif
#ifndef TclPreventAliasLoop
#define TclPreventAliasLoop \
(tclIntStubsPtr->tclPreventAliasLoop) /* 89 */
#endif
/* Slot 90 is reserved */
#ifndef TclProcCleanupProc
#define TclProcCleanupProc \
(tclIntStubsPtr->tclProcCleanupProc) /* 91 */
#endif
#ifndef TclProcCompileProc
#define TclProcCompileProc \
(tclIntStubsPtr->tclProcCompileProc) /* 92 */
#endif
#ifndef TclProcDeleteProc
#define TclProcDeleteProc \
(tclIntStubsPtr->tclProcDeleteProc) /* 93 */
#endif
#ifndef TclProcInterpProc
#define TclProcInterpProc \
(tclIntStubsPtr->tclProcInterpProc) /* 94 */
#endif
/* Slot 95 is reserved */
#ifndef TclRenameCommand
#define TclRenameCommand \
(tclIntStubsPtr->tclRenameCommand) /* 96 */
#endif
#ifndef TclResetShadowedCmdRefs
#define TclResetShadowedCmdRefs \
(tclIntStubsPtr->tclResetShadowedCmdRefs) /* 97 */
#endif
#ifndef TclServiceIdle
#define TclServiceIdle \
(tclIntStubsPtr->tclServiceIdle) /* 98 */
#endif
/* Slot 99 is reserved */
/* Slot 100 is reserved */
#ifndef TclSetPreInitScript
#define TclSetPreInitScript \
(tclIntStubsPtr->tclSetPreInitScript) /* 101 */
#endif
#ifndef TclSetupEnv
#define TclSetupEnv \
(tclIntStubsPtr->tclSetupEnv) /* 102 */
#endif
#ifndef TclSockGetPort
#define TclSockGetPort \
(tclIntStubsPtr->tclSockGetPort) /* 103 */
#endif
#ifndef TclSockMinimumBuffersOld
#define TclSockMinimumBuffersOld \
(tclIntStubsPtr->tclSockMinimumBuffersOld) /* 104 */
#endif
/* Slot 105 is reserved */
#ifndef TclStatDeleteProc
#define TclStatDeleteProc \
(tclIntStubsPtr->tclStatDeleteProc) /* 106 */
#endif
#ifndef TclStatInsertProc
#define TclStatInsertProc \
(tclIntStubsPtr->tclStatInsertProc) /* 107 */
#endif
#ifndef TclTeardownNamespace
#define TclTeardownNamespace \
(tclIntStubsPtr->tclTeardownNamespace) /* 108 */
#endif
#ifndef TclUpdateReturnInfo
#define TclUpdateReturnInfo \
(tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */
#endif
#ifndef TclSockMinimumBuffers
#define TclSockMinimumBuffers \
(tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */
#endif
#ifndef Tcl_AddInterpResolvers
#define Tcl_AddInterpResolvers \
(tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */
#endif
#ifndef Tcl_AppendExportList
#define Tcl_AppendExportList \
(tclIntStubsPtr->tcl_AppendExportList) /* 112 */
#endif
#ifndef Tcl_CreateNamespace
#define Tcl_CreateNamespace \
(tclIntStubsPtr->tcl_CreateNamespace) /* 113 */
#endif
#ifndef Tcl_DeleteNamespace
#define Tcl_DeleteNamespace \
(tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */
#endif
#ifndef Tcl_Export
#define Tcl_Export \
(tclIntStubsPtr->tcl_Export) /* 115 */
#endif
#ifndef Tcl_FindCommand
#define Tcl_FindCommand \
(tclIntStubsPtr->tcl_FindCommand) /* 116 */
#endif
#ifndef Tcl_FindNamespace
#define Tcl_FindNamespace \
(tclIntStubsPtr->tcl_FindNamespace) /* 117 */
#endif
#ifndef Tcl_GetInterpResolvers
#define Tcl_GetInterpResolvers \
(tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */
#endif
#ifndef Tcl_GetNamespaceResolvers
#define Tcl_GetNamespaceResolvers \
(tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */
#endif
#ifndef Tcl_FindNamespaceVar
#define Tcl_FindNamespaceVar \
(tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */
#endif
#ifndef Tcl_ForgetImport
#define Tcl_ForgetImport \
(tclIntStubsPtr->tcl_ForgetImport) /* 121 */
#endif
#ifndef Tcl_GetCommandFromObj
#define Tcl_GetCommandFromObj \
(tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */
#endif
#ifndef Tcl_GetCommandFullName
#define Tcl_GetCommandFullName \
(tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */
#endif
#ifndef Tcl_GetCurrentNamespace
#define Tcl_GetCurrentNamespace \
(tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */
#endif
#ifndef Tcl_GetGlobalNamespace
#define Tcl_GetGlobalNamespace \
(tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */
#endif
#ifndef Tcl_GetVariableFullName
#define Tcl_GetVariableFullName \
(tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */
#endif
#ifndef Tcl_Import
#define Tcl_Import \
(tclIntStubsPtr->tcl_Import) /* 127 */
#endif
#ifndef Tcl_PopCallFrame
#define Tcl_PopCallFrame \
(tclIntStubsPtr->tcl_PopCallFrame) /* 128 */
#endif
#ifndef Tcl_PushCallFrame
#define Tcl_PushCallFrame \
(tclIntStubsPtr->tcl_PushCallFrame) /* 129 */
#endif
#ifndef Tcl_RemoveInterpResolvers
#define Tcl_RemoveInterpResolvers \
(tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */
#endif
#ifndef Tcl_SetNamespaceResolvers
#define Tcl_SetNamespaceResolvers \
(tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */
#endif
#ifndef TclpHasSockets
#define TclpHasSockets \
(tclIntStubsPtr->tclpHasSockets) /* 132 */
#endif
#ifndef TclpGetDate
#define TclpGetDate \
(tclIntStubsPtr->tclpGetDate) /* 133 */
#endif
#ifndef TclpStrftime
#define TclpStrftime \
(tclIntStubsPtr->tclpStrftime) /* 134 */
#endif
#ifndef TclpCheckStackSpace
#define TclpCheckStackSpace \
(tclIntStubsPtr->tclpCheckStackSpace) /* 135 */
#endif
/* Slot 136 is reserved */
/* Slot 137 is reserved */
#ifndef TclGetEnv
#define TclGetEnv \
(tclIntStubsPtr->tclGetEnv) /* 138 */
#endif
/* Slot 139 is reserved */
#ifndef TclLooksLikeInt
#define TclLooksLikeInt \
(tclIntStubsPtr->tclLooksLikeInt) /* 140 */
#endif
#ifndef TclpGetCwd
#define TclpGetCwd \
(tclIntStubsPtr->tclpGetCwd) /* 141 */
#endif
#ifndef TclSetByteCodeFromAny
#define TclSetByteCodeFromAny \
(tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */
#endif
#ifndef TclAddLiteralObj
#define TclAddLiteralObj \
(tclIntStubsPtr->tclAddLiteralObj) /* 143 */
#endif
#ifndef TclHideLiteral
#define TclHideLiteral \
(tclIntStubsPtr->tclHideLiteral) /* 144 */
#endif
#ifndef TclGetAuxDataType
#define TclGetAuxDataType \
(tclIntStubsPtr->tclGetAuxDataType) /* 145 */
#endif
#ifndef TclHandleCreate
#define TclHandleCreate \
(tclIntStubsPtr->tclHandleCreate) /* 146 */
#endif
#ifndef TclHandleFree
#define TclHandleFree \
(tclIntStubsPtr->tclHandleFree) /* 147 */
#endif
#ifndef TclHandlePreserve
#define TclHandlePreserve \
(tclIntStubsPtr->tclHandlePreserve) /* 148 */
#endif
#ifndef TclHandleRelease
#define TclHandleRelease \
(tclIntStubsPtr->tclHandleRelease) /* 149 */
#endif
#ifndef TclRegAbout
#define TclRegAbout \
(tclIntStubsPtr->tclRegAbout) /* 150 */
#endif
#ifndef TclRegExpRangeUniChar
#define TclRegExpRangeUniChar \
(tclIntStubsPtr->tclRegExpRangeUniChar) /* 151 */
#endif
#ifndef TclSetLibraryPath
#define TclSetLibraryPath \
(tclIntStubsPtr->tclSetLibraryPath) /* 152 */
#endif
#ifndef TclGetLibraryPath
#define TclGetLibraryPath \
(tclIntStubsPtr->tclGetLibraryPath) /* 153 */
#endif
/* Slot 154 is reserved */
/* Slot 155 is reserved */
#ifndef TclRegError
#define TclRegError \
(tclIntStubsPtr->tclRegError) /* 156 */
#endif
#ifndef TclVarTraceExists
#define TclVarTraceExists \
(tclIntStubsPtr->tclVarTraceExists) /* 157 */
#endif
#ifndef TclSetStartupScriptFileName
#define TclSetStartupScriptFileName \
(tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */
#endif
#ifndef TclGetStartupScriptFileName
#define TclGetStartupScriptFileName \
(tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */
#endif
/* Slot 160 is reserved */
#ifndef TclChannelTransform
#define TclChannelTransform \
(tclIntStubsPtr->tclChannelTransform) /* 161 */
#endif
#ifndef TclChannelEventScriptInvoker
#define TclChannelEventScriptInvoker \
(tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */
#endif
#ifndef TclGetInstructionTable
#define TclGetInstructionTable \
(tclIntStubsPtr->tclGetInstructionTable) /* 163 */
#endif
#ifndef TclExpandCodeArray
#define TclExpandCodeArray \
(tclIntStubsPtr->tclExpandCodeArray) /* 164 */
#endif
#ifndef TclpSetInitialEncodings
#define TclpSetInitialEncodings \
(tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */
#endif
#ifndef TclListObjSetElement
#define TclListObjSetElement \
(tclIntStubsPtr->tclListObjSetElement) /* 166 */
#endif
#ifndef TclSetStartupScriptPath
#define TclSetStartupScriptPath \
(tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */
#endif
#ifndef TclGetStartupScriptPath
#define TclGetStartupScriptPath \
(tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */
#endif
#ifndef TclpUtfNcmp2
#define TclpUtfNcmp2 \
(tclIntStubsPtr->tclpUtfNcmp2) /* 169 */
#endif
#ifndef TclCheckInterpTraces
#define TclCheckInterpTraces \
(tclIntStubsPtr->tclCheckInterpTraces) /* 170 */
#endif
#ifndef TclCheckExecutionTraces
#define TclCheckExecutionTraces \
(tclIntStubsPtr->tclCheckExecutionTraces) /* 171 */
#endif
#ifndef TclInThreadExit
#define TclInThreadExit \
(tclIntStubsPtr->tclInThreadExit) /* 172 */
#endif
#ifndef TclUniCharMatch
#define TclUniCharMatch \
(tclIntStubsPtr->tclUniCharMatch) /* 173 */
#endif
/* Slot 174 is reserved */
/* Slot 175 is reserved */
/* Slot 176 is reserved */
/* Slot 177 is reserved */
/* Slot 178 is reserved */
/* Slot 179 is reserved */
/* Slot 180 is reserved */
/* Slot 181 is reserved */
#ifndef TclpLocaltime
#define TclpLocaltime \
(tclIntStubsPtr->tclpLocaltime) /* 182 */
#endif
#ifndef TclpGmtime
#define TclpGmtime \
(tclIntStubsPtr->tclpGmtime) /* 183 */
#endif
/* Slot 184 is reserved */
/* Slot 185 is reserved */
/* Slot 186 is reserved */
/* Slot 187 is reserved */
/* Slot 188 is reserved */
/* Slot 189 is reserved */
/* Slot 190 is reserved */
/* Slot 191 is reserved */
/* Slot 192 is reserved */
/* Slot 193 is reserved */
/* Slot 194 is reserved */
/* Slot 195 is reserved */
/* Slot 196 is reserved */
/* Slot 197 is reserved */
/* Slot 198 is reserved */
#ifndef TclMatchIsTrivial
#define TclMatchIsTrivial \
(tclIntStubsPtr->tclMatchIsTrivial) /* 199 */
#endif
/* Slot 200 is reserved */
/* Slot 201 is reserved */
/* Slot 202 is reserved */
/* Slot 203 is reserved */
/* Slot 204 is reserved */
/* Slot 205 is reserved */
/* Slot 206 is reserved */
/* Slot 207 is reserved */
/* Slot 208 is reserved */
/* Slot 209 is reserved */
/* Slot 210 is reserved */
/* Slot 211 is reserved */
/* Slot 212 is reserved */
/* Slot 213 is reserved */
/* Slot 214 is reserved */
/* Slot 215 is reserved */
/* Slot 216 is reserved */
/* Slot 217 is reserved */
/* Slot 218 is reserved */
/* Slot 219 is reserved */
/* Slot 220 is reserved */
/* Slot 221 is reserved */
/* Slot 222 is reserved */
/* Slot 223 is reserved */
/* Slot 224 is reserved */
/* Slot 225 is reserved */
/* Slot 226 is reserved */
/* Slot 227 is reserved */
/* Slot 228 is reserved */
/* Slot 229 is reserved */
/* Slot 230 is reserved */
/* Slot 231 is reserved */
/* Slot 232 is reserved */
/* Slot 233 is reserved */
/* Slot 234 is reserved */
/* Slot 235 is reserved */
/* Slot 236 is reserved */
/* Slot 237 is reserved */
/* Slot 238 is reserved */
/* Slot 239 is reserved */
/* Slot 240 is reserved */
/* Slot 241 is reserved */
/* Slot 242 is reserved */
/* Slot 243 is reserved */
/* Slot 244 is reserved */
/* Slot 245 is reserved */
/* Slot 246 is reserved */
/* Slot 247 is reserved */
/* Slot 248 is reserved */
#ifndef TclUnusedStubEntry
#define TclUnusedStubEntry \
(tclIntStubsPtr->tclUnusedStubEntry) /* 249 */
#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
/* !END!: Do not edit above this line. */
#if !defined(_WIN64)
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
# undef TclSockMinimumBuffers
# define TclSockMinimumBuffers(a,b) TclSockMinimumBuffersOld((int)(a),b)
#endif
#undef TclUnusedStubEntry
#endif /* _TCLINTDECLS */
tcl8.4.20/generic/tclAsync.c 0000644 0036047 0045461 00000023415 11737050674 014264 0 ustar dgp 771div /*
* tclAsync.c --
*
* This file provides low-level support needed to invoke signal
* handlers in a safe way. The code here doesn't actually handle
* signals, though. This code is based on proposals made by
* Mark Diekhans and Don Libes.
*
* Copyright (c) 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.
*/
#include "tclInt.h"
#include "tclPort.h"
/* Forward declaration */
struct ThreadSpecificData;
/*
* One of the following structures exists for each asynchronous
* handler:
*/
typedef struct AsyncHandler {
int ready; /* Non-zero means this handler should
* be invoked in the next call to
* Tcl_AsyncInvoke. */
struct AsyncHandler *nextPtr; /* Next in list of all handlers for
* the process. */
Tcl_AsyncProc *proc; /* Procedure to call when handler
* is invoked. */
ClientData clientData; /* Value to pass to handler when it
* is invoked. */
struct ThreadSpecificData *originTsd;
/* Used in Tcl_AsyncMark to modify thread-
* specific data from outside the thread
* it is associated to. */
Tcl_ThreadId originThrdId; /* Origin thread where this token was
* created and where it will be
* yielded. */
} AsyncHandler;
typedef struct ThreadSpecificData {
/*
* The variables below maintain a list of all existing handlers
* specific to the calling thread.
*/
AsyncHandler *firstHandler; /* First handler defined for process,
* or NULL if none. */
AsyncHandler *lastHandler; /* Last handler or NULL. */
/*
* The variable below is set to 1 whenever a handler becomes ready and
* it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be
* checked elsewhere in the application by calling Tcl_AsyncReady to see
* if Tcl_AsyncInvoke should be invoked.
*/
int asyncReady;
/*
* The variable below indicates whether Tcl_AsyncInvoke is currently
* working. If so then we won't set asyncReady again until
* Tcl_AsyncInvoke returns.
*/
int asyncActive;
Tcl_Mutex asyncMutex; /* Thread-specific AsyncHandler linked-list lock */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
*----------------------------------------------------------------------
*
* TclFinalizeAsync --
*
* Finalizes the mutex in the thread local data structure for the
* async subsystem.
*
* Results:
* None.
*
* Side effects:
* Forgets knowledge of the mutex should it have been created.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeAsync()
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->asyncMutex != NULL) {
Tcl_MutexFinalize(&tsdPtr->asyncMutex);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_AsyncCreate --
*
* This procedure creates the data structures for an asynchronous
* handler, so that no memory has to be allocated when the handler
* is activated.
*
* Results:
* The return value is a token for the handler, which can be used
* to activate it later on.
*
* Side effects:
* Information about the handler is recorded.
*
*----------------------------------------------------------------------
*/
Tcl_AsyncHandler
Tcl_AsyncCreate(proc, clientData)
Tcl_AsyncProc *proc; /* Procedure to call when handler
* is invoked. */
ClientData clientData; /* Argument to pass to handler. */
{
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler));
asyncPtr->ready = 0;
asyncPtr->nextPtr = NULL;
asyncPtr->proc = proc;
asyncPtr->clientData = clientData;
asyncPtr->originTsd = tsdPtr;
asyncPtr->originThrdId = Tcl_GetCurrentThread();
Tcl_MutexLock(&tsdPtr->asyncMutex);
if (tsdPtr->firstHandler == NULL) {
tsdPtr->firstHandler = asyncPtr;
} else {
tsdPtr->lastHandler->nextPtr = asyncPtr;
}
tsdPtr->lastHandler = asyncPtr;
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
return (Tcl_AsyncHandler) asyncPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AsyncMark --
*
* This procedure is called to request that an asynchronous handler
* be invoked as soon as possible. It's typically called from
* an interrupt handler, where it isn't safe to do anything that
* depends on or modifies application state.
*
* Results:
* None.
*
* Side effects:
* The handler gets marked for invocation later.
*
*----------------------------------------------------------------------
*/
void
Tcl_AsyncMark(async)
Tcl_AsyncHandler async; /* Token for handler. */
{
AsyncHandler *token = (AsyncHandler *) async;
Tcl_MutexLock(&token->originTsd->asyncMutex);
token->ready = 1;
if (!token->originTsd->asyncActive) {
token->originTsd->asyncReady = 1;
Tcl_ThreadAlert(token->originThrdId);
}
Tcl_MutexUnlock(&token->originTsd->asyncMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AsyncInvoke --
*
* This procedure is called at a "safe" time at background level
* to invoke any active asynchronous handlers.
*
* Results:
* The return value is a normal Tcl result, which is intended to
* replace the code argument as the current completion code for
* interp.
*
* Side effects:
* Depends on the handlers that are active.
*
*----------------------------------------------------------------------
*/
int
Tcl_AsyncInvoke(interp, code)
Tcl_Interp *interp; /* If invoked from Tcl_Eval just after
* completing a command, points to
* interpreter. Otherwise it is
* NULL. */
int code; /* If interp is non-NULL, this gives
* completion code from command that
* just completed. */
{
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_MutexLock(&tsdPtr->asyncMutex);
if (tsdPtr->asyncReady == 0) {
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
return code;
}
tsdPtr->asyncReady = 0;
tsdPtr->asyncActive = 1;
if (interp == NULL) {
code = 0;
}
/*
* Make one or more passes over the list of handlers, invoking
* at most one handler in each pass. After invoking a handler,
* go back to the start of the list again so that (a) if a new
* higher-priority handler gets marked while executing a lower
* priority handler, we execute the higher-priority handler
* next, and (b) if a handler gets deleted during the execution
* of a handler, then the list structure may change so it isn't
* safe to continue down the list anyway.
*/
while (1) {
for (asyncPtr = tsdPtr->firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->ready) {
break;
}
}
if (asyncPtr == NULL) {
break;
}
asyncPtr->ready = 0;
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code);
Tcl_MutexLock(&tsdPtr->asyncMutex);
}
tsdPtr->asyncActive = 0;
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AsyncDelete --
*
* Frees up all the state for an asynchronous handler. The handler
* should never be used again.
*
* Results:
* None.
*
* Side effects:
* The state associated with the handler is deleted.
*
* Failure to locate the handler in current thread private list
* of async handlers will result in panic; exception: the list
* is already empty (potential trouble?).
* Consequently, threads should create and delete handlers
* themselves. I.e. a handler created by one should not be
* deleted by some other thread.
*
*----------------------------------------------------------------------
*/
void
Tcl_AsyncDelete(async)
Tcl_AsyncHandler async; /* Token for handler to delete. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
AsyncHandler *asyncPtr = (AsyncHandler *) async;
AsyncHandler *prevPtr, *thisPtr;
/*
* Assure early handling of the constraint
*/
if (asyncPtr->originThrdId != Tcl_GetCurrentThread()) {
panic("Tcl_AsyncDelete: async handler deleted by the wrong thread");
}
/*
* If we come to this point when TSD's for the current
* thread have already been garbage-collected, we are
* in the _serious_ trouble. OTOH, we tolerate calling
* with already cleaned-up handler list (should we?).
*/
Tcl_MutexLock(&tsdPtr->asyncMutex);
if (tsdPtr->firstHandler != NULL) {
prevPtr = thisPtr = tsdPtr->firstHandler;
while (thisPtr != NULL && thisPtr != asyncPtr) {
prevPtr = thisPtr;
thisPtr = thisPtr->nextPtr;
}
if (thisPtr == NULL) {
panic("Tcl_AsyncDelete: cannot find async handler");
}
if (asyncPtr == tsdPtr->firstHandler) {
tsdPtr->firstHandler = asyncPtr->nextPtr;
} else {
prevPtr->nextPtr = asyncPtr->nextPtr;
}
if (asyncPtr == tsdPtr->lastHandler) {
tsdPtr->lastHandler = prevPtr;
}
}
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
ckfree((char *) asyncPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AsyncReady --
*
* This procedure can be used to tell whether Tcl_AsyncInvoke
* needs to be called. This procedure is the external interface
* for checking the thread-specific asyncReady variable.
*
* Results:
* The return value is 1 whenever a handler is ready and is 0
* when no handlers are ready.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_AsyncReady()
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
return tsdPtr->asyncReady;
}
tcl8.4.20/generic/tclCompile.c 0000644 0036047 0045461 00000371423 12133546537 014603 0 ustar dgp 771div /*
* tclCompile.c --
*
* This file contains procedures that compile Tcl commands or parts
* of commands (like quoted strings or nested sub-commands) into a
* sequence of instructions ("bytecodes").
*
* Copyright (c) 1996-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
* Table of all AuxData types.
*/
static Tcl_HashTable auxDataTypeTable;
static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(tableMutex)
/*
* Variable that controls whether compilation tracing is enabled and, if so,
* what level of tracing is desired:
* 0: no compilation tracing
* 1: summarize compilation of top level cmds and proc bodies
* 2: display all instructions of each ByteCode compiled
* This variable is linked to the Tcl variable "tcl_traceCompile".
*/
#ifdef TCL_COMPILE_DEBUG
int tclTraceCompile = 0;
static int traceInitialized = 0;
#endif
/*
* A table describing the Tcl bytecode instructions. Entries in this table
* must correspond to the instruction opcode definitions in tclCompile.h.
* The names "op1" and "op4" refer to an instruction's one or four byte
* first operand. Similarly, "stktop" and "stknext" refer to the topmost
* and next to topmost stack elements.
*
* Note that the load, store, and incr instructions do not distinguish local
* from global variables; the bytecode interpreter at runtime uses the
* existence of a procedure call frame to distinguish these.
*/
InstructionDesc tclInstructionTable[] = {
/* Name Bytes stackEffect #Opnds Operand types Stack top, next */
{"done", 1, -1, 0, {OPERAND_NONE}},
/* Finish ByteCode execution and return stktop (top stack item) */
{"push1", 2, +1, 1, {OPERAND_UINT1}},
/* Push object at ByteCode objArray[op1] */
{"push4", 5, +1, 1, {OPERAND_UINT4}},
/* Push object at ByteCode objArray[op4] */
{"pop", 1, -1, 0, {OPERAND_NONE}},
/* Pop the topmost stack object */
{"dup", 1, +1, 0, {OPERAND_NONE}},
/* Duplicate the topmost stack object and push the result */
{"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}},
/* Concatenate the top op1 items and push result */
{"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}},
/* Invoke command named objv[0]; = */
{"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}},
/* Invoke command named objv[0]; = */
{"evalStk", 1, 0, 0, {OPERAND_NONE}},
/* Evaluate command in stktop using Tcl_EvalObj. */
{"exprStk", 1, 0, 0, {OPERAND_NONE}},
/* Execute expression in stktop using Tcl_ExprStringObj. */
{"loadScalar1", 2, 1, 1, {OPERAND_UINT1}},
/* Load scalar variable at index op1 <= 255 in call frame */
{"loadScalar4", 5, 1, 1, {OPERAND_UINT4}},
/* Load scalar variable at index op1 >= 256 in call frame */
{"loadScalarStk", 1, 0, 0, {OPERAND_NONE}},
/* Load scalar variable; scalar's name is stktop */
{"loadArray1", 2, 0, 1, {OPERAND_UINT1}},
/* Load array element; array at slot op1<=255, element is stktop */
{"loadArray4", 5, 0, 1, {OPERAND_UINT4}},
/* Load array element; array at slot op1 > 255, element is stktop */
{"loadArrayStk", 1, -1, 0, {OPERAND_NONE}},
/* Load array element; element is stktop, array name is stknext */
{"loadStk", 1, 0, 0, {OPERAND_NONE}},
/* Load general variable; unparsed variable name is stktop */
{"storeScalar1", 2, 0, 1, {OPERAND_UINT1}},
/* Store scalar variable at op1<=255 in frame; value is stktop */
{"storeScalar4", 5, 0, 1, {OPERAND_UINT4}},
/* Store scalar variable at op1 > 255 in frame; value is stktop */
{"storeScalarStk", 1, -1, 0, {OPERAND_NONE}},
/* Store scalar; value is stktop, scalar name is stknext */
{"storeArray1", 2, -1, 1, {OPERAND_UINT1}},
/* Store array element; array at op1<=255, value is top then elem */
{"storeArray4", 5, -1, 1, {OPERAND_UINT4}},
/* Store array element; array at op1>=256, value is top then elem */
{"storeArrayStk", 1, -2, 0, {OPERAND_NONE}},
/* Store array element; value is stktop, then elem, array names */
{"storeStk", 1, -1, 0, {OPERAND_NONE}},
/* Store general variable; value is stktop, then unparsed name */
{"incrScalar1", 2, 0, 1, {OPERAND_UINT1}},
/* Incr scalar at index op1<=255 in frame; incr amount is stktop */
{"incrScalarStk", 1, -1, 0, {OPERAND_NONE}},
/* Incr scalar; incr amount is stktop, scalar's name is stknext */
{"incrArray1", 2, -1, 1, {OPERAND_UINT1}},
/* Incr array elem; arr at slot op1<=255, amount is top then elem */
{"incrArrayStk", 1, -2, 0, {OPERAND_NONE}},
/* Incr array element; amount is top then elem then array names */
{"incrStk", 1, -1, 0, {OPERAND_NONE}},
/* Incr general variable; amount is stktop then unparsed var name */
{"incrScalar1Imm", 3, +1, 2, {OPERAND_UINT1, OPERAND_INT1}},
/* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
{"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}},
/* Incr scalar; scalar name is stktop; incr amount is op1 */
{"incrArray1Imm", 3, 0, 2, {OPERAND_UINT1, OPERAND_INT1}},
/* Incr array elem; array at slot op1 <= 255, elem is stktop,
* amount is 2nd operand byte */
{"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}},
/* Incr array element; elem is top then array name, amount is op1 */
{"incrStkImm", 2, 0, 1, {OPERAND_INT1}},
/* Incr general variable; unparsed name is top, amount is op1 */
{"jump1", 2, 0, 1, {OPERAND_INT1}},
/* Jump relative to (pc + op1) */
{"jump4", 5, 0, 1, {OPERAND_INT4}},
/* Jump relative to (pc + op4) */
{"jumpTrue1", 2, -1, 1, {OPERAND_INT1}},
/* Jump relative to (pc + op1) if stktop expr object is true */
{"jumpTrue4", 5, -1, 1, {OPERAND_INT4}},
/* Jump relative to (pc + op4) if stktop expr object is true */
{"jumpFalse1", 2, -1, 1, {OPERAND_INT1}},
/* Jump relative to (pc + op1) if stktop expr object is false */
{"jumpFalse4", 5, -1, 1, {OPERAND_INT4}},
/* Jump relative to (pc + op4) if stktop expr object is false */
{"lor", 1, -1, 0, {OPERAND_NONE}},
/* Logical or: push (stknext || stktop) */
{"land", 1, -1, 0, {OPERAND_NONE}},
/* Logical and: push (stknext && stktop) */
{"bitor", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise or: push (stknext | stktop) */
{"bitxor", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise xor push (stknext ^ stktop) */
{"bitand", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise and: push (stknext & stktop) */
{"eq", 1, -1, 0, {OPERAND_NONE}},
/* Equal: push (stknext == stktop) */
{"neq", 1, -1, 0, {OPERAND_NONE}},
/* Not equal: push (stknext != stktop) */
{"lt", 1, -1, 0, {OPERAND_NONE}},
/* Less: push (stknext < stktop) */
{"gt", 1, -1, 0, {OPERAND_NONE}},
/* Greater: push (stknext || stktop) */
{"le", 1, -1, 0, {OPERAND_NONE}},
/* Logical or: push (stknext || stktop) */
{"ge", 1, -1, 0, {OPERAND_NONE}},
/* Logical or: push (stknext || stktop) */
{"lshift", 1, -1, 0, {OPERAND_NONE}},
/* Left shift: push (stknext << stktop) */
{"rshift", 1, -1, 0, {OPERAND_NONE}},
/* Right shift: push (stknext >> stktop) */
{"add", 1, -1, 0, {OPERAND_NONE}},
/* Add: push (stknext + stktop) */
{"sub", 1, -1, 0, {OPERAND_NONE}},
/* Sub: push (stkext - stktop) */
{"mult", 1, -1, 0, {OPERAND_NONE}},
/* Multiply: push (stknext * stktop) */
{"div", 1, -1, 0, {OPERAND_NONE}},
/* Divide: push (stknext / stktop) */
{"mod", 1, -1, 0, {OPERAND_NONE}},
/* Mod: push (stknext % stktop) */
{"uplus", 1, 0, 0, {OPERAND_NONE}},
/* Unary plus: push +stktop */
{"uminus", 1, 0, 0, {OPERAND_NONE}},
/* Unary minus: push -stktop */
{"bitnot", 1, 0, 0, {OPERAND_NONE}},
/* Bitwise not: push ~stktop */
{"not", 1, 0, 0, {OPERAND_NONE}},
/* Logical not: push !stktop */
{"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}},
/* Call builtin math function with index op1; any args are on stk */
{"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}},
/* Call non-builtin func objv[0]; = */
{"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}},
/* Try converting stktop to first int then double if possible. */
{"break", 1, 0, 0, {OPERAND_NONE}},
/* Abort closest enclosing loop; if none, return TCL_BREAK code. */
{"continue", 1, 0, 0, {OPERAND_NONE}},
/* Skip to next iteration of closest enclosing loop; if none,
* return TCL_CONTINUE code. */
{"foreach_start4", 5, 0, 1, {OPERAND_UINT4}},
/* Initialize execution of a foreach loop. Operand is aux data index
* of the ForeachInfo structure for the foreach command. */
{"foreach_step4", 5, +1, 1, {OPERAND_UINT4}},
/* "Step" or begin next iteration of foreach loop. Push 0 if to
* terminate loop, else push 1. */
{"beginCatch4", 5, 0, 1, {OPERAND_UINT4}},
/* Record start of catch with the operand's exception index.
* Push the current stack depth onto a special catch stack. */
{"endCatch", 1, 0, 0, {OPERAND_NONE}},
/* End of last catch. Pop the bytecode interpreter's catch stack. */
{"pushResult", 1, +1, 0, {OPERAND_NONE}},
/* Push the interpreter's object result onto the stack. */
{"pushReturnCode", 1, +1, 0, {OPERAND_NONE}},
/* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
* a new object onto the stack. */
{"streq", 1, -1, 0, {OPERAND_NONE}},
/* Str Equal: push (stknext eq stktop) */
{"strneq", 1, -1, 0, {OPERAND_NONE}},
/* Str !Equal: push (stknext neq stktop) */
{"strcmp", 1, -1, 0, {OPERAND_NONE}},
/* Str Compare: push (stknext cmp stktop) */
{"strlen", 1, 0, 0, {OPERAND_NONE}},
/* Str Length: push (strlen stktop) */
{"strindex", 1, -1, 0, {OPERAND_NONE}},
/* Str Index: push (strindex stknext stktop) */
{"strmatch", 2, -1, 1, {OPERAND_INT1}},
/* Str Match: push (strmatch stknext stktop) opnd == nocase */
{"list", 5, INT_MIN, 1, {OPERAND_UINT4}},
/* List: push (stk1 stk2 ... stktop) */
{"listindex", 1, -1, 0, {OPERAND_NONE}},
/* List Index: push (listindex stknext stktop) */
{"listlength", 1, 0, 0, {OPERAND_NONE}},
/* List Len: push (listlength stktop) */
{"appendScalar1", 2, 0, 1, {OPERAND_UINT1}},
/* Append scalar variable at op1<=255 in frame; value is stktop */
{"appendScalar4", 5, 0, 1, {OPERAND_UINT4}},
/* Append scalar variable at op1 > 255 in frame; value is stktop */
{"appendArray1", 2, -1, 1, {OPERAND_UINT1}},
/* Append array element; array at op1<=255, value is top then elem */
{"appendArray4", 5, -1, 1, {OPERAND_UINT4}},
/* Append array element; array at op1>=256, value is top then elem */
{"appendArrayStk", 1, -2, 0, {OPERAND_NONE}},
/* Append array element; value is stktop, then elem, array names */
{"appendStk", 1, -1, 0, {OPERAND_NONE}},
/* Append general variable; value is stktop, then unparsed name */
{"lappendScalar1", 2, 0, 1, {OPERAND_UINT1}},
/* Lappend scalar variable at op1<=255 in frame; value is stktop */
{"lappendScalar4", 5, 0, 1, {OPERAND_UINT4}},
/* Lappend scalar variable at op1 > 255 in frame; value is stktop */
{"lappendArray1", 2, -1, 1, {OPERAND_UINT1}},
/* Lappend array element; array at op1<=255, value is top then elem */
{"lappendArray4", 5, -1, 1, {OPERAND_UINT4}},
/* Lappend array element; array at op1>=256, value is top then elem */
{"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}},
/* Lappend array element; value is stktop, then elem, array names */
{"lappendStk", 1, -1, 0, {OPERAND_NONE}},
/* Lappend general variable; value is stktop, then unparsed name */
{"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}},
/* Lindex with generalized args, operand is number of stacked objs
* used: (operand-1) entries from stktop are the indices; then list
* to process. */
{"over", 5, +1, 1, {OPERAND_UINT4}},
/* Duplicate the arg-th element from top of stack (TOS=0) */
{"lsetList", 1, -2, 0, {OPERAND_NONE}},
/* Four-arg version of 'lset'. stktop is old value; next is
* new element value, next is the index list; pushes new value */
{"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}},
/* Three- or >=5-arg version of 'lset', operand is number of
* stacked objs: stktop is old value, next is new element value, next
* come (operand-2) indices; pushes the new value.
*/
{0, 0, 0, 0, {OPERAND_NONE}}
};
/*
* Prototypes for procedures defined later in this file:
*/
static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((
CompileEnv *envPtr, ByteCode *codePtr,
unsigned char *startPtr));
static void EnterCmdExtentData _ANSI_ARGS_((
CompileEnv *envPtr, int cmdNumber,
int numSrcBytes, int numCodeBytes));
static void EnterCmdStartData _ANSI_ARGS_((
CompileEnv *envPtr, int cmdNumber,
int srcOffset, int codeOffset));
static void FreeByteCodeInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
static int GetCmdLocEncodingSize _ANSI_ARGS_((
CompileEnv *envPtr));
static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *script, CONST char *command,
int length));
#ifdef TCL_COMPILE_STATS
static void RecordByteCodeStats _ANSI_ARGS_((
ByteCode *codePtr));
#endif /* TCL_COMPILE_STATS */
static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
#ifdef TCL_TIP280
/* TIP #280 : Helper for building the per-word line information of all
* compiled commands */
static void EnterCmdWordData _ANSI_ARGS_((
ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token* tokenPtr,
CONST char* cmd, int len, int numWords, int line,
int* clNext, int** lines, CompileEnv* envPtr));
static void ReleaseCmdWordData _ANSI_ARGS_((ExtCmdLoc* eclPtr));
#endif
/*
* The structure below defines the bytecode Tcl object type by
* means of procedures that can be invoked by generic object code.
*/
Tcl_ObjType tclByteCodeType = {
"bytecode", /* name */
FreeByteCodeInternalRep, /* freeIntRepProc */
DupByteCodeInternalRep, /* dupIntRepProc */
(Tcl_UpdateStringProc *) NULL, /* updateStringProc */
SetByteCodeFromAny /* setFromAnyProc */
};
/*
*----------------------------------------------------------------------
*
* TclSetByteCodeFromAny --
*
* Part of the bytecode Tcl object type implementation. Attempts to
* generate an byte code internal form for the Tcl object "objPtr" by
* compiling its string representation. This function also takes
* a hook procedure that will be invoked to perform any needed post
* processing on the compilation results before generating byte
* codes. interp is compilation context and may not be NULL.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during compilation, an error message is left in the interpreter's
* result.
*
* Side effects:
* Frees the old internal representation. If no error occurs, then the
* compiled code is stored as "objPtr"s bytecode representation.
* Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
* used to trace compilations.
*
*----------------------------------------------------------------------
*/
int
TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
Tcl_Interp *interp; /* The interpreter for which the code is
* being compiled. Must not be NULL. */
Tcl_Obj *objPtr; /* The object to make a ByteCode object. */
CompileHookProc *hookProc; /* Procedure to invoke after compilation. */
ClientData clientData; /* Hook procedure private data. */
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure
* allocated in frame. */
LiteralTable *localTablePtr = &(compEnv.localLitTable);
int length, nested, result;
char *string;
#ifdef TCL_TIP280
ContLineLoc* clLocPtr;
#endif
#ifdef TCL_COMPILE_DEBUG
if (!traceInitialized) {
if (Tcl_LinkVar(interp, "tcl_traceCompile",
(char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
}
traceInitialized = 1;
}
#endif
if (iPtr->evalFlags & TCL_BRACKET_TERM) {
nested = 1;
} else {
nested = 0;
}
string = Tcl_GetStringFromObj(objPtr, &length);
#ifndef TCL_TIP280
TclInitCompileEnv(interp, &compEnv, string, length);
#else
/*
* TIP #280. Pick up the CmdFrame in which the BC compiler was invoked
* and use to initialize the tracking in the compiler. This information
* was stored by TclCompEvalObj (tclExecute.c), and ProcCompileProc
* (tclProc.c).
*/
TclInitCompileEnv(interp, &compEnv, string, length,
iPtr->invokeCmdFramePtr, iPtr->invokeWord);
/*
* Now we check if we have data about invisible continuation lines for the
* script, and make it available to the compile environment, if so.
*
* It is not clear if the script Tcl_Obj* can be free'd while the compiler
* is using it, leading to the release of the associated ContLineLoc
* structure as well. To ensure that the latter doesn't happen we set a
* lock on it. We release this lock in the function TclFreeCompileEnv (),
* found in this file. The "lineCLPtr" hashtable is managed in the file
* "tclObj.c".
*/
clLocPtr = TclContinuationsGet (objPtr);
if (clLocPtr) {
compEnv.clLoc = clLocPtr;
compEnv.clNext = &compEnv.clLoc->loc[0];
Tcl_Preserve (compEnv.clLoc);
}
#endif
result = TclCompileScript(interp, string, length, nested, &compEnv);
if (result == TCL_OK) {
/*
* Successful compilation. Add a "done" instruction at the end.
*/
compEnv.numSrcBytes = iPtr->termOffset;
TclEmitOpcode(INST_DONE, &compEnv);
/*
* Invoke the compilation hook procedure if one exists.
*/
if (hookProc) {
result = (*hookProc)(interp, &compEnv, clientData);
}
/*
* Change the object into a ByteCode object. Ownership of the literal
* objects and aux data items is given to the ByteCode object.
*/
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(&compEnv);
#endif /*TCL_COMPILE_DEBUG*/
if (result == TCL_OK) {
TclInitByteCodeObj(objPtr, &compEnv);
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile >= 2) {
TclPrintByteCodeObj(interp, objPtr);
}
#endif /* TCL_COMPILE_DEBUG */
}
}
/*
* Free storage allocated during compilation.
*/
if (localTablePtr->buckets != localTablePtr->staticBuckets) {
ckfree((char *) localTablePtr->buckets);
}
TclFreeCompileEnv(&compEnv);
return result;
}
/*
*-----------------------------------------------------------------------
*
* SetByteCodeFromAny --
*
* Part of the bytecode Tcl object type implementation. Attempts to
* generate an byte code internal form for the Tcl object "objPtr" by
* compiling its string representation.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during compilation, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* Frees the old internal representation. If no error occurs, then the
* compiled code is stored as "objPtr"s bytecode representation.
* Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
* used to trace compilations.
*
*----------------------------------------------------------------------
*/
static int
SetByteCodeFromAny(interp, objPtr)
Tcl_Interp *interp; /* The interpreter for which the code is
* being compiled. Must not be NULL. */
Tcl_Obj *objPtr; /* The object to make a ByteCode object. */
{
if (interp == NULL) {
return TCL_ERROR;
}
return TclSetByteCodeFromAny(interp, objPtr,
(CompileHookProc *) NULL, (ClientData) NULL);
}
/*
*----------------------------------------------------------------------
*
* DupByteCodeInternalRep --
*
* Part of the bytecode Tcl object type implementation. However, it
* does not copy the internal representation of a bytecode Tcl_Obj, but
* instead leaves the new object untyped (with a NULL type pointer).
* Code will be compiled for the new object only if necessary.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
DupByteCodeInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
return;
}
/*
*----------------------------------------------------------------------
*
* FreeByteCodeInternalRep --
*
* Part of the bytecode Tcl object type implementation. Frees the
* storage associated with a bytecode object's internal representation
* unless its code is actively being executed.
*
* Results:
* None.
*
* Side effects:
* The bytecode object's internal rep is marked invalid and its
* code gets freed unless the code is actively being executed.
* In that case the cleanup is delayed until the last execution
* of the code completes.
*
*----------------------------------------------------------------------
*/
static void
FreeByteCodeInternalRep(objPtr)
register Tcl_Obj *objPtr; /* Object whose internal rep to free. */
{
register ByteCode *codePtr =
(ByteCode *) objPtr->internalRep.otherValuePtr;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
objPtr->typePtr = NULL;
objPtr->internalRep.otherValuePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* TclCleanupByteCode --
*
* This procedure does all the real work of freeing up a bytecode
* object's ByteCode structure. It's called only when the structure's
* reference count becomes zero.
*
* Results:
* None.
*
* Side effects:
* Frees objPtr's bytecode internal representation and sets its type
* and objPtr->internalRep.otherValuePtr NULL. Also releases its
* literals and frees its auxiliary data items.
*
*----------------------------------------------------------------------
*/
void
TclCleanupByteCode(codePtr)
register ByteCode *codePtr; /* Points to the ByteCode to free. */
{
Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
int numLitObjects = codePtr->numLitObjects;
int numAuxDataItems = codePtr->numAuxDataItems;
register Tcl_Obj **objArrayPtr;
register AuxData *auxDataPtr;
int i;
#ifdef TCL_COMPILE_STATS
if (interp != NULL) {
ByteCodeStats *statsPtr;
Tcl_Time destroyTime;
int lifetimeSec, lifetimeMicroSec, log2;
statsPtr = &((Interp *) interp)->stats;
statsPtr->numByteCodesFreed++;
statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;
statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
statsPtr->currentLitBytes -=
(double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
statsPtr->currentExceptBytes -=
(double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
statsPtr->currentAuxBytes -=
(double) (codePtr->numAuxDataItems * sizeof(AuxData));
statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;
Tcl_GetTime(&destroyTime);
lifetimeSec = destroyTime.sec - codePtr->createTime.sec;
if (lifetimeSec > 2000) { /* avoid overflow */
lifetimeSec = 2000;
}
lifetimeMicroSec =
1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec);
log2 = TclLog2(lifetimeMicroSec);
if (log2 > 31) {
log2 = 31;
}
statsPtr->lifetimeCount[log2]++;
}
#endif /* TCL_COMPILE_STATS */
/*
* A single heap object holds the ByteCode structure and its code,
* object, command location, and auxiliary data arrays. This means we
* only need to 1) decrement the ref counts of the LiteralEntry's in
* its literal array, 2) call the free procs for the auxiliary data
* items, and 3) free the ByteCode structure's heap object.
*
* The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes,
* like those generated from tbcload) is special, as they doesn't
* make use of the global literal table. They instead maintain
* private references to their literals which must be decremented.
*/
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
register Tcl_Obj *objPtr;
objArrayPtr = codePtr->objArrayPtr;
for (i = 0; i < numLitObjects; i++) {
objPtr = *objArrayPtr;
if (objPtr) {
Tcl_DecrRefCount(objPtr);
}
objArrayPtr++;
}
codePtr->numLitObjects = 0;
} else if (interp != NULL) {
/*
* If the interp has already been freed, then Tcl will have already
* forcefully released all the literals used by ByteCodes compiled
* with respect to that interp.
*/
objArrayPtr = codePtr->objArrayPtr;
for (i = 0; i < numLitObjects; i++) {
/*
* TclReleaseLiteral sets a ByteCode's object array entry NULL to
* indicate that it has already freed the literal.
*/
if (*objArrayPtr != NULL) {
TclReleaseLiteral(interp, *objArrayPtr);
}
objArrayPtr++;
}
}
auxDataPtr = codePtr->auxDataArrayPtr;
for (i = 0; i < numAuxDataItems; i++) {
if (auxDataPtr->type->freeProc != NULL) {
(*auxDataPtr->type->freeProc)(auxDataPtr->clientData);
}
auxDataPtr++;
}
#ifdef TCL_TIP280
/*
* TIP #280. Release the location data associated with this byte code
* structure, if any. NOTE: The interp we belong to may be gone already,
* and the data with it.
*
* See also tclBasic.c, DeleteInterpProc
*/
if (iPtr) {
Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
if (hePtr) {
ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
ReleaseCmdWordData (eclPtr);
Tcl_DeleteHashEntry (hePtr);
}
}
#endif
TclHandleRelease(codePtr->interpHandle);
ckfree((char *) codePtr);
}
#ifdef TCL_TIP280
static void
ReleaseCmdWordData (eclPtr)
ExtCmdLoc* eclPtr;
{
int i;
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (eclPtr->path);
}
for (i=0; i < eclPtr->nuloc; i++) {
ckfree ((char*) eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
ckfree ((char*) eclPtr->loc);
}
Tcl_DeleteHashTable (&eclPtr->litInfo);
ckfree ((char*) eclPtr);
}
#endif
/*
*----------------------------------------------------------------------
*
* TclInitCompileEnv --
*
* Initializes a CompileEnv compilation environment structure for the
* compilation of a string in an interpreter.
*
* Results:
* None.
*
* Side effects:
* The CompileEnv structure is initialized.
*
*----------------------------------------------------------------------
*/
void
#ifndef TCL_TIP280
TclInitCompileEnv(interp, envPtr, string, numBytes)
#else
TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
#endif
Tcl_Interp *interp; /* The interpreter for which a CompileEnv
* structure is initialized. */
register CompileEnv *envPtr; /* Points to the CompileEnv structure to
* initialize. */
char *string; /* The source string to be compiled. */
int numBytes; /* Number of bytes in source string. */
#ifdef TCL_TIP280
CONST CmdFrame* invoker; /* Location context invoking the bcc */
int word; /* Index of the word in that context
* getting compiled */
#endif
{
Interp *iPtr = (Interp *) interp;
envPtr->iPtr = iPtr;
envPtr->source = string;
envPtr->numSrcBytes = numBytes;
envPtr->procPtr = iPtr->compiledProcPtr;
iPtr->compiledProcPtr = NULL;
envPtr->numCommands = 0;
envPtr->exceptDepth = 0;
envPtr->maxExceptDepth = 0;
envPtr->maxStackDepth = 0;
envPtr->currStackDepth = 0;
TclInitLiteralTable(&(envPtr->localLitTable));
envPtr->codeStart = envPtr->staticCodeSpace;
envPtr->codeNext = envPtr->codeStart;
envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
envPtr->mallocedCodeArray = 0;
envPtr->literalArrayPtr = envPtr->staticLiteralSpace;
envPtr->literalArrayNext = 0;
envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
envPtr->mallocedLiteralArray = 0;
envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
envPtr->exceptArrayNext = 0;
envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
envPtr->mallocedExceptArray = 0;
envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
envPtr->mallocedCmdMap = 0;
#ifdef TCL_TIP280
/*
* TIP #280: Set up the extended command location information, based on
* the context invoking the byte code compiler. This structure is used to
* keep the per-word line information for all compiled commands.
*
* See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
* non-compiling evaluator
*/
envPtr->extCmdMapPtr = (ExtCmdLoc*) ckalloc (sizeof (ExtCmdLoc));
envPtr->extCmdMapPtr->loc = NULL;
envPtr->extCmdMapPtr->nloc = 0;
envPtr->extCmdMapPtr->nuloc = 0;
envPtr->extCmdMapPtr->path = NULL;
Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS);
if (invoker == NULL ||
(invoker->type == TCL_LOCATION_EVAL_LIST)) {
/*
* Initialize the compiler for relative counting in case of a
* dynamic context.
*/
envPtr->line = 1;
envPtr->extCmdMapPtr->type = (envPtr->procPtr
? TCL_LOCATION_PROC
: TCL_LOCATION_BC);
} else {
/* Initialize the compiler using the context, making counting absolute
* to that context. Note that the context can be byte code
* execution. In that case we have to fill out the missing pieces
* (line, path, ...). Which may make change the type as well.
*/
CmdFrame ctx = *invoker;
int pc = 0;
if (invoker->type == TCL_LOCATION_BC) {
/* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc (&ctx);
pc = 1;
}
if ((ctx.nline <= word) || (ctx.line[word] < 0)) {
/* Word is not a literal, relative counting */
envPtr->line = 1;
envPtr->extCmdMapPtr->type = (envPtr->procPtr
? TCL_LOCATION_PROC
: TCL_LOCATION_BC);
if (pc && (ctx.type == TCL_LOCATION_SOURCE)) {
/*
* The reference made by 'TclGetSrcInfoForPc' is dead.
*/
Tcl_DecrRefCount(ctx.data.eval.path);
}
} else {
envPtr->line = ctx.line [word];
envPtr->extCmdMapPtr->type = ctx.type;
envPtr->extCmdMapPtr->path = ctx.data.eval.path;
if (ctx.type == TCL_LOCATION_SOURCE) {
if (pc) {
/* The reference 'TclGetSrcInfoForPc' made is transfered */
ctx.data.eval.path = NULL;
} else {
/* We have a new reference here */
Tcl_IncrRefCount (ctx.data.eval.path);
}
}
}
/* ctx going out of scope */
}
/*
* Initialize the data about invisible continuation lines as empty,
* i.e. not used. The caller (TclSetByteCodeFromAny) will set this up, if
* such data is available.
*/
envPtr->clLoc = NULL;
envPtr->clNext = NULL;
#endif
envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
envPtr->auxDataArrayNext = 0;
envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
envPtr->mallocedAuxDataArray = 0;
}
/*
*----------------------------------------------------------------------
*
* TclFreeCompileEnv --
*
* Free the storage allocated in a CompileEnv compilation environment
* structure.
*
* Results:
* None.
*
* Side effects:
* Allocated storage in the CompileEnv structure is freed. Note that
* its local literal table is not deleted and its literal objects are
* not released. In addition, storage referenced by its auxiliary data
* items is not freed. This is done so that, when compilation is
* successful, "ownership" of these objects and aux data items is
* handed over to the corresponding ByteCode structure.
*
*----------------------------------------------------------------------
*/
void
TclFreeCompileEnv(envPtr)
register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
{
if (envPtr->iPtr) {
/*
* We never converted to Bytecode, so free the things we would
* have transferred to it.
*/
int i;
LiteralEntry *entryPtr = envPtr->literalArrayPtr;
AuxData *auxDataPtr = envPtr->auxDataArrayPtr;
for (i = 0; i < envPtr->literalArrayNext; i++) {
TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr);
entryPtr++;
}
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable(envPtr->iPtr);
#endif /*TCL_COMPILE_DEBUG*/
for (i = 0; i < envPtr->auxDataArrayNext; i++) {
if (auxDataPtr->type->freeProc != NULL) {
auxDataPtr->type->freeProc(auxDataPtr->clientData);
}
auxDataPtr++;
}
}
if (envPtr->mallocedCodeArray) {
ckfree((char *) envPtr->codeStart);
}
if (envPtr->mallocedLiteralArray) {
ckfree((char *) envPtr->literalArrayPtr);
}
if (envPtr->mallocedExceptArray) {
ckfree((char *) envPtr->exceptArrayPtr);
}
if (envPtr->mallocedCmdMap) {
ckfree((char *) envPtr->cmdMapPtr);
}
if (envPtr->mallocedAuxDataArray) {
ckfree((char *) envPtr->auxDataArrayPtr);
}
#ifdef TCL_TIP280
/*
* If we used data about invisible continuation lines, then now is the
* time to release on our hold on it. The lock was set in function
* TclSetByteCodeFromAny(), found in this file.
*/
if (envPtr->clLoc) {
Tcl_Release (envPtr->clLoc);
}
if (envPtr->extCmdMapPtr) {
ReleaseCmdWordData (envPtr->extCmdMapPtr);
}
#endif
}
#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
*
* TclWordKnownAtCompileTime --
*
* Test whether the value of a token is completely known at compile time.
*
* Results:
* Returns true if the tokenPtr argument points to a word value that is
* completely known at compile time. Generally, values that are known at
* compile time can be compiled to their values, while values that cannot
* be known until substitution at runtime must be compiled to bytecode
* instructions that perform that substitution. For several commands,
* whether or not arguments are known at compile time determine whether
* it is worthwhile to compile at all.
*
* Side effects:
* None.
*
* TIP #280
*----------------------------------------------------------------------
*/
int
TclWordKnownAtCompileTime (tokenPtr)
Tcl_Token* tokenPtr;
{
int i;
Tcl_Token* sub;
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {return 1;};
if (tokenPtr->type != TCL_TOKEN_WORD) {return 0;};
/* Check the sub tokens of the word. It is a literal if we find
* only BS and TEXT tokens */
for (i=0, sub = tokenPtr + 1;
i < tokenPtr->numComponents;
i++, sub ++) {
if (sub->type == TCL_TOKEN_TEXT) continue;
if (sub->type == TCL_TOKEN_BS) continue;
return 0;
}
return 1;
}
#endif
/*
*----------------------------------------------------------------------
*
* TclCompileScript --
*
* Compile a Tcl script in a string.
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* interp->termOffset is set to the offset of the character in the
* script just after the last one successfully processed; this will be
* the offset of the ']' if (flags & TCL_BRACKET_TERM).
*
* Side effects:
* Adds instructions to envPtr to evaluate the script at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileScript(interp, script, numBytes, nested, envPtr)
Tcl_Interp *interp; /* Used for error and status reporting.
* Also serves as context for finding and
* compiling commands. May not be NULL. */
CONST char *script; /* The source script to compile. */
int numBytes; /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
int nested; /* Non-zero means this is a nested command:
* close bracket ']' should be considered a
* command terminator. If zero, close
* bracket has no special meaning. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Parse parse;
int lastTopLevelCmdIndex = -1;
/* Index of most recent toplevel command in
* the command location table. Initialized
* to avoid compiler warning. */
int startCodeOffset = -1; /* Offset of first byte of current command's
* code. Init. to avoid compiler warning. */
unsigned char *entryCodeNext = envPtr->codeNext;
CONST char *p, *next;
Namespace *cmdNsPtr;
Command *cmdPtr;
Tcl_Token *tokenPtr;
int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
int commandLength, objIndex, code;
Tcl_DString ds;
#ifdef TCL_TIP280
/* TIP #280 */
ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr;
int* wlines = NULL;
int wlineat, cmdLine;
int* clNext;
#endif
if (envPtr->iPtr == NULL) {
Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv");
}
Tcl_DStringInit(&ds);
if (numBytes < 0) {
numBytes = strlen(script);
}
Tcl_ResetResult(interp);
isFirstCmd = 1;
/*
* Each iteration through the following loop compiles the next
* command from the script.
*/
p = script;
bytesLeft = numBytes;
gotParse = 0;
#ifdef TCL_TIP280
cmdLine = envPtr->line;
clNext = envPtr->clNext;
#endif
do {
if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
code = TCL_ERROR;
goto error;
}
gotParse = 1;
if (nested) {
/*
* This is an unusual situation where the caller has passed us
* a non-zero value for "nested". How unusual? Well, this
* procedure, TclCompileScript, is internal to Tcl, so all
* callers should be within Tcl itself. All but one of those
* callers explicitly pass in (nested = 0). The exceptional
* caller is TclSetByteCodeFromAny, which will pass in
* (nested = 1) if and only if the flag TCL_BRACKET_TERM
* is set in the evalFlags field of interp.
*
* It appears that the TCL_BRACKET_TERM flag is only ever set
* by Tcl_SubstObj, and it immediately calls Tcl_EvalEx
* which clears the flag before passing the interp along.
* So, I don't think this procedure, TclCompileScript, is
* **ever** called with (nested != 0).
* (The testsuite indeed doesn't exercise this code. MS)
*
* This means that the branches in this procedure that are
* only active when (nested != 0) are probably never exercised.
* This means that any bugs in them go unnoticed, and any bug
* fixes in them have a semi-theoretical nature.
*
* All that said, the spec for this procedure says it should
* handle the (nested != 0) case, so here's an attempt to fix
* bugs (Tcl Bug 681841) in that case. Just in case some
* callers eventually come along and expect it to work...
*/
if (parse.term == (script + numBytes)) {
/*
* The (nested != 0) case is meant to indicate that the
* caller found an open bracket ([) and asked us to
* parse and compile Tcl commands up to the matching
* close bracket (]). We have to detect and handle
* the case where the close bracket is missing.
*/
Tcl_SetObjResult(interp,
Tcl_NewStringObj("missing close-bracket", -1));
code = TCL_ERROR;
goto error;
}
}
if (parse.numWords > 0) {
/*
* If not the first command, pop the previous command's result
* and, if we're compiling a top level command, update the last
* command's code size to account for the pop instruction.
*/
if (!isFirstCmd) {
TclEmitOpcode(INST_POP, envPtr);
if (!nested) {
envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
(envPtr->codeNext - envPtr->codeStart)
- startCodeOffset;
}
}
/*
* Determine the actual length of the command.
*/
commandLength = parse.commandSize;
if (parse.term == parse.commandStart + commandLength - 1) {
/*
* The command terminator character (such as ; or ]) is
* the last character in the parsed command. Reduce the
* length by one so that the trace message doesn't include
* the terminator character.
*/
commandLength -= 1;
}
#ifdef TCL_COMPILE_DEBUG
/*
* If tracing, print a line for each top level command compiled.
*/
if ((tclTraceCompile >= 1)
&& !nested && (envPtr->procPtr == NULL)) {
fprintf(stdout, " Compiling: ");
TclPrintSource(stdout, parse.commandStart,
TclMin(commandLength, 55));
fprintf(stdout, "\n");
}
#endif
/*
* Each iteration of the following loop compiles one word
* from the command.
*/
envPtr->numCommands++;
currCmdIndex = (envPtr->numCommands - 1);
if (!nested) {
lastTopLevelCmdIndex = currCmdIndex;
}
startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
EnterCmdStartData(envPtr, currCmdIndex,
(parse.commandStart - envPtr->source), startCodeOffset);
#ifdef TCL_TIP280
/* TIP #280. Scan the words and compute the extended location
* information. The map first contain full per-word line
* information for use by the compiler. This is later replaced by
* a reduced form which signals non-literal words, stored in
* 'wlines'.
*/
TclAdvanceLines (&cmdLine, p, parse.commandStart);
TclAdvanceContinuations (&cmdLine, &clNext,
parse.commandStart - envPtr->source);
EnterCmdWordData (eclPtr, (parse.commandStart - envPtr->source),
parse.tokenPtr, parse.commandStart,
parse.commandSize, parse.numWords,
cmdLine, clNext, &wlines, envPtr);
wlineat = eclPtr->nuloc - 1;
#endif
for (wordIdx = 0, tokenPtr = parse.tokenPtr;
wordIdx < parse.numWords;
wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
#ifdef TCL_TIP280
envPtr->line = eclPtr->loc [wlineat].line [wordIdx];
envPtr->clNext = eclPtr->loc [wlineat].next [wordIdx];
#endif
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
* If this is the first word and the command has a
* compile procedure, let it compile the command.
*/
if (wordIdx == 0) {
if (envPtr->procPtr != NULL) {
cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
} else {
cmdNsPtr = NULL; /* use current NS */
}
/*
* We copy the string before trying to find the command
* by name. We used to modify the string in place, but
* this is not safe because the name resolution
* handlers could have side effects that rely on the
* unmodified string.
*/
Tcl_DStringSetLength(&ds, 0);
Tcl_DStringAppend(&ds, tokenPtr[1].start,
tokenPtr[1].size);
cmdPtr = (Command *) Tcl_FindCommand(interp,
Tcl_DStringValue(&ds),
(Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
if ((cmdPtr != NULL)
&& (cmdPtr->compileProc != NULL)
&& !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
int savedNumCmds = envPtr->numCommands;
unsigned int savedCodeNext =
envPtr->codeNext - envPtr->codeStart;
code = (*(cmdPtr->compileProc))(interp, &parse,
envPtr);
if (code == TCL_OK) {
goto finishCommand;
} else if (code == TCL_OUT_LINE_COMPILE) {
/*
* Restore numCommands and codeNext to their correct
* values, removing any commands compiled before
* TCL_OUT_LINE_COMPILE [Bugs 705406 and 735055]
*/
envPtr->numCommands = savedNumCmds;
envPtr->codeNext = envPtr->codeStart + savedCodeNext;
} else { /* an error */
/*
* There was a compilation error, the last
* command did not get compiled into (*envPtr).
* Decrement the number of commands
* claimed to be in (*envPtr).
*/
envPtr->numCommands--;
goto log;
}
}
/*
* No compile procedure so push the word. If the
* command was found, push a CmdName object to
* reduce runtime lookups.
*/
objIndex = TclRegisterNewLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size);
if (cmdPtr != NULL) {
TclSetCmdNameObj(interp,
envPtr->literalArrayPtr[objIndex].objPtr,
cmdPtr);
}
} else {
/* Simple argument word of a command. We reach this if
* and only if the command word was not compiled for
* whatever reason. Register the literal's location
* for use by uplevel, etc. commands, should they
* encounter it unmodified. We care only if the we are
* in a context which already allows absolute
* counting.
*/
objIndex = TclRegisterNewLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size);
#ifdef TCL_TIP280
if (envPtr->clNext) {
TclContinuationsEnterDerived (envPtr->literalArrayPtr[objIndex].objPtr,
tokenPtr[1].start - envPtr->source,
eclPtr->loc [wlineat].next [wordIdx]);
}
#endif
}
TclEmitPush(objIndex, envPtr);
} else {
/*
* The word is not a simple string of characters.
*/
code = TclCompileTokens(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto log;
}
}
}
/*
* Emit an invoke instruction for the command. We skip this
* if a compile procedure was found for the command.
*/
if (wordIdx > 0) {
#ifdef TCL_TIP280
/*
* Save PC -> command map for the TclArgumentBC* functions.
*/
int isnew;
Tcl_HashEntry* hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo,
(char*) (envPtr->codeNext - envPtr->codeStart), &isnew);
Tcl_SetHashValue(hePtr, (char*) wlineat);
#endif
if (wordIdx <= 255) {
TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
} else {
TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
}
}
/*
* Update the compilation environment structure and record the
* offsets of the source and code for the command.
*/
finishCommand:
EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
(envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
isFirstCmd = 0;
#ifdef TCL_TIP280
/* TIP #280: Free full form of per-word line data and insert
* the reduced form now
*/
ckfree ((char*) eclPtr->loc [wlineat].line);
ckfree ((char*) eclPtr->loc [wlineat].next);
eclPtr->loc [wlineat].line = wlines;
eclPtr->loc [wlineat].next = NULL;
wlines = NULL;
#endif
} /* end if parse.numWords > 0 */
/*
* Advance to the next command in the script.
*/
next = parse.commandStart + parse.commandSize;
bytesLeft -= (next - p);
p = next;
#ifdef TCL_TIP280
/* TIP #280 : Track lines in the just compiled command */
TclAdvanceLines (&cmdLine, parse.commandStart, p);
TclAdvanceContinuations (&cmdLine, &clNext, p - envPtr->source);
#endif
Tcl_FreeParse(&parse);
gotParse = 0;
if (nested && (*parse.term == ']')) {
/*
* We get here in the special case where TCL_BRACKET_TERM was
* set in the interpreter and the latest parsed command was
* terminated by the matching close-bracket we were looking for.
* Stop compilation.
*/
break;
}
} while (bytesLeft > 0);
/*
* If the source script yielded no instructions (e.g., if it was empty),
* push an empty string as the command's result.
*/
if (envPtr->codeNext == entryCodeNext) {
TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
envPtr);
}
if (nested) {
/*
* When (nested != 0) back up 1 character to have
* iPtr->termOffset indicate the offset to the matching
* close-bracket.
*/
iPtr->termOffset = (p - 1) - script;
} else {
iPtr->termOffset = (p - script);
}
Tcl_DStringFree(&ds);
return TCL_OK;
error:
/*
* Generate various pieces of error information, such as the line
* number where the error occurred and information to add to the
* errorInfo variable. Then free resources that had been allocated
* to the command.
*/
commandLength = parse.commandSize;
if (parse.term == parse.commandStart + commandLength - 1) {
/*
* The terminator character (such as ; or ]) of the command where
* the error occurred is the last character in the parsed command.
* Reduce the length by one so that the error message doesn't
* include the terminator character.
*/
commandLength -= 1;
}
log:
#ifdef TCL_TIP280
/* TIP #280: Free the per-word line data left over from parsing an
* erroneous command, if any.
*/
if (wlines) {
ckfree ((char*) eclPtr->loc [wlineat].line);
ckfree ((char*) eclPtr->loc [wlineat].next);
ckfree ((char*) wlines);
eclPtr->loc [wlineat].line = NULL;
eclPtr->loc [wlineat].next = NULL;
wlines = NULL;
}
#endif
LogCompilationInfo(interp, script, parse.commandStart, commandLength);
if (gotParse) {
Tcl_FreeParse(&parse);
}
iPtr->termOffset = (p - script);
Tcl_DStringFree(&ds);
return code;
}
/*
*----------------------------------------------------------------------
*
* TclCompileTokens --
*
* Given an array of tokens parsed from a Tcl command (e.g., the tokens
* that make up a word) this procedure emits instructions to evaluate
* the tokens and concatenate their values to form a single result
* value on the interpreter's runtime evaluation stack.
*
* Results:
* The return value is a standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
* Side effects:
* Instructions are added to envPtr to push and evaluate the tokens
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileTokens(interp, tokenPtr, count, envPtr)
Tcl_Interp *interp; /* Used for error and status reporting. */
Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
* to compile. */
int count; /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
CompileEnv *envPtr; /* Holds the resulting instructions. */
{
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
char buffer[TCL_UTF_MAX];
CONST char *name, *p;
int numObjsToConcat, nameBytes, localVarName, localVar;
int length, i, code;
unsigned char *entryCodeNext = envPtr->codeNext;
#ifdef TCL_TIP280
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL;
int* clPosition = NULL;
/*
* For the handling of continuation lines in literals we first check if
* this is actually a literal. For if not we can forego the additional
* processing. Otherwise we pre-allocate a small table to store the
* locations of all continuation lines we find in this literal, if
* any. The table is extended if needed.
*
* Note: Different to the equivalent code in function
* 'EvalTokensStandard()' (see file "tclBasic.c") we do not seem to need
* the 'adjust' variable. We also do not seem to need code which merges
* continuation line information of multiple words which concat'd at
* runtime. Either that or I have not managed to find a test case for
* these two possibilities yet. It might be a difference between compile-
* versus runtime processing.
*/
numCL = 0;
maxNumCL = 0;
isLiteral = 1;
for (i=0 ; i < count; i++) {
if ((tokenPtr[i].type != TCL_TOKEN_TEXT) &&
(tokenPtr[i].type != TCL_TOKEN_BS)) {
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
clPosition = (int*) ckalloc (maxNumCL*sizeof(int));
}
#endif
Tcl_DStringInit(&textBuffer);
numObjsToConcat = 0;
for ( ; count > 0; count--, tokenPtr++) {
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
Tcl_DStringAppend(&textBuffer, tokenPtr->start,
tokenPtr->size);
break;
case TCL_TOKEN_BS:
length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
(int *) NULL, buffer);
Tcl_DStringAppend(&textBuffer, buffer, length);
#ifdef TCL_TIP280
/*
* If the backslash sequence we found is in a literal, and
* represented a continuation line, we compute and store its
* location (as char offset to the beginning of the _result_
* script). We may have to extend the table of locations.
*
* Note that the continuation line information is relevant
* even if the word we are processing is not a literal, as it
* can affect nested commands. See the branch for
* TCL_TOKEN_COMMAND below, where the adjustment we are
* tracking here is taken into account. The good thing is that
* we do not need a table of everything, just the number of
* lines we have to add as correction.
*/
if ((length == 1) && (buffer[0] == ' ') &&
(tokenPtr->start[1] == '\n')) {
if (isLiteral) {
int clPos = Tcl_DStringLength (&textBuffer);
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = (int*) ckrealloc ((char*)clPosition,
maxNumCL*sizeof(int));
}
clPosition[numCL] = clPos;
numCL ++;
}
}
#endif
break;
case TCL_TOKEN_COMMAND:
/*
* Push any accumulated chars appearing before the command.
*/
if (Tcl_DStringLength(&textBuffer) > 0) {
int literal;
literal = TclRegisterLiteral(envPtr,
Tcl_DStringValue(&textBuffer),
Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
Tcl_DStringFree(&textBuffer);
#ifdef TCL_TIP280
if (numCL) {
TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
numCL, clPosition);
}
numCL = 0;
#endif
}
code = TclCompileScript(interp, tokenPtr->start+1,
tokenPtr->size-2, /*nested*/ 0, envPtr);
if (code != TCL_OK) {
goto error;
}
numObjsToConcat++;
break;
case TCL_TOKEN_VARIABLE:
/*
* Push any accumulated chars appearing before the $.
*/
if (Tcl_DStringLength(&textBuffer) > 0) {
int literal;
literal = TclRegisterLiteral(envPtr,
Tcl_DStringValue(&textBuffer),
Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
Tcl_DStringFree(&textBuffer);
}
/*
* Determine how the variable name should be handled: if it contains
* any namespace qualifiers it is not a local variable (localVarName=-1);
* if it looks like an array element and the token has a single component,
* it should not be created here [Bug 569438] (localVarName=0); otherwise,
* the local variable can safely be created (localVarName=1).
*/
name = tokenPtr[1].start;
nameBytes = tokenPtr[1].size;
localVarName = -1;
if (envPtr->procPtr != NULL) {
localVarName = 1;
for (i = 0, p = name; i < nameBytes; i++, p++) {
if ((*p == ':') && (i < (nameBytes-1))
&& (*(p+1) == ':')) {
localVarName = -1;
break;
} else if ((*p == '(')
&& (tokenPtr->numComponents == 1)
&& (*(name + nameBytes - 1) == ')')) {
localVarName = 0;
break;
}
}
}
/*
* Either push the variable's name, or find its index in
* the array of local variables in a procedure frame.
*/
localVar = -1;
if (localVarName != -1) {
localVar = TclFindCompiledLocal(name, nameBytes,
localVarName, /*flags*/ 0, envPtr->procPtr);
}
if (localVar < 0) {
TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
envPtr);
}
/*
* Emit instructions to load the variable.
*/
if (tokenPtr->numComponents == 1) {
if (localVar < 0) {
TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
} else if (localVar <= 255) {
TclEmitInstInt1(INST_LOAD_SCALAR1, localVar,
envPtr);
} else {
TclEmitInstInt4(INST_LOAD_SCALAR4, localVar,
envPtr);
}
} else {
code = TclCompileTokens(interp, tokenPtr+2,
tokenPtr->numComponents-1, envPtr);
if (code != TCL_OK) {
char errorBuffer[150];
sprintf(errorBuffer,
"\n (parsing index for array \"%.*s\")",
((nameBytes > 100)? 100 : nameBytes), name);
Tcl_AddObjErrorInfo(interp, errorBuffer, -1);
goto error;
}
if (localVar < 0) {
TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
} else if (localVar <= 255) {
TclEmitInstInt1(INST_LOAD_ARRAY1, localVar,
envPtr);
} else {
TclEmitInstInt4(INST_LOAD_ARRAY4, localVar,
envPtr);
}
}
numObjsToConcat++;
count -= tokenPtr->numComponents;
tokenPtr += tokenPtr->numComponents;
break;
default:
panic("Unexpected token type in TclCompileTokens");
}
}
/*
* Push any accumulated characters appearing at the end.
*/
if (Tcl_DStringLength(&textBuffer) > 0) {
int literal;
literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),
Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
#ifdef TCL_TIP280
if (numCL) {
TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
numCL, clPosition);
}
numCL = 0;
#endif
}
/*
* If necessary, concatenate the parts of the word.
*/
while (numObjsToConcat > 255) {
TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
numObjsToConcat -= 254; /* concat pushes 1 obj, the result */
}
if (numObjsToConcat > 1) {
TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);
}
/*
* If the tokens yielded no instructions, push an empty string.
*/
if (envPtr->codeNext == entryCodeNext) {
TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
envPtr);
}
code = TCL_OK;
error:
Tcl_DStringFree(&textBuffer);
#ifdef TCL_TIP280
/*
* Release the temp table we used to collect the locations of
* continuation lines, if any.
*/
if (maxNumCL) {
ckfree ((char*) clPosition);
}
#endif
return code;
}
/*
*----------------------------------------------------------------------
*
* TclCompileCmdWord --
*
* Given an array of parse tokens for a word containing one or more Tcl
* commands, emit inline instructions to execute them. This procedure
* differs from TclCompileTokens in that a simple word such as a loop
* body enclosed in braces is not just pushed as a string, but is
* itself parsed into tokens and compiled.
*
* Results:
* The return value is a standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
* Side effects:
* Instructions are added to envPtr to execute the tokens at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileCmdWord(interp, tokenPtr, count, envPtr)
Tcl_Interp *interp; /* Used for error and status reporting. */
Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
* for a command word to compile inline. */
int count; /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
CompileEnv *envPtr; /* Holds the resulting instructions. */
{
int code;
/*
* Handle the common case: if there is a single text token, compile it
* into an inline sequence of instructions.
*/
if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
/*nested*/ 0, envPtr);
return code;
}
/*
* Multiple tokens or the single token involves substitutions. Emit
* instructions to invoke the eval command procedure at runtime on the
* result of evaluating the tokens.
*/
code = TclCompileTokens(interp, tokenPtr, count, envPtr);
if (code != TCL_OK) {
return code;
}
TclEmitOpcode(INST_EVAL_STK, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileExprWords --
*
* Given an array of parse tokens representing one or more words that
* contain a Tcl expression, emit inline instructions to execute the
* expression. This procedure differs from TclCompileExpr in that it
* supports Tcl's two-level substitution semantics for expressions that
* appear as command words.
*
* Results:
* The return value is a standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
* Side effects:
* Instructions are added to envPtr to execute the expression.
*
*----------------------------------------------------------------------
*/
int
TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
Tcl_Interp *interp; /* Used for error and status reporting. */
Tcl_Token *tokenPtr; /* Points to first in an array of word
* tokens tokens for the expression to
* compile inline. */
int numWords; /* Number of word tokens starting at
* tokenPtr. Must be at least 1. Each word
* token contains one or more subtokens. */
CompileEnv *envPtr; /* Holds the resulting instructions. */
{
Tcl_Token *wordPtr;
int numBytes, i, code;
CONST char *script;
code = TCL_OK;
/*
* If the expression is a single word that doesn't require
* substitutions, just compile its string into inline instructions.
*/
if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
script = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
code = TclCompileExpr(interp, script, numBytes, envPtr);
return code;
}
/*
* Emit code to call the expr command proc at runtime. Concatenate the
* (already substituted once) expr tokens with a space between each.
*/
wordPtr = tokenPtr;
for (i = 0; i < numWords; i++) {
code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents,
envPtr);
if (code != TCL_OK) {
break;
}
if (i < (numWords - 1)) {
TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0),
envPtr);
}
wordPtr += (wordPtr->numComponents + 1);
}
if (code == TCL_OK) {
int concatItems = 2*numWords - 1;
while (concatItems > 255) {
TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
concatItems -= 254;
}
if (concatItems > 1) {
TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);
}
TclEmitOpcode(INST_EXPR_STK, envPtr);
}
return code;
}
/*
*----------------------------------------------------------------------
*
* TclInitByteCodeObj --
*
* Create a ByteCode structure and initialize it from a CompileEnv
* compilation environment structure. The ByteCode structure is
* smaller and contains just that information needed to execute
* the bytecode instructions resulting from compiling a Tcl script.
* The resulting structure is placed in the specified object.
*
* Results:
* A newly constructed ByteCode object is stored in the internal
* representation of the objPtr.
*
* Side effects:
* A single heap object is allocated to hold the new ByteCode structure
* and its code, object, command location, and aux data arrays. Note
* that "ownership" (i.e., the pointers to) the Tcl objects and aux
* data items will be handed over to the new ByteCode structure from
* the CompileEnv structure.
*
*----------------------------------------------------------------------
*/
void
TclInitByteCodeObj(objPtr, envPtr)
Tcl_Obj *objPtr; /* Points object that should be
* initialized, and whose string rep
* contains the source code. */
register CompileEnv *envPtr; /* Points to the CompileEnv structure from
* which to create a ByteCode structure. */
{
register ByteCode *codePtr;
size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
size_t auxDataArrayBytes, structureSize;
register unsigned char *p;
#ifdef TCL_COMPILE_DEBUG
unsigned char *nextPtr;
#endif
int numLitObjects = envPtr->literalArrayNext;
Namespace *namespacePtr;
int i;
#ifdef TCL_TIP280
int new;
#endif
Interp *iPtr;
if (envPtr->iPtr == NULL) {
Tcl_Panic("TclInitByteCodeObj() called on uninitialized CompileEnv");
}
iPtr = envPtr->iPtr;
codeBytes = (envPtr->codeNext - envPtr->codeStart);
objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
cmdLocBytes = GetCmdLocEncodingSize(envPtr);
/*
* Compute the total number of bytes needed for this bytecode.
*/
structureSize = sizeof(ByteCode);
structureSize += TCL_ALIGN(codeBytes); /* align object array */
structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */
structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
structureSize += auxDataArrayBytes;
structureSize += cmdLocBytes;
if (envPtr->iPtr->varFramePtr != NULL) {
namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = envPtr->iPtr->globalNsPtr;
}
p = (unsigned char *) ckalloc((size_t) structureSize);
codePtr = (ByteCode *) p;
codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = namespacePtr;
codePtr->nsEpoch = namespacePtr->resolverEpoch;
codePtr->refCount = 1;
codePtr->flags = 0;
codePtr->source = envPtr->source;
codePtr->procPtr = envPtr->procPtr;
codePtr->numCommands = envPtr->numCommands;
codePtr->numSrcBytes = envPtr->numSrcBytes;
codePtr->numCodeBytes = codeBytes;
codePtr->numLitObjects = numLitObjects;
codePtr->numExceptRanges = envPtr->exceptArrayNext;
codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
codePtr->numCmdLocBytes = cmdLocBytes;
codePtr->maxExceptDepth = envPtr->maxExceptDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
p += sizeof(ByteCode);
codePtr->codeStart = p;
memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes);
p += TCL_ALIGN(codeBytes); /* align object array */
codePtr->objArrayPtr = (Tcl_Obj **) p;
for (i = 0; i < numLitObjects; i++) {
codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
}
p += TCL_ALIGN(objArrayBytes); /* align exception range array */
if (exceptArrayBytes > 0) {
codePtr->exceptArrayPtr = (ExceptionRange *) p;
memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr,
(size_t) exceptArrayBytes);
} else {
codePtr->exceptArrayPtr = NULL;
}
p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
if (auxDataArrayBytes > 0) {
codePtr->auxDataArrayPtr = (AuxData *) p;
memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
(size_t) auxDataArrayBytes);
} else {
codePtr->auxDataArrayPtr = NULL;
}
p += auxDataArrayBytes;
#ifndef TCL_COMPILE_DEBUG
EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
#else
nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
if (((size_t)(nextPtr - p)) != cmdLocBytes) {
panic("TclInitByteCodeObj: encoded cmd location bytes %ld != expected size %ld\n", (nextPtr - p), cmdLocBytes);
}
#endif
/*
* Record various compilation-related statistics about the new ByteCode
* structure. Don't include overhead for statistics-related fields.
*/
#ifdef TCL_COMPILE_STATS
codePtr->structureSize = structureSize
- (sizeof(size_t) + sizeof(Tcl_Time));
Tcl_GetTime(&(codePtr->createTime));
RecordByteCodeStats(codePtr);
#endif /* TCL_COMPILE_STATS */
/*
* Free the old internal rep then convert the object to a
* bytecode object by making its internal rep point to the just
* compiled ByteCode.
*/
if ((objPtr->typePtr != NULL) &&
(objPtr->typePtr->freeIntRepProc != NULL)) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
objPtr->typePtr = &tclByteCodeType;
#ifdef TCL_TIP280
/* TIP #280. Associate the extended per-word line information with the
* byte code object (internal rep), for use with the bc compiler.
*/
Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->lineBCPtr, (char*) codePtr, &new),
envPtr->extCmdMapPtr);
envPtr->extCmdMapPtr = NULL;
#endif
/* We've used up the CompileEnv. Mark as uninitialized. */
envPtr->iPtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* LogCompilationInfo --
*
* This procedure is invoked after an error occurs during compilation.
* It adds information to the "errorInfo" variable to describe the
* command that was being compiled when the error occurred.
*
* Results:
* None.
*
* Side effects:
* Information about the command is added to errorInfo and the
* line number stored internally in the interpreter is set. If this
* is the first call to this procedure or Tcl_AddObjErrorInfo since
* an error occurred, then old information in errorInfo is
* deleted.
*
*----------------------------------------------------------------------
*/
static void
LogCompilationInfo(interp, script, command, length)
Tcl_Interp *interp; /* Interpreter in which to log the
* information. */
CONST char *script; /* First character in script containing
* command (must be <= command). */
CONST char *command; /* First character in command that
* generated the error. */
int length; /* Number of bytes in command (-1 means
* use all bytes up to first null byte). */
{
char buffer[200];
register CONST char *p;
char *ellipsis = "";
Interp *iPtr = (Interp *) interp;
if (iPtr->flags & ERR_ALREADY_LOGGED) {
/*
* Someone else has already logged error information for this
* command; we shouldn't add anything more.
*/
return;
}
/*
* Compute the line number where the error occurred.
*/
iPtr->errorLine = 1;
for (p = script; p != command; p++) {
if (*p == '\n') {
iPtr->errorLine++;
}
}
/*
* Create an error message to add to errorInfo, including up to a
* maximum number of characters of the command.
*/
if (length < 0) {
length = strlen(command);
}
if (length > 150) {
length = 150;
ellipsis = "...";
}
while ( (command[length] & 0xC0) == 0x80 ) {
/*
* Back up truncation point so that we don't truncate in the
* middle of a multi-byte character (in UTF-8)
*/
length--;
ellipsis = "...";
}
sprintf(buffer, "\n while compiling\n\"%.*s%s\"",
length, command, ellipsis);
Tcl_AddObjErrorInfo(interp, buffer, -1);
}
/*
*----------------------------------------------------------------------
*
* TclFindCompiledLocal --
*
* This procedure is called at compile time to look up and optionally
* allocate an entry ("slot") for a variable in a procedure's array of
* local variables. If the variable's name is NULL, a new temporary
* variable is always created. (Such temporary variables can only be
* referenced using their slot index.)
*
* Results:
* If create is 0 and the name is non-NULL, then if the variable is
* found, the index of its entry in the procedure's array of local
* variables is returned; otherwise -1 is returned. If name is NULL,
* the index of a new temporary variable is returned. Finally, if
* create is 1 and name is non-NULL, the index of a new entry is
* returned.
*
* Side effects:
* Creates and registers a new local variable if create is 1 and
* the variable is unknown, or if the name is NULL.
*
*----------------------------------------------------------------------
*/
int
TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
register CONST char *name; /* Points to first character of the name of
* a scalar or array variable. If NULL, a
* temporary var should be created. */
int nameBytes; /* Number of bytes in the name. */
int create; /* If 1, allocate a local frame entry for
* the variable if it is new. */
int flags; /* Flag bits for the compiled local if
* created. Only VAR_SCALAR, VAR_ARRAY, and
* VAR_LINK make sense. */
register Proc *procPtr; /* Points to structure describing procedure
* containing the variable reference. */
{
register CompiledLocal *localPtr;
int localVar = -1;
register int i;
/*
* If not creating a temporary, does a local variable of the specified
* name already exist?
*/
if (name != NULL) {
int localCt = procPtr->numCompiledLocals;
localPtr = procPtr->firstLocalPtr;
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
char *localName = localPtr->name;
if ((nameBytes == localPtr->nameLength)
&& (strncmp(name, localName, (unsigned) nameBytes) == 0)) {
return i;
}
}
localPtr = localPtr->nextPtr;
}
}
/*
* Create a new variable if appropriate.
*/
if (create || (name == NULL)) {
localVar = procPtr->numCompiledLocals;
localPtr = (CompiledLocal *) ckalloc((unsigned)
(sizeof(CompiledLocal) - sizeof(localPtr->name)
+ nameBytes+1));
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
localPtr->nameLength = nameBytes;
localPtr->frameIndex = localVar;
localPtr->flags = flags | VAR_UNDEFINED;
if (name == NULL) {
localPtr->flags |= VAR_TEMPORARY;
}
localPtr->defValuePtr = NULL;
localPtr->resolveInfo = NULL;
if (name != NULL) {
memcpy((VOID *) localPtr->name, (VOID *) name,
(size_t) nameBytes);
}
localPtr->name[nameBytes] = '\0';
procPtr->numCompiledLocals++;
}
return localVar;
}
/*
*----------------------------------------------------------------------
*
* TclInitCompiledLocals --
*
* This routine is invoked in order to initialize the compiled
* locals table for a new call frame.
*
* Results:
* None.
*
* Side effects:
* May invoke various name resolvers in order to determine which
* variables are being referenced at runtime.
*
*----------------------------------------------------------------------
*/
void
TclInitCompiledLocals(interp, framePtr, nsPtr)
Tcl_Interp *interp; /* Current interpreter. */
CallFrame *framePtr; /* Call frame to initialize. */
Namespace *nsPtr; /* Pointer to current namespace. */
{
register CompiledLocal *localPtr;
Interp *iPtr = (Interp*) interp;
Tcl_ResolvedVarInfo *vinfo, *resVarInfo;
Var *varPtr = framePtr->compiledLocals;
Var *resolvedVarPtr;
ResolverScheme *resPtr;
int result;
/*
* Initialize the array of local variables stored in the call frame.
* Some variables may have special resolution rules. In that case,
* we call their "resolver" procs to get our hands on the variable,
* and we make the compiled local a link to the real variable.
*/
for (localPtr = framePtr->procPtr->firstLocalPtr;
localPtr != NULL;
localPtr = localPtr->nextPtr) {
/*
* Check to see if this local is affected by namespace or
* interp resolvers. The resolver to use is cached for the
* next invocation of the procedure.
*/
if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED))
&& (nsPtr->compiledVarResProc || iPtr->resolverPtr)) {
resPtr = iPtr->resolverPtr;
if (nsPtr->compiledVarResProc) {
result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
localPtr->name, localPtr->nameLength,
(Tcl_Namespace *) nsPtr, &vinfo);
} else {
result = TCL_CONTINUE;
}
while ((result == TCL_CONTINUE) && resPtr) {
if (resPtr->compiledVarResProc) {
result = (*resPtr->compiledVarResProc)(nsPtr->interp,
localPtr->name, localPtr->nameLength,
(Tcl_Namespace *) nsPtr, &vinfo);
}
resPtr = resPtr->nextPtr;
}
if (result == TCL_OK) {
localPtr->resolveInfo = vinfo;
localPtr->flags |= VAR_RESOLVED;
}
}
/*
* Now invoke the resolvers to determine the exact variables that
* should be used.
*/
resVarInfo = localPtr->resolveInfo;
resolvedVarPtr = NULL;
if (resVarInfo && resVarInfo->fetchProc) {
resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
resVarInfo);
}
if (resolvedVarPtr) {
varPtr->name = localPtr->name; /* will be just '\0' if temp var */
varPtr->nsPtr = NULL;
varPtr->hPtr = NULL;
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
varPtr->flags = 0;
TclSetVarLink(varPtr);
varPtr->value.linkPtr = resolvedVarPtr;
resolvedVarPtr->refCount++;
} else {
varPtr->value.objPtr = NULL;
varPtr->name = localPtr->name; /* will be just '\0' if temp var */
varPtr->nsPtr = NULL;
varPtr->hPtr = NULL;
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
varPtr->flags = localPtr->flags;
}
varPtr++;
}
}
/*
*----------------------------------------------------------------------
*
* TclExpandCodeArray --
*
* Procedure that uses malloc to allocate more storage for a
* CompileEnv's code array.
*
* Results:
* None.
*
* Side effects:
* The byte code array in *envPtr is reallocated to a new array of
* double the size, and if envPtr->mallocedCodeArray is non-zero the
* old array is freed. Byte codes are copied from the old array to the
* new one.
*
*----------------------------------------------------------------------
*/
void
TclExpandCodeArray(envArgPtr)
void *envArgPtr; /* Points to the CompileEnv whose code array
* must be enlarged. */
{
CompileEnv *envPtr = (CompileEnv*) envArgPtr; /* Points to the CompileEnv whose code array
* must be enlarged. */
/*
* envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
* code bytes are stored between envPtr->codeStart and
* (envPtr->codeNext - 1) [inclusive].
*/
size_t currBytes = (envPtr->codeNext - envPtr->codeStart);
size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
/*
* Copy from old code array to new, free old code array if needed, and
* mark new code array as malloced.
*/
memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes);
if (envPtr->mallocedCodeArray) {
ckfree((char *) envPtr->codeStart);
}
envPtr->codeStart = newPtr;
envPtr->codeNext = (newPtr + currBytes);
envPtr->codeEnd = (newPtr + newBytes);
envPtr->mallocedCodeArray = 1;
}
/*
*----------------------------------------------------------------------
*
* EnterCmdStartData --
*
* Registers the starting source and bytecode location of a
* command. This information is used at runtime to map between
* instruction pc and source locations.
*
* Results:
* None.
*
* Side effects:
* Inserts source and code location information into the compilation
* environment envPtr for the command at index cmdIndex. The
* compilation environment's CmdLocation array is grown if necessary.
*
*----------------------------------------------------------------------
*/
static void
EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
CompileEnv *envPtr; /* Points to the compilation environment
* structure in which to enter command
* location information. */
int cmdIndex; /* Index of the command whose start data
* is being set. */
int srcOffset; /* Offset of first char of the command. */
int codeOffset; /* Offset of first byte of command code. */
{
CmdLocation *cmdLocPtr;
if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
}
if (cmdIndex >= envPtr->cmdMapEnd) {
/*
* Expand the command location array by allocating more storage from
* the heap. The currently allocated CmdLocation entries are stored
* from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
*/
size_t currElems = envPtr->cmdMapEnd;
size_t newElems = 2*currElems;
size_t currBytes = currElems * sizeof(CmdLocation);
size_t newBytes = newElems * sizeof(CmdLocation);
CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);
/*
* Copy from old command location array to new, free old command
* location array if needed, and mark new array as malloced.
*/
memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes);
if (envPtr->mallocedCmdMap) {
ckfree((char *) envPtr->cmdMapPtr);
}
envPtr->cmdMapPtr = (CmdLocation *) newPtr;
envPtr->cmdMapEnd = newElems;
envPtr->mallocedCmdMap = 1;
}
if (cmdIndex > 0) {
if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
panic("EnterCmdStartData: cmd map not sorted by code offset");
}
}
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->srcOffset = srcOffset;
cmdLocPtr->numSrcBytes = -1;
cmdLocPtr->numCodeBytes = -1;
}
/*
*----------------------------------------------------------------------
*
* EnterCmdExtentData --
*
* Registers the source and bytecode length for a command. This
* information is used at runtime to map between instruction pc and
* source locations.
*
* Results:
* None.
*
* Side effects:
* Inserts source and code length information into the compilation
* environment envPtr for the command at index cmdIndex. Starting
* source and bytecode information for the command must already
* have been registered.
*
*----------------------------------------------------------------------
*/
static void
EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes)
CompileEnv *envPtr; /* Points to the compilation environment
* structure in which to enter command
* location information. */
int cmdIndex; /* Index of the command whose source and
* code length data is being set. */
int numSrcBytes; /* Number of command source chars. */
int numCodeBytes; /* Offset of last byte of command code. */
{
CmdLocation *cmdLocPtr;
if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
panic("EnterCmdExtentData: bad command index %d\n", cmdIndex);
}
if (cmdIndex > envPtr->cmdMapEnd) {
panic("EnterCmdExtentData: missing start data for command %d\n",
cmdIndex);
}
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
cmdLocPtr->numSrcBytes = numSrcBytes;
cmdLocPtr->numCodeBytes = numCodeBytes;
}
#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
* TIP #280
*
* EnterCmdWordData --
*
* Registers the lines for the words of a command. This information
* is used at runtime by 'info frame'.
*
* Results:
* None.
*
* Side effects:
* Inserts word location information into the compilation
* environment envPtr for the command at index cmdIndex. The
* compilation environment's ExtCmdLoc.ECL array is grown if necessary.
*
*----------------------------------------------------------------------
*/
static void
EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, clNext, wlines, envPtr)
ExtCmdLoc *eclPtr; /* Points to the map environment
* structure in which to enter command
* location information. */
int srcOffset; /* Offset of first char of the command. */
Tcl_Token* tokenPtr;
CONST char* cmd;
int len;
int numWords;
int line;
int* clNext;
int** wlines;
CompileEnv* envPtr;
{
ECL* ePtr;
int wordIdx;
CONST char* last;
int wordLine;
int* wordNext;
int* wwlines;
if (eclPtr->nuloc >= eclPtr->nloc) {
/*
* Expand the ECL array by allocating more storage from the
* heap. The currently allocated ECL entries are stored from
* eclPtr->loc[0] up to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
*/
size_t currElems = eclPtr->nloc;
size_t newElems = (currElems ? 2*currElems : 1);
size_t currBytes = currElems * sizeof(ECL);
size_t newBytes = newElems * sizeof(ECL);
ECL * newPtr = (ECL *) ckalloc((unsigned) newBytes);
/*
* Copy from old ECL array to new, free old ECL array if
* needed.
*/
if (currBytes) {
memcpy((VOID *) newPtr, (VOID *) eclPtr->loc, currBytes);
}
if (eclPtr->loc != NULL) {
ckfree((char *) eclPtr->loc);
}
eclPtr->loc = (ECL *) newPtr;
eclPtr->nloc = newElems;
}
ePtr = &eclPtr->loc [eclPtr->nuloc];
ePtr->srcOffset = srcOffset;
ePtr->line = (int*) ckalloc (numWords * sizeof (int));
ePtr->next = (int**) ckalloc (numWords * sizeof (int*));
ePtr->nline = numWords;
wwlines = (int*) ckalloc (numWords * sizeof (int));
last = cmd;
wordLine = line;
wordNext = clNext;
for (wordIdx = 0;
wordIdx < numWords;
wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
TclAdvanceLines (&wordLine, last, tokenPtr->start);
TclAdvanceContinuations (&wordLine, &wordNext,
tokenPtr->start - envPtr->source);
wwlines [wordIdx] = (TclWordKnownAtCompileTime (tokenPtr)
? wordLine
: -1);
ePtr->line [wordIdx] = wordLine;
ePtr->next [wordIdx] = wordNext;
last = tokenPtr->start;
}
*wlines = wwlines;
eclPtr->nuloc ++;
}
#endif
/*
*----------------------------------------------------------------------
*
* TclCreateExceptRange --
*
* Procedure that allocates and initializes a new ExceptionRange
* structure of the specified kind in a CompileEnv.
*
* Results:
* Returns the index for the newly created ExceptionRange.
*
* Side effects:
* If there is not enough room in the CompileEnv's ExceptionRange
* array, the array in expanded: a new array of double the size is
* allocated, if envPtr->mallocedExceptArray is non-zero the old
* array is freed, and ExceptionRange entries are copied from the old
* array to the new one.
*
*----------------------------------------------------------------------
*/
int
TclCreateExceptRange(type, envPtr)
ExceptionRangeType type; /* The kind of ExceptionRange desired. */
register CompileEnv *envPtr;/* Points to CompileEnv for which to
* create a new ExceptionRange structure. */
{
register ExceptionRange *rangePtr;
int index = envPtr->exceptArrayNext;
if (index >= envPtr->exceptArrayEnd) {
/*
* Expand the ExceptionRange array. The currently allocated entries
* are stored between elements 0 and (envPtr->exceptArrayNext - 1)
* [inclusive].
*/
size_t currBytes =
envPtr->exceptArrayNext * sizeof(ExceptionRange);
int newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
ExceptionRange *newPtr = (ExceptionRange *)
ckalloc((unsigned) newBytes);
/*
* Copy from old ExceptionRange array to new, free old
* ExceptionRange array if needed, and mark the new ExceptionRange
* array as malloced.
*/
memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr,
currBytes);
if (envPtr->mallocedExceptArray) {
ckfree((char *) envPtr->exceptArrayPtr);
}
envPtr->exceptArrayPtr = (ExceptionRange *) newPtr;
envPtr->exceptArrayEnd = newElems;
envPtr->mallocedExceptArray = 1;
}
envPtr->exceptArrayNext++;
rangePtr = &(envPtr->exceptArrayPtr[index]);
rangePtr->type = type;
rangePtr->nestingLevel = envPtr->exceptDepth;
rangePtr->codeOffset = -1;
rangePtr->numCodeBytes = -1;
rangePtr->breakOffset = -1;
rangePtr->continueOffset = -1;
rangePtr->catchOffset = -1;
return index;
}
/*
*----------------------------------------------------------------------
*
* TclCreateAuxData --
*
* Procedure that allocates and initializes a new AuxData structure in
* a CompileEnv's array of compilation auxiliary data records. These
* AuxData records hold information created during compilation by
* CompileProcs and used by instructions during execution.
*
* Results:
* Returns the index for the newly created AuxData structure.
*
* Side effects:
* If there is not enough room in the CompileEnv's AuxData array,
* the AuxData array in expanded: a new array of double the size
* is allocated, if envPtr->mallocedAuxDataArray is non-zero
* the old array is freed, and AuxData entries are copied from
* the old array to the new one.
*
*----------------------------------------------------------------------
*/
int
TclCreateAuxData(clientData, typePtr, envPtr)
ClientData clientData; /* The compilation auxiliary data to store
* in the new aux data record. */
AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */
register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
* aux data structure is to be allocated. */
{
int index; /* Index for the new AuxData structure. */
register AuxData *auxDataPtr;
/* Points to the new AuxData structure */
index = envPtr->auxDataArrayNext;
if (index >= envPtr->auxDataArrayEnd) {
/*
* Expand the AuxData array. The currently allocated entries are
* stored between elements 0 and (envPtr->auxDataArrayNext - 1)
* [inclusive].
*/
size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
int newElems = 2*envPtr->auxDataArrayEnd;
size_t newBytes = newElems * sizeof(AuxData);
AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
/*
* Copy from old AuxData array to new, free old AuxData array if
* needed, and mark the new AuxData array as malloced.
*/
memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr,
currBytes);
if (envPtr->mallocedAuxDataArray) {
ckfree((char *) envPtr->auxDataArrayPtr);
}
envPtr->auxDataArrayPtr = newPtr;
envPtr->auxDataArrayEnd = newElems;
envPtr->mallocedAuxDataArray = 1;
}
envPtr->auxDataArrayNext++;
auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
auxDataPtr->clientData = clientData;
auxDataPtr->type = typePtr;
return index;
}
/*
*----------------------------------------------------------------------
*
* TclInitJumpFixupArray --
*
* Initializes a JumpFixupArray structure to hold some number of
* jump fixup entries.
*
* Results:
* None.
*
* Side effects:
* The JumpFixupArray structure is initialized.
*
*----------------------------------------------------------------------
*/
void
TclInitJumpFixupArray(fixupArrayPtr)
register JumpFixupArray *fixupArrayPtr;
/* Points to the JumpFixupArray structure
* to initialize. */
{
fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
fixupArrayPtr->next = 0;
fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);
fixupArrayPtr->mallocedArray = 0;
}
/*
*----------------------------------------------------------------------
*
* TclExpandJumpFixupArray --
*
* Procedure that uses malloc to allocate more storage for a
* jump fixup array.
*
* Results:
* None.
*
* Side effects:
* The jump fixup array in *fixupArrayPtr is reallocated to a new array
* of double the size, and if fixupArrayPtr->mallocedArray is non-zero
* the old array is freed. Jump fixup structures are copied from the
* old array to the new one.
*
*----------------------------------------------------------------------
*/
void
TclExpandJumpFixupArray(fixupArrayPtr)
register JumpFixupArray *fixupArrayPtr;
/* Points to the JumpFixupArray structure
* to enlarge. */
{
/*
* The currently allocated jump fixup entries are stored from fixup[0]
* up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
* fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
int newElems = 2*(fixupArrayPtr->end + 1);
size_t newBytes = newElems * sizeof(JumpFixup);
JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
/*
* Copy from the old array to new, free the old array if needed,
* and mark the new array as malloced.
*/
memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes);
if (fixupArrayPtr->mallocedArray) {
ckfree((char *) fixupArrayPtr->fixup);
}
fixupArrayPtr->fixup = (JumpFixup *) newPtr;
fixupArrayPtr->end = newElems;
fixupArrayPtr->mallocedArray = 1;
}
/*
*----------------------------------------------------------------------
*
* TclFreeJumpFixupArray --
*
* Free any storage allocated in a jump fixup array structure.
*
* Results:
* None.
*
* Side effects:
* Allocated storage in the JumpFixupArray structure is freed.
*
*----------------------------------------------------------------------
*/
void
TclFreeJumpFixupArray(fixupArrayPtr)
register JumpFixupArray *fixupArrayPtr;
/* Points to the JumpFixupArray structure
* to free. */
{
if (fixupArrayPtr->mallocedArray) {
ckfree((char *) fixupArrayPtr->fixup);
}
}
/*
*----------------------------------------------------------------------
*
* TclEmitForwardJump --
*
* Procedure to emit a two-byte forward jump of kind "jumpType". Since
* the jump may later have to be grown to five bytes if the jump target
* is more than, say, 127 bytes away, this procedure also initializes a
* JumpFixup record with information about the jump.
*
* Results:
* None.
*
* Side effects:
* The JumpFixup record pointed to by "jumpFixupPtr" is initialized
* with information needed later if the jump is to be grown. Also,
* a two byte jump of the designated type is emitted at the current
* point in the bytecode stream.
*
*----------------------------------------------------------------------
*/
void
TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
CompileEnv *envPtr; /* Points to the CompileEnv structure that
* holds the resulting instruction. */
TclJumpType jumpType; /* Indicates the kind of jump: if true or
* false or unconditional. */
JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to
* initialize with information about this
* forward jump. */
{
/*
* Initialize the JumpFixup structure:
* - codeOffset is offset of first byte of jump below
* - cmdIndex is index of the command after the current one
* - exceptIndex is the index of the first ExceptionRange after
* the current one.
*/
jumpFixupPtr->jumpType = jumpType;
jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart);
jumpFixupPtr->cmdIndex = envPtr->numCommands;
jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;
switch (jumpType) {
case TCL_UNCONDITIONAL_JUMP:
TclEmitInstInt1(INST_JUMP1, 0, envPtr);
break;
case TCL_TRUE_JUMP:
TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr);
break;
default:
TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
break;
}
}
/*
*----------------------------------------------------------------------
*
* TclFixupForwardJump --
*
* Procedure that updates a previously-emitted forward jump to jump
* a specified number of bytes, "jumpDist". If necessary, the jump is
* grown from two to five bytes; this is done if the jump distance is
* greater than "distThreshold" (normally 127 bytes). The jump is
* described by a JumpFixup record previously initialized by
* TclEmitForwardJump.
*
* Results:
* 1 if the jump was grown and subsequent instructions had to be moved;
* otherwise 0. This result is returned to allow callers to update
* any additional code offsets they may hold.
*
* Side effects:
* The jump may be grown and subsequent instructions moved. If this
* happens, the code offsets for any commands and any ExceptionRange
* records between the jump and the current code address will be
* updated to reflect the moved code. Also, the bytecode instruction
* array in the CompileEnv structure may be grown and reallocated.
*
*----------------------------------------------------------------------
*/
int
TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
CompileEnv *envPtr; /* Points to the CompileEnv structure that
* holds the resulting instruction. */
JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that
* describes the forward jump. */
int jumpDist; /* Jump distance to set in jump
* instruction. */
int distThreshold; /* Maximum distance before the two byte
* jump is grown to five bytes. */
{
unsigned char *jumpPc, *p;
int firstCmd, lastCmd, firstRange, lastRange, k;
unsigned int numBytes;
if (jumpDist <= distThreshold) {
jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
switch (jumpFixupPtr->jumpType) {
case TCL_UNCONDITIONAL_JUMP:
TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
break;
case TCL_TRUE_JUMP:
TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);
break;
default:
TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
break;
}
return 0;
}
/*
* We must grow the jump then move subsequent instructions down.
* Note that if we expand the space for generated instructions,
* code addresses might change; be careful about updating any of
* these addresses held in variables.
*/
if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
TclExpandCodeArray(envPtr);
}
jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
numBytes = envPtr->codeNext-jumpPc-2;
p = jumpPc+2;
memmove(p+3, p, numBytes);
envPtr->codeNext += 3;
jumpDist += 3;
switch (jumpFixupPtr->jumpType) {
case TCL_UNCONDITIONAL_JUMP:
TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);
break;
case TCL_TRUE_JUMP:
TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);
break;
default:
TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
break;
}
/*
* Adjust the code offsets for any commands and any ExceptionRange
* records between the jump and the current code address.
*/
firstCmd = jumpFixupPtr->cmdIndex;
lastCmd = (envPtr->numCommands - 1);
if (firstCmd < lastCmd) {
for (k = firstCmd; k <= lastCmd; k++) {
(envPtr->cmdMapPtr[k]).codeOffset += 3;
}
}
firstRange = jumpFixupPtr->exceptIndex;
lastRange = (envPtr->exceptArrayNext - 1);
for (k = firstRange; k <= lastRange; k++) {
ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]);
rangePtr->codeOffset += 3;
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
rangePtr->breakOffset += 3;
if (rangePtr->continueOffset != -1) {
rangePtr->continueOffset += 3;
}
break;
case CATCH_EXCEPTION_RANGE:
rangePtr->catchOffset += 3;
break;
default:
panic("TclFixupForwardJump: bad ExceptionRange type %d\n",
rangePtr->type);
}
}
return 1; /* the jump was grown */
}
/*
*----------------------------------------------------------------------
*
* TclGetInstructionTable --
*
* Returns a pointer to the table describing Tcl bytecode instructions.
* This procedure is defined so that clients can access the pointer from
* outside the TCL DLLs.
*
* Results:
* Returns a pointer to the global instruction table, same as the
* expression (&tclInstructionTable[0]).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void * /* == InstructionDesc* == */
TclGetInstructionTable()
{
return &tclInstructionTable[0];
}
/*
*--------------------------------------------------------------
*
* TclRegisterAuxDataType --
*
* This procedure is called to register a new AuxData type
* in the table of all AuxData types supported by Tcl.
*
* Results:
* None.
*
* Side effects:
* The type is registered in the AuxData type table. If there was already
* a type with the same name as in typePtr, it is replaced with the
* new type.
*
*--------------------------------------------------------------
*/
void
TclRegisterAuxDataType(typePtr)
AuxDataType *typePtr; /* Information about object type;
* storage must be statically
* allocated (must live forever). */
{
register Tcl_HashEntry *hPtr;
int new;
Tcl_MutexLock(&tableMutex);
if (!auxDataTypeTableInitialized) {
TclInitAuxDataTypeTable();
}
/*
* If there's already a type with the given name, remove it.
*/
hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name);
if (hPtr != (Tcl_HashEntry *) NULL) {
Tcl_DeleteHashEntry(hPtr);
}
/*
* Now insert the new object type.
*/
hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new);
if (new) {
Tcl_SetHashValue(hPtr, typePtr);
}
Tcl_MutexUnlock(&tableMutex);
}
/*
*----------------------------------------------------------------------
*
* TclGetAuxDataType --
*
* This procedure looks up an Auxdata type by name.
*
* Results:
* If an AuxData type with name matching "typeName" is found, a pointer
* to its AuxDataType structure is returned; otherwise, NULL is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
AuxDataType *
TclGetAuxDataType(typeName)
char *typeName; /* Name of AuxData type to look up. */
{
register Tcl_HashEntry *hPtr;
AuxDataType *typePtr = NULL;
Tcl_MutexLock(&tableMutex);
if (!auxDataTypeTableInitialized) {
TclInitAuxDataTypeTable();
}
hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName);
if (hPtr != (Tcl_HashEntry *) NULL) {
typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
return typePtr;
}
/*
*--------------------------------------------------------------
*
* TclInitAuxDataTypeTable --
*
* This procedure is invoked to perform once-only initialization of
* the AuxData type table. It also registers the AuxData types defined in
* this file.
*
* Results:
* None.
*
* Side effects:
* Initializes the table of defined AuxData types "auxDataTypeTable" with
* builtin AuxData types defined in this file.
*
*--------------------------------------------------------------
*/
void
TclInitAuxDataTypeTable()
{
/*
* The table mutex must already be held before this routine is invoked.
*/
auxDataTypeTableInitialized = 1;
Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
/*
* There is only one AuxData type at this time, so register it here.
*/
TclRegisterAuxDataType(&tclForeachInfoType);
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeAuxDataTypeTable --
*
* This procedure is called by Tcl_Finalize after all exit handlers
* have been run to free up storage associated with the table of AuxData
* types. This procedure is called by TclFinalizeExecution() which
* is called by Tcl_Finalize().
*
* Results:
* None.
*
* Side effects:
* Deletes all entries in the hash table of AuxData types.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeAuxDataTypeTable()
{
Tcl_MutexLock(&tableMutex);
if (auxDataTypeTableInitialized) {
Tcl_DeleteHashTable(&auxDataTypeTable);
auxDataTypeTableInitialized = 0;
}
Tcl_MutexUnlock(&tableMutex);
}
/*
*----------------------------------------------------------------------
*
* GetCmdLocEncodingSize --
*
* Computes the total number of bytes needed to encode the command
* location information for some compiled code.
*
* Results:
* The byte count needed to encode the compiled location information.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
GetCmdLocEncodingSize(envPtr)
CompileEnv *envPtr; /* Points to compilation environment
* structure containing the CmdLocation
* structure to encode. */
{
register CmdLocation *mapPtr = envPtr->cmdMapPtr;
int numCmds = envPtr->numCommands;
int codeDelta, codeLen, srcDelta, srcLen;
int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
/* The offsets in their respective byte
* sequences where the next encoded offset
* or length should go. */
int prevCodeOffset, prevSrcOffset, i;
codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
prevCodeOffset = prevSrcOffset = 0;
for (i = 0; i < numCmds; i++) {
codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
if (codeDelta < 0) {
panic("GetCmdLocEncodingSize: bad code offset");
} else if (codeDelta <= 127) {
codeDeltaNext++;
} else {
codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
}
prevCodeOffset = mapPtr[i].codeOffset;
codeLen = mapPtr[i].numCodeBytes;
if (codeLen < 0) {
panic("GetCmdLocEncodingSize: bad code length");
} else if (codeLen <= 127) {
codeLengthNext++;
} else {
codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
}
srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
if ((-127 <= srcDelta) && (srcDelta <= 127)) {
srcDeltaNext++;
} else {
srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
}
prevSrcOffset = mapPtr[i].srcOffset;
srcLen = mapPtr[i].numSrcBytes;
if (srcLen < 0) {
panic("GetCmdLocEncodingSize: bad source length");
} else if (srcLen <= 127) {
srcLengthNext++;
} else {
srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
}
}
return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
}
/*
*----------------------------------------------------------------------
*
* EncodeCmdLocMap --
*
* Encode the command location information for some compiled code into
* a ByteCode structure. The encoded command location map is stored as
* three adjacent byte sequences.
*
* Results:
* Pointer to the first byte after the encoded command location
* information.
*
* Side effects:
* The encoded information is stored into the block of memory headed
* by codePtr. Also records pointers to the start of the four byte
* sequences in fields in codePtr's ByteCode header structure.
*
*----------------------------------------------------------------------
*/
static unsigned char *
EncodeCmdLocMap(envPtr, codePtr, startPtr)
CompileEnv *envPtr; /* Points to compilation environment
* structure containing the CmdLocation
* structure to encode. */
ByteCode *codePtr; /* ByteCode in which to encode envPtr's
* command location information. */
unsigned char *startPtr; /* Points to the first byte in codePtr's
* memory block where the location
* information is to be stored. */
{
register CmdLocation *mapPtr = envPtr->cmdMapPtr;
int numCmds = envPtr->numCommands;
register unsigned char *p = startPtr;
int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
register int i;
/*
* Encode the code offset for each command as a sequence of deltas.
*/
codePtr->codeDeltaStart = p;
prevOffset = 0;
for (i = 0; i < numCmds; i++) {
codeDelta = (mapPtr[i].codeOffset - prevOffset);
if (codeDelta < 0) {
panic("EncodeCmdLocMap: bad code offset");
} else if (codeDelta <= 127) {
TclStoreInt1AtPtr(codeDelta, p);
p++;
} else {
TclStoreInt1AtPtr(0xFF, p);
p++;
TclStoreInt4AtPtr(codeDelta, p);
p += 4;
}
prevOffset = mapPtr[i].codeOffset;
}
/*
* Encode the code length for each command.
*/
codePtr->codeLengthStart = p;
for (i = 0; i < numCmds; i++) {
codeLen = mapPtr[i].numCodeBytes;
if (codeLen < 0) {
panic("EncodeCmdLocMap: bad code length");
} else if (codeLen <= 127) {
TclStoreInt1AtPtr(codeLen, p);
p++;
} else {
TclStoreInt1AtPtr(0xFF, p);
p++;
TclStoreInt4AtPtr(codeLen, p);
p += 4;
}
}
/*
* Encode the source offset for each command as a sequence of deltas.
*/
codePtr->srcDeltaStart = p;
prevOffset = 0;
for (i = 0; i < numCmds; i++) {
srcDelta = (mapPtr[i].srcOffset - prevOffset);
if ((-127 <= srcDelta) && (srcDelta <= 127)) {
TclStoreInt1AtPtr(srcDelta, p);
p++;
} else {
TclStoreInt1AtPtr(0xFF, p);
p++;
TclStoreInt4AtPtr(srcDelta, p);
p += 4;
}
prevOffset = mapPtr[i].srcOffset;
}
/*
* Encode the source length for each command.
*/
codePtr->srcLengthStart = p;
for (i = 0; i < numCmds; i++) {
srcLen = mapPtr[i].numSrcBytes;
if (srcLen < 0) {
panic("EncodeCmdLocMap: bad source length");
} else if (srcLen <= 127) {
TclStoreInt1AtPtr(srcLen, p);
p++;
} else {
TclStoreInt1AtPtr(0xFF, p);
p++;
TclStoreInt4AtPtr(srcLen, p);
p += 4;
}
}
return p;
}
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
* TclPrintByteCodeObj --
*
* This procedure prints ("disassembles") the instructions of a
* bytecode object to stdout.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclPrintByteCodeObj(interp, objPtr)
Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */
Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
{
ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
if (codePtr->refCount <= 0) {
return; /* already freed */
}
codeStart = codePtr->codeStart;
codeLimit = (codeStart + codePtr->numCodeBytes);
numCmds = codePtr->numCommands;
/*
* Print header lines describing the ByteCode.
*/
fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
(unsigned int) codePtr, codePtr->refCount,
codePtr->compileEpoch, (unsigned int) iPtr,
iPtr->compileEpoch);
fprintf(stdout, " Source ");
TclPrintSource(stdout, codePtr->source,
TclMin(codePtr->numSrcBytes, 55));
fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
codePtr->numLitObjects, codePtr->numAuxDataItems,
codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
(codePtr->numSrcBytes?
((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
#else
0.0);
#endif
#ifdef TCL_COMPILE_STATS
fprintf(stdout,
" Code %u = header %u+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
(unsigned int)codePtr->structureSize,
(unsigned int)(sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
codePtr->numCodeBytes,
(unsigned long)(codePtr->numLitObjects * sizeof(Tcl_Obj *)),
(unsigned long)(codePtr->numExceptRanges * sizeof(ExceptionRange)),
(unsigned long)(codePtr->numAuxDataItems * sizeof(AuxData)),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
/*
* If the ByteCode is the compiled body of a Tcl procedure, print
* information about that procedure. Note that we don't know the
* procedure's name since ByteCode's can be shared among procedures.
*/
if (codePtr->procPtr != NULL) {
Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
fprintf(stdout,
" Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
(unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
numCompiledLocals);
if (numCompiledLocals > 0) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
for (i = 0; i < numCompiledLocals; i++) {
fprintf(stdout, " slot %d%s%s%s%s%s%s", i,
((localPtr->flags & VAR_SCALAR)? ", scalar" : ""),
((localPtr->flags & VAR_ARRAY)? ", array" : ""),
((localPtr->flags & VAR_LINK)? ", link" : ""),
((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""),
((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""),
((localPtr->flags & VAR_RESOLVED)? ", resolved" : ""));
if (TclIsVarTemporary(localPtr)) {
fprintf(stdout, "\n");
} else {
fprintf(stdout, ", \"%s\"\n", localPtr->name);
}
localPtr = localPtr->nextPtr;
}
}
}
/*
* Print the ExceptionRange array.
*/
if (codePtr->numExceptRanges > 0) {
fprintf(stdout, " Exception ranges %d, depth %d:\n",
codePtr->numExceptRanges, codePtr->maxExceptDepth);
for (i = 0; i < codePtr->numExceptRanges; i++) {
ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
i, rangePtr->nestingLevel,
((rangePtr->type == LOOP_EXCEPTION_RANGE)
? "loop" : "catch"),
rangePtr->codeOffset,
(rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
fprintf(stdout, "continue %d, break %d\n",
rangePtr->continueOffset, rangePtr->breakOffset);
break;
case CATCH_EXCEPTION_RANGE:
fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
break;
default:
panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n",
rangePtr->type);
}
}
}
/*
* If there were no commands (e.g., an expression or an empty string
* was compiled), just print all instructions and return.
*/
if (numCmds == 0) {
pc = codeStart;
while (pc < codeLimit) {
fprintf(stdout, " ");
pc += TclPrintInstruction(codePtr, pc);
}
return;
}
/*
* Print table showing the code offset, source offset, and source
* length for each command. These are encoded as a sequence of bytes.
*/
fprintf(stdout, " Commands %d:", numCmds);
codeDeltaNext = codePtr->codeDeltaStart;
codeLengthNext = codePtr->codeLengthStart;
srcDeltaNext = codePtr->srcDeltaStart;
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset = 0;
for (i = 0; i < numCmds; i++) {
if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
codeDeltaNext++;
delta = TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(codeDeltaNext);
codeDeltaNext++;
}
codeOffset += delta;
if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
codeLengthNext++;
codeLen = TclGetInt4AtPtr(codeLengthNext);
codeLengthNext += 4;
} else {
codeLen = TclGetInt1AtPtr(codeLengthNext);
codeLengthNext++;
}
if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
srcDeltaNext++;
delta = TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(srcDeltaNext);
srcDeltaNext++;
}
srcOffset += delta;
if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
srcLengthNext++;
srcLen = TclGetInt4AtPtr(srcLengthNext);
srcLengthNext += 4;
} else {
srcLen = TclGetInt1AtPtr(srcLengthNext);
srcLengthNext++;
}
fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d",
((i % 2)? " " : "\n "),
(i+1), codeOffset, (codeOffset + codeLen - 1),
srcOffset, (srcOffset + srcLen - 1));
}
if (numCmds > 0) {
fprintf(stdout, "\n");
}
/*
* Print each instruction. If the instruction corresponds to the start
* of a command, print the command's source. Note that we don't need
* the code length here.
*/
codeDeltaNext = codePtr->codeDeltaStart;
srcDeltaNext = codePtr->srcDeltaStart;
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset = 0;
pc = codeStart;
for (i = 0; i < numCmds; i++) {
if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
codeDeltaNext++;
delta = TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(codeDeltaNext);
codeDeltaNext++;
}
codeOffset += delta;
if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
srcDeltaNext++;
delta = TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(srcDeltaNext);
srcDeltaNext++;
}
srcOffset += delta;
if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
srcLengthNext++;
srcLen = TclGetInt4AtPtr(srcLengthNext);
srcLengthNext += 4;
} else {
srcLen = TclGetInt1AtPtr(srcLengthNext);
srcLengthNext++;
}
/*
* Print instructions before command i.
*/
while ((pc-codeStart) < codeOffset) {
fprintf(stdout, " ");
pc += TclPrintInstruction(codePtr, pc);
}
fprintf(stdout, " Command %d: ", (i+1));
TclPrintSource(stdout, (codePtr->source + srcOffset),
TclMin(srcLen, 55));
fprintf(stdout, "\n");
}
if (pc < codeLimit) {
/*
* Print instructions after the last command.
*/
while (pc < codeLimit) {
fprintf(stdout, " ");
pc += TclPrintInstruction(codePtr, pc);
}
}
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* TclPrintInstruction --
*
* This procedure prints ("disassembles") one instruction from a
* bytecode object to stdout.
*
* Results:
* Returns the length in bytes of the current instruiction.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclPrintInstruction(codePtr, pc)
ByteCode* codePtr; /* Bytecode containing the instruction. */
unsigned char *pc; /* Points to first byte of instruction. */
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
register InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned int pcOffset = (pc - codeStart);
int opnd, i, j;
fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
for (i = 0; i < instDesc->numOperands; i++) {
switch (instDesc->opTypes[i]) {
case OPERAND_INT1:
opnd = TclGetInt1AtPtr(pc+1+i);
if ((i == 0) && ((opCode == INST_JUMP1)
|| (opCode == INST_JUMP_TRUE1)
|| (opCode == INST_JUMP_FALSE1))) {
fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
} else {
fprintf(stdout, "%d", opnd);
}
break;
case OPERAND_INT4:
opnd = TclGetInt4AtPtr(pc+1+i);
if ((i == 0) && ((opCode == INST_JUMP4)
|| (opCode == INST_JUMP_TRUE4)
|| (opCode == INST_JUMP_FALSE4))) {
fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
} else {
fprintf(stdout, "%d", opnd);
}
break;
case OPERAND_UINT1:
opnd = TclGetUInt1AtPtr(pc+1+i);
if ((i == 0) && (opCode == INST_PUSH1)) {
fprintf(stdout, "%u # ", (unsigned int) opnd);
TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
} else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)
|| (opCode == INST_LOAD_ARRAY1)
|| (opCode == INST_STORE_SCALAR1)
|| (opCode == INST_STORE_ARRAY1))) {
int localCt = procPtr->numCompiledLocals;
CompiledLocal *localPtr = procPtr->firstLocalPtr;
if (opnd >= localCt) {
panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
(unsigned int) opnd, localCt);
return instDesc->numBytes;
}
for (j = 0; j < opnd; j++) {
localPtr = localPtr->nextPtr;
}
if (TclIsVarTemporary(localPtr)) {
fprintf(stdout, "%u # temp var %u",
(unsigned int) opnd, (unsigned int) opnd);
} else {
fprintf(stdout, "%u # var ", (unsigned int) opnd);
TclPrintSource(stdout, localPtr->name, 40);
}
} else {
fprintf(stdout, "%u ", (unsigned int) opnd);
}
break;
case OPERAND_UINT4:
opnd = TclGetUInt4AtPtr(pc+1+i);
if (opCode == INST_PUSH4) {
fprintf(stdout, "%u # ", opnd);
TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
} else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
|| (opCode == INST_LOAD_ARRAY4)
|| (opCode == INST_STORE_SCALAR4)
|| (opCode == INST_STORE_ARRAY4))) {
int localCt = procPtr->numCompiledLocals;
CompiledLocal *localPtr = procPtr->firstLocalPtr;
if (opnd >= localCt) {
panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
(unsigned int) opnd, localCt);
return instDesc->numBytes;
}
for (j = 0; j < opnd; j++) {
localPtr = localPtr->nextPtr;
}
if (TclIsVarTemporary(localPtr)) {
fprintf(stdout, "%u # temp var %u",
(unsigned int) opnd, (unsigned int) opnd);
} else {
fprintf(stdout, "%u # var ", (unsigned int) opnd);
TclPrintSource(stdout, localPtr->name, 40);
}
} else {
fprintf(stdout, "%u ", (unsigned int) opnd);
}
break;
case OPERAND_NONE:
default:
break;
}
}
fprintf(stdout, "\n");
return instDesc->numBytes;
}
/*
*----------------------------------------------------------------------
*
* TclPrintObject --
*
* This procedure prints up to a specified number of characters from
* the argument Tcl object's string representation to a specified file.
*
* Results:
* None.
*
* Side effects:
* Outputs characters to the specified file.
*
*----------------------------------------------------------------------
*/
void
TclPrintObject(outFile, objPtr, maxChars)
FILE *outFile; /* The file to print the source to. */
Tcl_Obj *objPtr; /* Points to the Tcl object whose string
* representation should be printed. */
int maxChars; /* Maximum number of chars to print. */
{
char *bytes;
int length;
bytes = Tcl_GetStringFromObj(objPtr, &length);
TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
/*
*----------------------------------------------------------------------
*
* TclPrintSource --
*
* This procedure prints up to a specified number of characters from
* the argument string to a specified file. It tries to produce legible
* output by adding backslashes as necessary.
*
* Results:
* None.
*
* Side effects:
* Outputs characters to the specified file.
*
*----------------------------------------------------------------------
*/
void
TclPrintSource(outFile, string, maxChars)
FILE *outFile; /* The file to print the source to. */
CONST char *string; /* The string to print. */
int maxChars; /* Maximum number of chars to print. */
{
register CONST char *p;
register int i = 0;
if (string == NULL) {
fprintf(outFile, "\"\"");
return;
}
fprintf(outFile, "\"");
p = string;
for (; (*p != '\0') && (i < maxChars); p++, i++) {
switch (*p) {
case '"':
fprintf(outFile, "\\\"");
continue;
case '\f':
fprintf(outFile, "\\f");
continue;
case '\n':
fprintf(outFile, "\\n");
continue;
case '\r':
fprintf(outFile, "\\r");
continue;
case '\t':
fprintf(outFile, "\\t");
continue;
case '\v':
fprintf(outFile, "\\v");
continue;
default:
fprintf(outFile, "%c", *p);
continue;
}
}
fprintf(outFile, "\"");
}
#ifdef TCL_COMPILE_STATS
/*
*----------------------------------------------------------------------
*
* RecordByteCodeStats --
*
* Accumulates various compilation-related statistics for each newly
* compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is
* compiled with the -DTCL_COMPILE_STATS flag
*
* Results:
* None.
*
* Side effects:
* Accumulates aggregate code-related statistics in the interpreter's
* ByteCodeStats structure. Records statistics specific to a ByteCode
* in its ByteCode structure.
*
*----------------------------------------------------------------------
*/
void
RecordByteCodeStats(codePtr)
ByteCode *codePtr; /* Points to ByteCode structure with info
* to add to accumulated statistics. */
{
Interp *iPtr = (Interp *) *codePtr->interpHandle;
register ByteCodeStats *statsPtr = &(iPtr->stats);
if (iPtr == NULL) {
/* Avoid segfaulting in case we're called in a deleted interp */
return;
}
statsPtr->numCompilations++;
statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
statsPtr->totalByteCodeBytes += (double) codePtr->structureSize;
statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes;
statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;
statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++;
statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
statsPtr->currentLitBytes +=
(double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
statsPtr->currentExceptBytes +=
(double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
statsPtr->currentAuxBytes +=
(double) (codePtr->numAuxDataItems * sizeof(AuxData));
statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
}
#endif /* TCL_COMPILE_STATS */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclRegexp.c 0000644 0036047 0045461 00000072716 11737050674 014451 0 ustar dgp 771div /*
* tclRegexp.c --
*
* This file contains the public interfaces to the Tcl regular
* expression mechanism.
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"
/*
*----------------------------------------------------------------------
* The routines in this file use Henry Spencer's regular expression
* package contained in the following additional source files:
*
* regc_color.c regc_cvec.c regc_lex.c
* regc_nfa.c regcomp.c regcustom.h
* rege_dfa.c regerror.c regerrs.h
* regex.h regexec.c regfree.c
* regfronts.c regguts.h
*
* Copyright (c) 1998 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* *** NOTE: this code has been altered slightly for use in Tcl: ***
* *** 1. Names have been changed, e.g. from re_comp to ***
* *** TclRegComp, to avoid clashes with other ***
* *** regexp implementations used by applications. ***
*/
/*
* Thread local storage used to maintain a per-thread cache of compiled
* regular expressions.
*/
#define NUM_REGEXPS 30
typedef struct ThreadSpecificData {
int initialized; /* Set to 1 when the module is initialized. */
char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled
* regular expression patterns. NULL
* means that this slot isn't used.
* Malloc-ed. */
int patLengths[NUM_REGEXPS];/* Number of non-null characters in
* corresponding entry in patterns.
* -1 means entry isn't used. */
struct TclRegexp *regexps[NUM_REGEXPS];
/* Compiled forms of above strings. Also
* malloc-ed, or NULL if not in use yet. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Declarations for functions used only in this file.
*/
static TclRegexp * CompileRegexp _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *pattern, int length, int flags));
static void DupRegexpInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static void FinalizeRegexp _ANSI_ARGS_((ClientData clientData));
static void FreeRegexp _ANSI_ARGS_((TclRegexp *regexpPtr));
static void FreeRegexpInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int RegExpExecUniChar _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_RegExp re, CONST Tcl_UniChar *uniString,
int numChars, int nmatches, int flags));
static int SetRegexpFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
/*
* The regular expression Tcl object type. This serves as a cache
* of the compiled form of the regular expression.
*/
static Tcl_ObjType tclRegexpType = {
"regexp", /* name */
FreeRegexpInternalRep, /* freeIntRepProc */
DupRegexpInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetRegexpFromAny /* setFromAnyProc */
};
/*
*----------------------------------------------------------------------
*
* Tcl_RegExpCompile --
*
* Compile a regular expression into a form suitable for fast
* matching. This procedure is DEPRECATED in favor of the
* object version of the command.
*
* Results:
* The return value is a pointer to the compiled form of string,
* suitable for passing to Tcl_RegExpExec. This compiled form
* is only valid up until the next call to this procedure, so
* don't keep these around for a long time! If an error occurred
* while compiling the pattern, then NULL is returned and an error
* message is left in the interp's result.
*
* Side effects:
* Updates the cache of compiled regexps.
*
*----------------------------------------------------------------------
*/
Tcl_RegExp
Tcl_RegExpCompile(interp, string)
Tcl_Interp *interp; /* For use in error reporting and
* to access the interp regexp cache. */
CONST char *string; /* String for which to produce
* compiled regular expression. */
{
return (Tcl_RegExp) CompileRegexp(interp, string, (int) strlen(string),
REG_ADVANCED);
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegExpExec --
*
* Execute the regular expression matcher using a compiled form
* of a regular expression and save information about any match
* that is found.
*
* Results:
* If an error occurs during the matching operation then -1
* is returned and the interp's result contains an error message.
* Otherwise the return value is 1 if a matching range is
* found and 0 if there is no matching range.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_RegExpExec(interp, re, string, start)
Tcl_Interp *interp; /* Interpreter to use for error reporting. */
Tcl_RegExp re; /* Compiled regular expression; must have
* been returned by previous call to
* Tcl_GetRegExpFromObj. */
CONST char *string; /* String against which to match re. */
CONST char *start; /* If string is part of a larger string,
* this identifies beginning of larger
* string, so that "^" won't match. */
{
int flags, result, numChars;
TclRegexp *regexp = (TclRegexp *)re;
Tcl_DString ds;
CONST Tcl_UniChar *ustr;
/*
* If the starting point is offset from the beginning of the buffer,
* then we need to tell the regexp engine not to match "^".
*/
if (string > start) {
flags = REG_NOTBOL;
} else {
flags = 0;
}
/*
* Remember the string for use by Tcl_RegExpRange().
*/
regexp->string = string;
regexp->objPtr = NULL;
/*
* Convert the string to Unicode and perform the match.
*/
Tcl_DStringInit(&ds);
ustr = Tcl_UtfToUniCharDString(string, -1, &ds);
numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar);
result = RegExpExecUniChar(interp, re, ustr, numChars,
-1 /* nmatches */, flags);
Tcl_DStringFree(&ds);
return result;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_RegExpRange --
*
* Returns pointers describing the range of a regular expression match,
* or one of the subranges within the match.
*
* Results:
* The variables at *startPtr and *endPtr are modified to hold the
* addresses of the endpoints of the range given by index. If the
* specified range doesn't exist then NULLs are returned.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
void
Tcl_RegExpRange(re, index, startPtr, endPtr)
Tcl_RegExp re; /* Compiled regular expression that has
* been passed to Tcl_RegExpExec. */
int index; /* 0 means give the range of the entire
* match, > 0 means give the range of
* a matching subrange. */
CONST char **startPtr; /* Store address of first character in
* (sub-) range here. */
CONST char **endPtr; /* Store address of character just after last
* in (sub-) range here. */
{
TclRegexp *regexpPtr = (TclRegexp *) re;
CONST char *string;
if ((size_t) index > regexpPtr->re.re_nsub) {
*startPtr = *endPtr = NULL;
} else if (regexpPtr->matches[index].rm_so < 0) {
*startPtr = *endPtr = NULL;
} else {
if (regexpPtr->objPtr) {
string = Tcl_GetString(regexpPtr->objPtr);
} else {
string = regexpPtr->string;
}
*startPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_so);
*endPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_eo);
}
}
/*
*---------------------------------------------------------------------------
*
* RegExpExecUniChar --
*
* Execute the regular expression matcher using a compiled form of a
* regular expression and save information about any match that is
* found.
*
* Results:
* If an error occurs during the matching operation then -1 is
* returned and an error message is left in interp's result.
* Otherwise the return value is 1 if a matching range was found or
* 0 if there was no matching range.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
RegExpExecUniChar(interp, re, wString, numChars, nmatches, flags)
Tcl_Interp *interp; /* Interpreter to use for error reporting. */
Tcl_RegExp re; /* Compiled regular expression; returned by
* a previous call to Tcl_GetRegExpFromObj */
CONST Tcl_UniChar *wString; /* String against which to match re. */
int numChars; /* Length of Tcl_UniChar string (must
* be >= 0). */
int nmatches; /* How many subexpression matches (counting
* the whole match as subexpression 0) are
* of interest. -1 means "don't know". */
int flags; /* Regular expression flags. */
{
int status;
TclRegexp *regexpPtr = (TclRegexp *) re;
size_t last = regexpPtr->re.re_nsub + 1;
size_t nm = last;
if (nmatches >= 0 && (size_t) nmatches < nm) {
nm = (size_t) nmatches;
}
status = TclReExec(®expPtr->re, wString, (size_t) numChars,
®expPtr->details, nm, regexpPtr->matches, flags);
/*
* Check for errors.
*/
if (status != REG_OKAY) {
if (status == REG_NOMATCH) {
return 0;
}
if (interp != NULL) {
TclRegError(interp, "error while matching regular expression: ",
status);
}
return -1;
}
return 1;
}
/*
*---------------------------------------------------------------------------
*
* TclRegExpRangeUniChar --
*
* Returns pointers describing the range of a regular expression match,
* or one of the subranges within the match, or the hypothetical range
* represented by the rm_extend field of the rm_detail_t.
*
* Results:
* The variables at *startPtr and *endPtr are modified to hold the
* offsets of the endpoints of the range given by index. If the
* specified range doesn't exist then -1s are supplied.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
void
TclRegExpRangeUniChar(re, index, startPtr, endPtr)
Tcl_RegExp re; /* Compiled regular expression that has
* been passed to Tcl_RegExpExec. */
int index; /* 0 means give the range of the entire
* match, > 0 means give the range of
* a matching subrange, -1 means the
* range of the rm_extend field. */
int *startPtr; /* Store address of first character in
* (sub-) range here. */
int *endPtr; /* Store address of character just after last
* in (sub-) range here. */
{
TclRegexp *regexpPtr = (TclRegexp *) re;
if ((regexpPtr->flags®_EXPECT) && index == -1) {
*startPtr = regexpPtr->details.rm_extend.rm_so;
*endPtr = regexpPtr->details.rm_extend.rm_eo;
} else if ((size_t) index > regexpPtr->re.re_nsub) {
*startPtr = -1;
*endPtr = -1;
} else {
*startPtr = regexpPtr->matches[index].rm_so;
*endPtr = regexpPtr->matches[index].rm_eo;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegExpMatch --
*
* See if a string matches a regular expression.
*
* Results:
* If an error occurs during the matching operation then -1
* is returned and the interp's result contains an error message.
* Otherwise the return value is 1 if "string" matches "pattern"
* and 0 otherwise.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_RegExpMatch(interp, string, pattern)
Tcl_Interp *interp; /* Used for error reporting. May be NULL. */
CONST char *string; /* String. */
CONST char *pattern; /* Regular expression to match against
* string. */
{
Tcl_RegExp re;
re = Tcl_RegExpCompile(interp, pattern);
if (re == NULL) {
return -1;
}
return Tcl_RegExpExec(interp, re, string, string);
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegExpExecObj --
*
* Execute a precompiled regexp against the given object.
*
* Results:
* If an error occurs during the matching operation then -1
* is returned and the interp's result contains an error message.
* Otherwise the return value is 1 if "string" matches "pattern"
* and 0 otherwise.
*
* Side effects:
* Converts the object to a Unicode object.
*
*----------------------------------------------------------------------
*/
int
Tcl_RegExpExecObj(interp, re, objPtr, offset, nmatches, flags)
Tcl_Interp *interp; /* Interpreter to use for error reporting. */
Tcl_RegExp re; /* Compiled regular expression; must have
* been returned by previous call to
* Tcl_GetRegExpFromObj. */
Tcl_Obj *objPtr; /* String against which to match re. */
int offset; /* Character index that marks where matching
* should begin. */
int nmatches; /* How many subexpression matches (counting
* the whole match as subexpression 0) are
* of interest. -1 means all of them. */
int flags; /* Regular expression execution flags. */
{
TclRegexp *regexpPtr = (TclRegexp *) re;
Tcl_UniChar *udata;
int length;
/*
* Save the target object so we can extract strings from it later.
*/
regexpPtr->string = NULL;
regexpPtr->objPtr = objPtr;
udata = Tcl_GetUnicodeFromObj(objPtr, &length);
if (offset > length) {
offset = length;
}
udata += offset;
length -= offset;
return RegExpExecUniChar(interp, re, udata, length, nmatches, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegExpMatchObj --
*
* See if an object matches a regular expression.
*
* Results:
* If an error occurs during the matching operation then -1
* is returned and the interp's result contains an error message.
* Otherwise the return value is 1 if "string" matches "pattern"
* and 0 otherwise.
*
* Side effects:
* Changes the internal rep of the pattern and string objects.
*
*----------------------------------------------------------------------
*/
int
Tcl_RegExpMatchObj(interp, stringObj, patternObj)
Tcl_Interp *interp; /* Used for error reporting. May be NULL. */
Tcl_Obj *stringObj; /* Object containing the String to search. */
Tcl_Obj *patternObj; /* Regular expression to match against
* string. */
{
Tcl_RegExp re;
re = Tcl_GetRegExpFromObj(interp, patternObj,
TCL_REG_ADVANCED | TCL_REG_NOSUB);
if (re == NULL) {
return -1;
}
return Tcl_RegExpExecObj(interp, re, stringObj, 0 /* offset */,
0 /* nmatches */, 0 /* flags */);
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegExpGetInfo --
*
* Retrieve information about the current match.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_RegExpGetInfo(regexp, infoPtr)
Tcl_RegExp regexp; /* Pattern from which to get subexpressions. */
Tcl_RegExpInfo *infoPtr; /* Match information is stored here. */
{
TclRegexp *regexpPtr = (TclRegexp *) regexp;
infoPtr->nsubs = regexpPtr->re.re_nsub;
infoPtr->matches = (Tcl_RegExpIndices *) regexpPtr->matches;
infoPtr->extendStart = regexpPtr->details.rm_extend.rm_so;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetRegExpFromObj --
*
* Compile a regular expression into a form suitable for fast
* matching. This procedure caches the result in a Tcl_Obj.
*
* Results:
* The return value is a pointer to the compiled form of string,
* suitable for passing to Tcl_RegExpExec. If an error occurred
* while compiling the pattern, then NULL is returned and an error
* message is left in the interp's result.
*
* Side effects:
* Updates the native rep of the Tcl_Obj.
*
*----------------------------------------------------------------------
*/
Tcl_RegExp
Tcl_GetRegExpFromObj(interp, objPtr, flags)
Tcl_Interp *interp; /* For use in error reporting, and to access
* the interp regexp cache. */
Tcl_Obj *objPtr; /* Object whose string rep contains regular
* expression pattern. Internal rep will be
* changed to compiled form of this regular
* expression. */
int flags; /* Regular expression compilation flags. */
{
int length;
Tcl_ObjType *typePtr;
TclRegexp *regexpPtr;
char *pattern;
typePtr = objPtr->typePtr;
regexpPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr;
if ((typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
pattern = Tcl_GetStringFromObj(objPtr, &length);
regexpPtr = CompileRegexp(interp, pattern, length, flags);
if (regexpPtr == NULL) {
return NULL;
}
/*
* Add a reference to the regexp so it will persist even if it is
* pushed out of the current thread's regexp cache. This reference
* will be removed when the object's internal rep is freed.
*/
regexpPtr->refCount++;
/*
* Free the old representation and set our type.
*/
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
(*typePtr->freeIntRepProc)(objPtr);
}
objPtr->internalRep.otherValuePtr = (VOID *) regexpPtr;
objPtr->typePtr = &tclRegexpType;
}
return (Tcl_RegExp) regexpPtr;
}
/*
*----------------------------------------------------------------------
*
* TclRegAbout --
*
* Return information about a compiled regular expression.
*
* Results:
* The return value is -1 for failure, 0 for success, although at
* the moment there's nothing that could fail. On success, a list
* is left in the interp's result: first element is the subexpression
* count, second is a list of re_info bit names.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclRegAbout(interp, re)
Tcl_Interp *interp; /* For use in variable assignment. */
Tcl_RegExp re; /* The compiled regular expression. */
{
TclRegexp *regexpPtr = (TclRegexp *)re;
char buf[TCL_INTEGER_SPACE];
static struct infoname {
int bit;
char *text;
} infonames[] = {
{REG_UBACKREF, "REG_UBACKREF"},
{REG_ULOOKAHEAD, "REG_ULOOKAHEAD"},
{REG_UBOUNDS, "REG_UBOUNDS"},
{REG_UBRACES, "REG_UBRACES"},
{REG_UBSALNUM, "REG_UBSALNUM"},
{REG_UPBOTCH, "REG_UPBOTCH"},
{REG_UBBS, "REG_UBBS"},
{REG_UNONPOSIX, "REG_UNONPOSIX"},
{REG_UUNSPEC, "REG_UUNSPEC"},
{REG_UUNPORT, "REG_UUNPORT"},
{REG_ULOCALE, "REG_ULOCALE"},
{REG_UEMPTYMATCH, "REG_UEMPTYMATCH"},
{REG_UIMPOSSIBLE, "REG_UIMPOSSIBLE"},
{REG_USHORTEST, "REG_USHORTEST"},
{0, ""}
};
struct infoname *inf;
int n;
Tcl_ResetResult(interp);
sprintf(buf, "%u", (unsigned)(regexpPtr->re.re_nsub));
Tcl_AppendElement(interp, buf);
/*
* Must count bits before generating list, because we must know
* whether {} are needed before we start appending names.
*/
n = 0;
for (inf = infonames; inf->bit != 0; inf++) {
if (regexpPtr->re.re_info&inf->bit) {
n++;
}
}
if (n != 1) {
Tcl_AppendResult(interp, " {", NULL);
}
for (inf = infonames; inf->bit != 0; inf++) {
if (regexpPtr->re.re_info&inf->bit) {
Tcl_AppendElement(interp, inf->text);
}
}
if (n != 1) {
Tcl_AppendResult(interp, "}", NULL);
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* TclRegError --
*
* Generate an error message based on the regexp status code.
*
* Results:
* Places an error in the interpreter.
*
* Side effects:
* Sets errorCode as well.
*
*----------------------------------------------------------------------
*/
void
TclRegError(interp, msg, status)
Tcl_Interp *interp; /* Interpreter for error reporting. */
CONST char *msg; /* Message to prepend to error. */
int status; /* Status code to report. */
{
char buf[100]; /* ample in practice */
char cbuf[100]; /* lots in practice */
size_t n;
char *p;
Tcl_ResetResult(interp);
n = TclReError(status, (regex_t *)NULL, buf, sizeof(buf));
p = (n > sizeof(buf)) ? "..." : "";
Tcl_AppendResult(interp, msg, buf, p, NULL);
sprintf(cbuf, "%d", status);
(VOID) TclReError(REG_ITOA, (regex_t *)NULL, cbuf, sizeof(cbuf));
Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL);
}
/*
*----------------------------------------------------------------------
*
* FreeRegexpInternalRep --
*
* Deallocate the storage associated with a regexp object's internal
* representation.
*
* Results:
* None.
*
* Side effects:
* Frees the compiled regular expression.
*
*----------------------------------------------------------------------
*/
static void
FreeRegexpInternalRep(objPtr)
Tcl_Obj *objPtr; /* Regexp object with internal rep to free. */
{
TclRegexp *regexpRepPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr;
/*
* If this is the last reference to the regexp, free it.
*/
if (--(regexpRepPtr->refCount) <= 0) {
FreeRegexp(regexpRepPtr);
}
}
/*
*----------------------------------------------------------------------
*
* DupRegexpInternalRep --
*
* We copy the reference to the compiled regexp and bump its
* reference count.
*
* Results:
* None.
*
* Side effects:
* Increments the reference count of the regexp.
*
*----------------------------------------------------------------------
*/
static void
DupRegexpInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
TclRegexp *regexpPtr = (TclRegexp *) srcPtr->internalRep.otherValuePtr;
regexpPtr->refCount++;
copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr;
copyPtr->typePtr = &tclRegexpType;
}
/*
*----------------------------------------------------------------------
*
* SetRegexpFromAny --
*
* Attempt to generate a compiled regular expression for the Tcl object
* "objPtr".
*
* Results:
* The return value is TCL_OK or TCL_ERROR. If an error occurs during
* conversion, an error message is left in the interpreter's result
* unless "interp" is NULL.
*
* Side effects:
* If no error occurs, a regular expression is stored as "objPtr"s
* internal representation.
*
*----------------------------------------------------------------------
*/
static int
SetRegexpFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object to convert. */
{
if (Tcl_GetRegExpFromObj(interp, objPtr, REG_ADVANCED) == NULL) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* CompileRegexp --
*
* Attempt to compile the given regexp pattern. If the compiled
* regular expression can be found in the per-thread cache, it
* will be used instead of compiling a new copy.
*
* Results:
* The return value is a pointer to a newly allocated TclRegexp
* that represents the compiled pattern, or NULL if the pattern
* could not be compiled. If NULL is returned, an error message is
* left in the interp's result.
*
* Side effects:
* The thread-local regexp cache is updated and a new TclRegexp may
* be allocated.
*
*----------------------------------------------------------------------
*/
static TclRegexp *
CompileRegexp(interp, string, length, flags)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
CONST char *string; /* The regexp to compile (UTF-8). */
int length; /* The length of the string in bytes. */
int flags; /* Compilation flags. */
{
TclRegexp *regexpPtr;
CONST Tcl_UniChar *uniString;
int numChars;
Tcl_DString stringBuf;
int status, i;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->initialized) {
tsdPtr->initialized = 1;
Tcl_CreateThreadExitHandler(FinalizeRegexp, NULL);
}
/*
* This routine maintains a second-level regular expression cache in
* addition to the per-object regexp cache. The per-thread cache is needed
* to handle the case where for various reasons the object is lost between
* invocations of the regexp command, but the literal pattern is the same.
*/
/*
* Check the per-thread compiled regexp cache. We can only reuse
* a regexp if it has the same pattern and the same flags.
*/
for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
if ((length == tsdPtr->patLengths[i])
&& (tsdPtr->regexps[i]->flags == flags)
&& (strcmp(string, tsdPtr->patterns[i]) == 0)) {
/*
* Move the matched pattern to the first slot in the
* cache and shift the other patterns down one position.
*/
if (i != 0) {
int j;
char *cachedString;
cachedString = tsdPtr->patterns[i];
regexpPtr = tsdPtr->regexps[i];
for (j = i-1; j >= 0; j--) {
tsdPtr->patterns[j+1] = tsdPtr->patterns[j];
tsdPtr->patLengths[j+1] = tsdPtr->patLengths[j];
tsdPtr->regexps[j+1] = tsdPtr->regexps[j];
}
tsdPtr->patterns[0] = cachedString;
tsdPtr->patLengths[0] = length;
tsdPtr->regexps[0] = regexpPtr;
}
return tsdPtr->regexps[0];
}
}
/*
* This is a new expression, so compile it and add it to the cache.
*/
regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp));
regexpPtr->objPtr = NULL;
regexpPtr->string = NULL;
regexpPtr->details.rm_extend.rm_so = -1;
regexpPtr->details.rm_extend.rm_eo = -1;
/*
* Get the up-to-date string representation and map to unicode.
*/
Tcl_DStringInit(&stringBuf);
uniString = Tcl_UtfToUniCharDString(string, length, &stringBuf);
numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar);
/*
* Compile the string and check for errors.
*/
regexpPtr->flags = flags;
status = TclReComp(®expPtr->re, uniString, (size_t) numChars, flags);
Tcl_DStringFree(&stringBuf);
if (status != REG_OKAY) {
/*
* Clean up and report errors in the interpreter, if possible.
*/
ckfree((char *)regexpPtr);
if (interp) {
TclRegError(interp,
"couldn't compile regular expression pattern: ",
status);
}
return NULL;
}
/*
* Allocate enough space for all of the subexpressions, plus one
* extra for the entire pattern.
*/
regexpPtr->matches = (regmatch_t *) ckalloc(
sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
/*
* Initialize the refcount to one initially, since it is in the cache.
*/
regexpPtr->refCount = 1;
/*
* Free the last regexp, if necessary, and make room at the head of the
* list for the new regexp.
*/
if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) {
TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1];
if (--(oldRegexpPtr->refCount) <= 0) {
FreeRegexp(oldRegexpPtr);
}
ckfree(tsdPtr->patterns[NUM_REGEXPS-1]);
}
for (i = NUM_REGEXPS - 2; i >= 0; i--) {
tsdPtr->patterns[i+1] = tsdPtr->patterns[i];
tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
}
tsdPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
strcpy(tsdPtr->patterns[0], string);
tsdPtr->patLengths[0] = length;
tsdPtr->regexps[0] = regexpPtr;
return regexpPtr;
}
/*
*----------------------------------------------------------------------
*
* FreeRegexp --
*
* Release the storage associated with a TclRegexp.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
FreeRegexp(regexpPtr)
TclRegexp *regexpPtr; /* Compiled regular expression to free. */
{
TclReFree(®expPtr->re);
if (regexpPtr->matches) {
ckfree((char *) regexpPtr->matches);
}
ckfree((char *) regexpPtr);
}
/*
*----------------------------------------------------------------------
*
* FinalizeRegexp --
*
* Release the storage associated with the per-thread regexp
* cache.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
FinalizeRegexp(clientData)
ClientData clientData; /* Not used. */
{
int i;
TclRegexp *regexpPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
regexpPtr = tsdPtr->regexps[i];
if (--(regexpPtr->refCount) <= 0) {
FreeRegexp(regexpPtr);
}
ckfree(tsdPtr->patterns[i]);
tsdPtr->patterns[i] = NULL;
}
/*
* We may find ourselves reinitialized if another finalization routine
* invokes regexps.
*/
tsdPtr->initialized = 0;
}
tcl8.4.20/generic/tclDate.c 0000644 0036047 0045461 00000156220 12052456743 014063 0 ustar dgp 771div /*
* tclDate.c --
*
* This file is generated from a yacc grammar defined in
* the file tclGetDate.y. It should not be edited directly.
*
* Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
* Copyright (c) 1995-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.
*/
#include "tclInt.h"
#include "tclPort.h"
#define EPOCH 1970
#define START_OF_TIME 1902
#define END_OF_TIME 2037
/*
* The offset of tm_year of struct tm returned by localtime, gmtime, etc.
* I don't know how universal this is; K&R II, the NetBSD manpages, and
* ../compat/strftime.c all agree that tm_year is the year-1900. However,
* some systems may have a different value. This #define should be the
* same as in ../compat/strftime.c.
*/
#define TM_YEAR_BASE 1900
#define HOUR(x) ((int) (60 * x))
#define SECSPERDAY (24L * 60L * 60L)
#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0))
/*
* An entry in the lexical lookup table.
*/
typedef struct _TABLE {
char *name;
int type;
time_t value;
} TABLE;
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
/*
* Meridian: am, pm, or 24-hour style.
*/
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
/*
* Global variables. We could get rid of most of these by using a good
* union as the yacc stack. (This routine was originally written before
* yacc had the %union construct.) Maybe someday; right now we only use
* the %union very rarely.
*/
static char *TclDateInput;
static DSTMODE TclDateDSTmode;
static time_t TclDateDayOrdinal;
static time_t TclDateDayNumber;
static time_t TclDateMonthOrdinal;
static int TclDateHaveDate;
static int TclDateHaveDay;
static int TclDateHaveOrdinalMonth;
static int TclDateHaveRel;
static int TclDateHaveTime;
static int TclDateHaveZone;
static time_t TclDateTimezone;
static time_t TclDateDay;
static time_t TclDateHour;
static time_t TclDateMinutes;
static time_t TclDateMonth;
static time_t TclDateSeconds;
static time_t TclDateYear;
static MERIDIAN TclDateMeridian;
static time_t TclDateRelMonth;
static time_t TclDateRelDay;
static time_t TclDateRelSeconds;
static time_t *TclDateRelPointer;
/*
* Prototypes of internal functions.
*/
static void TclDateerror _ANSI_ARGS_((char *s));
static time_t ToSeconds _ANSI_ARGS_((time_t Hours, time_t Minutes,
time_t Seconds, MERIDIAN Meridian));
static int Convert _ANSI_ARGS_((time_t Month, time_t Day, time_t Year,
time_t Hours, time_t Minutes, time_t Seconds,
MERIDIAN Meridia, DSTMODE DSTmode, time_t *TimePtr));
static time_t DSTcorrect _ANSI_ARGS_((time_t Start, time_t Future));
static time_t NamedDay _ANSI_ARGS_((time_t Start, time_t DayOrdinal,
time_t DayNumber));
static time_t NamedMonth _ANSI_ARGS_((time_t Start, time_t MonthOrdinal,
time_t MonthNumber));
static int RelativeMonth _ANSI_ARGS_((time_t Start, time_t RelMonth,
time_t *TimePtr));
static int RelativeDay _ANSI_ARGS_((time_t Start, time_t RelDay,
time_t *TimePtr));
static int LookupWord _ANSI_ARGS_((char *buff));
static int TclDatelex _ANSI_ARGS_((void));
int
TclDateparse _ANSI_ARGS_((void));
typedef union
#ifdef __cplusplus
YYSTYPE
#endif
{
time_t Number;
enum _MERIDIAN Meridian;
} YYSTYPE;
# define tAGO 257
# define tDAY 258
# define tDAYZONE 259
# define tID 260
# define tMERIDIAN 261
# define tMINUTE_UNIT 262
# define tMONTH 263
# define tMONTH_UNIT 264
# define tSTARDATE 265
# define tSEC_UNIT 266
# define tSNUMBER 267
# define tUNUMBER 268
# define tZONE 269
# define tEPOCH 270
# define tDST 271
# define tISOBASE 272
# define tDAY_UNIT 273
# define tNEXT 274
#if defined(__cplusplus) || defined(__STDC__)
#if defined(__cplusplus) && defined(__EXTERN_C__)
extern "C" {
#endif
#ifndef TclDateerror
#if defined(__cplusplus)
void TclDateerror(CONST char *);
#endif
#endif
#ifndef TclDatelex
int TclDatelex(void);
#endif
int TclDateparse(void);
#if defined(__cplusplus) && defined(__EXTERN_C__)
}
#endif
#endif
#define TclDateclearin TclDatechar = -1
#define TclDateerrok TclDateerrflag = 0
extern int TclDatechar;
extern int TclDateerrflag;
YYSTYPE TclDatelval;
YYSTYPE TclDateval;
typedef int TclDatetabelem;
#ifndef YYMAXDEPTH
#define YYMAXDEPTH 150
#endif
#if YYMAXDEPTH > 0
int TclDate_TclDates[YYMAXDEPTH], *TclDates = TclDate_TclDates;
YYSTYPE TclDate_TclDatev[YYMAXDEPTH], *TclDatev = TclDate_TclDatev;
#else /* user does initial allocation */
int *TclDates;
YYSTYPE *TclDatev;
#endif
static int TclDatemaxdepth = YYMAXDEPTH;
# define YYERRCODE 256
/*
* Month and day table.
*/
static CONST TABLE MonthDayTable[] = {
{ "january", tMONTH, 1 },
{ "february", tMONTH, 2 },
{ "march", tMONTH, 3 },
{ "april", tMONTH, 4 },
{ "may", tMONTH, 5 },
{ "june", tMONTH, 6 },
{ "july", tMONTH, 7 },
{ "august", tMONTH, 8 },
{ "september", tMONTH, 9 },
{ "sept", tMONTH, 9 },
{ "october", tMONTH, 10 },
{ "november", tMONTH, 11 },
{ "december", tMONTH, 12 },
{ "sunday", tDAY, 0 },
{ "monday", tDAY, 1 },
{ "tuesday", tDAY, 2 },
{ "tues", tDAY, 2 },
{ "wednesday", tDAY, 3 },
{ "wednes", tDAY, 3 },
{ "thursday", tDAY, 4 },
{ "thur", tDAY, 4 },
{ "thurs", tDAY, 4 },
{ "friday", tDAY, 5 },
{ "saturday", tDAY, 6 },
{ NULL }
};
/*
* Time units table.
*/
static CONST TABLE UnitsTable[] = {
{ "year", tMONTH_UNIT, 12 },
{ "month", tMONTH_UNIT, 1 },
{ "fortnight", tDAY_UNIT, 14 },
{ "week", tDAY_UNIT, 7 },
{ "day", tDAY_UNIT, 1 },
{ "hour", tSEC_UNIT, 60 * 60 },
{ "minute", tSEC_UNIT, 60 },
{ "min", tSEC_UNIT, 60 },
{ "second", tSEC_UNIT, 1 },
{ "sec", tSEC_UNIT, 1 },
{ NULL }
};
/*
* Assorted relative-time words.
*/
static CONST TABLE OtherTable[] = {
{ "tomorrow", tDAY_UNIT, 1 },
{ "yesterday", tDAY_UNIT, -1 },
{ "today", tDAY_UNIT, 0 },
{ "now", tSEC_UNIT, 0 },
{ "last", tUNUMBER, -1 },
{ "this", tSEC_UNIT, 0 },
{ "next", tNEXT, 1 },
#if 0
{ "first", tUNUMBER, 1 },
{ "second", tUNUMBER, 2 },
{ "third", tUNUMBER, 3 },
{ "fourth", tUNUMBER, 4 },
{ "fifth", tUNUMBER, 5 },
{ "sixth", tUNUMBER, 6 },
{ "seventh", tUNUMBER, 7 },
{ "eighth", tUNUMBER, 8 },
{ "ninth", tUNUMBER, 9 },
{ "tenth", tUNUMBER, 10 },
{ "eleventh", tUNUMBER, 11 },
{ "twelfth", tUNUMBER, 12 },
#endif
{ "ago", tAGO, 1 },
{ "epoch", tEPOCH, 0 },
{ "stardate", tSTARDATE, 0},
{ NULL }
};
/*
* The timezone table. (Note: This table was modified to not use any floating
* point constants to work around an SGI compiler bug).
*/
static CONST TABLE TimezoneTable[] = {
{ "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */
{ "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */
{ "utc", tZONE, HOUR( 0) },
{ "uct", tZONE, HOUR( 0) }, /* Universal Coordinated Time */
{ "wet", tZONE, HOUR( 0) }, /* Western European */
{ "bst", tDAYZONE, HOUR( 0) }, /* British Summer */
{ "wat", tZONE, HOUR( 1) }, /* West Africa */
{ "at", tZONE, HOUR( 2) }, /* Azores */
#if 0
/* For completeness. BST is also British Summer, and GST is
* also Guam Standard. */
{ "bst", tZONE, HOUR( 3) }, /* Brazil Standard */
{ "gst", tZONE, HOUR( 3) }, /* Greenland Standard */
#endif
{ "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */
{ "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */
{ "ndt", tDAYZONE, HOUR( 7/2) }, /* Newfoundland Daylight */
{ "ast", tZONE, HOUR( 4) }, /* Atlantic Standard */
{ "adt", tDAYZONE, HOUR( 4) }, /* Atlantic Daylight */
{ "est", tZONE, HOUR( 5) }, /* Eastern Standard */
{ "edt", tDAYZONE, HOUR( 5) }, /* Eastern Daylight */
{ "cst", tZONE, HOUR( 6) }, /* Central Standard */
{ "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */
{ "mst", tZONE, HOUR( 7) }, /* Mountain Standard */
{ "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */
{ "pst", tZONE, HOUR( 8) }, /* Pacific Standard */
{ "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */
{ "yst", tZONE, HOUR( 9) }, /* Yukon Standard */
{ "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */
{ "hst", tZONE, HOUR(10) }, /* Hawaii Standard */
{ "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */
{ "cat", tZONE, HOUR(10) }, /* Central Alaska */
{ "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */
{ "nt", tZONE, HOUR(11) }, /* Nome */
{ "idlw", tZONE, HOUR(12) }, /* International Date Line West */
{ "cet", tZONE, -HOUR( 1) }, /* Central European */
{ "cest", tDAYZONE, -HOUR( 1) }, /* Central European Summer */
{ "met", tZONE, -HOUR( 1) }, /* Middle European */
{ "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */
{ "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */
{ "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */
{ "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */
{ "fwt", tZONE, -HOUR( 1) }, /* French Winter */
{ "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */
{ "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */
{ "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */
{ "it", tZONE, -HOUR( 7/2) }, /* Iran */
{ "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */
{ "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */
{ "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */
{ "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */
#if 0
/* For completeness. NST is also Newfoundland Stanard, nad SST is
* also Swedish Summer. */
{ "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */
{ "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */
#endif /* 0 */
{ "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */
{ "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */
{ "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */
{ "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */
{ "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */
{ "jdt", tDAYZONE, -HOUR( 9) }, /* Japan Daylight */
{ "kst", tZONE, -HOUR( 9) }, /* Korea Standard */
{ "kdt", tDAYZONE, -HOUR( 9) }, /* Korea Daylight */
{ "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */
{ "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */
{ "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */
{ "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */
{ "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */
{ "nzt", tZONE, -HOUR(12) }, /* New Zealand */
{ "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */
{ "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */
{ "idle", tZONE, -HOUR(12) }, /* International Date Line East */
/* ADDED BY Marco Nijdam */
{ "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */
/* End ADDED */
{ NULL }
};
/*
* Military timezone table.
*/
static CONST TABLE MilitaryTable[] = {
{ "a", tZONE, HOUR( 1) },
{ "b", tZONE, HOUR( 2) },
{ "c", tZONE, HOUR( 3) },
{ "d", tZONE, HOUR( 4) },
{ "e", tZONE, HOUR( 5) },
{ "f", tZONE, HOUR( 6) },
{ "g", tZONE, HOUR( 7) },
{ "h", tZONE, HOUR( 8) },
{ "i", tZONE, HOUR( 9) },
{ "k", tZONE, HOUR( 10) },
{ "l", tZONE, HOUR( 11) },
{ "m", tZONE, HOUR( 12) },
{ "n", tZONE, HOUR(- 1) },
{ "o", tZONE, HOUR(- 2) },
{ "p", tZONE, HOUR(- 3) },
{ "q", tZONE, HOUR(- 4) },
{ "r", tZONE, HOUR(- 5) },
{ "s", tZONE, HOUR(- 6) },
{ "t", tZONE, HOUR(- 7) },
{ "u", tZONE, HOUR(- 8) },
{ "v", tZONE, HOUR(- 9) },
{ "w", tZONE, HOUR(-10) },
{ "x", tZONE, HOUR(-11) },
{ "y", tZONE, HOUR(-12) },
{ "z", tZONE, HOUR( 0) },
{ NULL }
};
/*
* Dump error messages in the bit bucket.
*/
static void
TclDateerror(s)
char *s;
{
}
static time_t
ToSeconds(Hours, Minutes, Seconds, Meridian)
time_t Hours;
time_t Minutes;
time_t Seconds;
MERIDIAN Meridian;
{
if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59)
return -1;
switch (Meridian) {
case MER24:
if (Hours < 0 || Hours > 23)
return -1;
return (Hours * 60L + Minutes) * 60L + Seconds;
case MERam:
if (Hours < 1 || Hours > 12)
return -1;
return ((Hours % 12) * 60L + Minutes) * 60L + Seconds;
case MERpm:
if (Hours < 1 || Hours > 12)
return -1;
return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds;
}
return -1; /* Should never be reached */
}
/*
*-----------------------------------------------------------------------------
*
* Convert --
*
* Convert a {month, day, year, hours, minutes, seconds, meridian, dst}
* tuple into a clock seconds value.
*
* Results:
* 0 or -1 indicating success or failure.
*
* Side effects:
* Fills TimePtr with the computed value.
*
*-----------------------------------------------------------------------------
*/
static int
Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr)
time_t Month;
time_t Day;
time_t Year;
time_t Hours;
time_t Minutes;
time_t Seconds;
MERIDIAN Meridian;
DSTMODE DSTmode;
time_t *TimePtr;
{
static int DaysInMonth[12] = {
31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31
};
time_t tod;
time_t Julian;
int i;
/* Figure out how many days are in February for the given year.
* Every year divisible by 4 is a leap year.
* But, every year divisible by 100 is not a leap year.
* But, every year divisible by 400 is a leap year after all.
*/
DaysInMonth[1] = IsLeapYear(Year) ? 29 : 28;
/* Check the inputs for validity */
if (Month < 1 || Month > 12
|| Year < START_OF_TIME || Year > END_OF_TIME
|| Day < 1 || Day > DaysInMonth[(int)--Month])
return -1;
/* Start computing the value. First determine the number of days
* represented by the date, then multiply by the number of seconds/day.
*/
for (Julian = Day - 1, i = 0; i < Month; i++)
Julian += DaysInMonth[i];
if (Year >= EPOCH) {
for (i = EPOCH; i < Year; i++)
Julian += 365 + IsLeapYear(i);
} else {
for (i = (int)Year; i < EPOCH; i++)
Julian -= 365 + IsLeapYear(i);
}
Julian *= SECSPERDAY;
/* Add the timezone offset ?? */
Julian += TclDateTimezone * 60L;
/* Add the number of seconds represented by the time component */
if ((tod = ToSeconds(Hours, Minutes, Seconds, Meridian)) < 0)
return -1;
Julian += tod;
/* Perform a preliminary DST compensation ?? */
if (DSTmode == DSTon
|| (DSTmode == DSTmaybe && TclpGetDate((TclpTime_t)&Julian, 0)->tm_isdst))
Julian -= 60 * 60;
*TimePtr = Julian;
return 0;
}
static time_t
DSTcorrect(Start, Future)
time_t Start;
time_t Future;
{
time_t StartDay;
time_t FutureDay;
StartDay = (TclpGetDate((TclpTime_t)&Start, 0)->tm_hour + 1) % 24;
FutureDay = (TclpGetDate((TclpTime_t)&Future, 0)->tm_hour + 1) % 24;
return (Future - Start) + (StartDay - FutureDay) * 60L * 60L;
}
static time_t
NamedDay(Start, DayOrdinal, DayNumber)
time_t Start;
time_t DayOrdinal;
time_t DayNumber;
{
struct tm *tm;
time_t now;
now = Start;
tm = TclpGetDate((TclpTime_t)&now, 0);
now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7);
now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1);
return DSTcorrect(Start, now);
}
static time_t
NamedMonth(Start, MonthOrdinal, MonthNumber)
time_t Start;
time_t MonthOrdinal;
time_t MonthNumber;
{
struct tm *tm;
time_t now;
int result;
now = Start;
tm = TclpGetDate((TclpTime_t)&now, 0);
/* To compute the next n'th month, we use this alg:
* add n to year value
* if currentMonth < requestedMonth decrement year value by 1 (so that
* doing next february from january gives us february of the current year)
* set day to 1, time to 0
*/
tm->tm_year += (int)MonthOrdinal;
if (tm->tm_mon < MonthNumber - 1) {
tm->tm_year--;
}
result = Convert(MonthNumber, (time_t) 1, tm->tm_year + TM_YEAR_BASE,
(time_t) 0, (time_t) 0, (time_t) 0, MER24, DSTmaybe, &now);
if (result < 0) {
return 0;
}
return DSTcorrect(Start, now);
}
static int
RelativeMonth(Start, RelMonth, TimePtr)
time_t Start;
time_t RelMonth;
time_t *TimePtr;
{
struct tm *tm;
time_t Month;
time_t Year;
time_t Julian;
int result;
if (RelMonth == 0) {
*TimePtr = 0;
return 0;
}
tm = TclpGetDate((TclpTime_t)&Start, 0);
Month = 12 * (tm->tm_year + TM_YEAR_BASE) + tm->tm_mon + RelMonth;
Year = Month / 12;
Month = Month % 12 + 1;
result = Convert(Month, (time_t) tm->tm_mday, Year,
(time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec,
MER24, DSTmaybe, &Julian);
/*
* The Julian time returned above is behind by one day, if "month"
* or "year" is used to specify relative time and the GMT flag is true.
* This problem occurs only when the current time is closer to
* midnight, the difference being not more than its time difference
* with GMT. For example, in US/Pacific time zone, the problem occurs
* whenever the current time is between midnight to 8:00am or 7:00amDST.
* See Bug# 413397 for more details and sample script.
* To resolve this bug, we simply add the number of seconds corresponding
* to timezone difference with GMT to Julian time, if GMT flag is true.
*/
if (TclDateTimezone == 0) {
Julian += TclpGetTimeZone((unsigned long) Start) * 60L;
}
/*
* The following iteration takes into account the case were we jump
* into a "short month". Far example, "one month from Jan 31" will
* fail because there is no Feb 31. The code below will reduce the
* day and try converting the date until we succed or the date equals
* 28 (which always works unless the date is bad in another way).
*/
while ((result != 0) && (tm->tm_mday > 28)) {
tm->tm_mday--;
result = Convert(Month, (time_t) tm->tm_mday, Year,
(time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec,
MER24, DSTmaybe, &Julian);
}
if (result != 0) {
return -1;
}
*TimePtr = DSTcorrect(Start, Julian);
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* RelativeDay --
*
* Given a starting time and a number of days before or after, compute the
* DST corrected difference between those dates.
*
* Results:
* 1 or -1 indicating success or failure.
*
* Side effects:
* Fills TimePtr with the computed value.
*
*-----------------------------------------------------------------------------
*/
static int
RelativeDay(Start, RelDay, TimePtr)
time_t Start;
time_t RelDay;
time_t *TimePtr;
{
time_t new;
new = Start + (RelDay * 60 * 60 * 24);
*TimePtr = DSTcorrect(Start, new);
return 1;
}
static int
LookupWord(buff)
char *buff;
{
register char *p;
register char *q;
register CONST TABLE *tp;
int i;
int abbrev;
/*
* Make it lowercase.
*/
Tcl_UtfToLower(buff);
if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) {
TclDatelval.Meridian = MERam;
return tMERIDIAN;
}
if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) {
TclDatelval.Meridian = MERpm;
return tMERIDIAN;
}
/*
* See if we have an abbreviation for a month.
*/
if (strlen(buff) == 3) {
abbrev = 1;
} else if (strlen(buff) == 4 && buff[3] == '.') {
abbrev = 1;
buff[3] = '\0';
} else {
abbrev = 0;
}
for (tp = MonthDayTable; tp->name; tp++) {
if (abbrev) {
if (strncmp(buff, tp->name, 3) == 0) {
TclDatelval.Number = tp->value;
return tp->type;
}
} else if (strcmp(buff, tp->name) == 0) {
TclDatelval.Number = tp->value;
return tp->type;
}
}
for (tp = TimezoneTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
TclDatelval.Number = tp->value;
return tp->type;
}
}
for (tp = UnitsTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
TclDatelval.Number = tp->value;
return tp->type;
}
}
/*
* Strip off any plural and try the units table again.
*/
i = strlen(buff) - 1;
if (buff[i] == 's') {
buff[i] = '\0';
for (tp = UnitsTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
TclDatelval.Number = tp->value;
return tp->type;
}
}
}
for (tp = OtherTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
TclDatelval.Number = tp->value;
return tp->type;
}
}
/*
* Military timezones.
*/
if (buff[1] == '\0' && !(*buff & 0x80)
&& isalpha(UCHAR(*buff))) { /* INTL: ISO only */
for (tp = MilitaryTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
TclDatelval.Number = tp->value;
return tp->type;
}
}
}
/*
* Drop out any periods and try the timezone table again.
*/
for (i = 0, p = q = buff; *q; q++)
if (*q != '.') {
*p++ = *q;
} else {
i++;
}
*p = '\0';
if (i) {
for (tp = TimezoneTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
TclDatelval.Number = tp->value;
return tp->type;
}
}
}
return tID;
}
static int
TclDatelex()
{
register char c;
register char *p;
char buff[20];
int Count;
for ( ; ; ) {
while (isspace(UCHAR(*TclDateInput))) {
TclDateInput++;
}
if (isdigit(UCHAR(c = *TclDateInput))) { /* INTL: digit */
/* convert the string into a number; count the number of digits */
Count = 0;
for (TclDatelval.Number = 0;
isdigit(UCHAR(c = *TclDateInput++)); ) { /* INTL: digit */
TclDatelval.Number = 10 * TclDatelval.Number + c - '0';
Count++;
}
TclDateInput--;
/* A number with 6 or more digits is considered an ISO 8601 base */
if (Count >= 6) {
return tISOBASE;
} else {
return tUNUMBER;
}
}
if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */
for (p = buff; isalpha(UCHAR(c = *TclDateInput++)) /* INTL: ISO only. */
|| c == '.'; ) {
if (p < &buff[sizeof buff - 1]) {
*p++ = c;
}
}
*p = '\0';
TclDateInput--;
return LookupWord(buff);
}
if (c != '(') {
return *TclDateInput++;
}
Count = 0;
do {
c = *TclDateInput++;
if (c == '\0') {
return c;
} else if (c == '(') {
Count++;
} else if (c == ')') {
Count--;
}
} while (Count > 0);
}
}
/*
* Specify zone is of -50000 to force GMT. (This allows BST to work).
*/
int
TclGetDate(p, now, zone, timePtr)
char *p;
Tcl_WideInt now;
long zone;
Tcl_WideInt *timePtr;
{
struct tm *tm;
time_t Start;
time_t Time;
time_t tod;
int thisyear;
TclDateInput = p;
/* now has to be cast to a time_t for 64bit compliance */
Start = (time_t) now;
tm = TclpGetDate((TclpTime_t) &Start, (zone == -50000));
thisyear = tm->tm_year + TM_YEAR_BASE;
TclDateYear = thisyear;
TclDateMonth = tm->tm_mon + 1;
TclDateDay = tm->tm_mday;
TclDateTimezone = zone;
if (zone == -50000) {
TclDateDSTmode = DSToff; /* assume GMT */
TclDateTimezone = 0;
} else {
TclDateDSTmode = DSTmaybe;
}
TclDateHour = 0;
TclDateMinutes = 0;
TclDateSeconds = 0;
TclDateMeridian = MER24;
TclDateRelSeconds = 0;
TclDateRelMonth = 0;
TclDateRelDay = 0;
TclDateRelPointer = NULL;
TclDateHaveDate = 0;
TclDateHaveDay = 0;
TclDateHaveOrdinalMonth = 0;
TclDateHaveRel = 0;
TclDateHaveTime = 0;
TclDateHaveZone = 0;
if (TclDateparse() || TclDateHaveTime > 1 || TclDateHaveZone > 1 || TclDateHaveDate > 1 ||
TclDateHaveDay > 1 || TclDateHaveOrdinalMonth > 1) {
return -1;
}
if (TclDateHaveDate || TclDateHaveTime || TclDateHaveDay) {
if (TclDateYear < 0) {
TclDateYear = -TclDateYear;
}
/*
* The following line handles years that are specified using
* only two digits. The line of code below implements a policy
* defined by the X/Open workgroup on the millinium rollover.
* Note: some of those dates may not actually be valid on some
* platforms. The POSIX standard startes that the dates 70-99
* shall refer to 1970-1999 and 00-38 shall refer to 2000-2038.
* This later definition should work on all platforms.
*/
if (TclDateYear < 100) {
if (TclDateYear >= 69) {
TclDateYear += 1900;
} else {
TclDateYear += 2000;
}
}
if (Convert(TclDateMonth, TclDateDay, TclDateYear, TclDateHour, TclDateMinutes, TclDateSeconds,
TclDateMeridian, TclDateDSTmode, &Start) < 0) {
return -1;
}
} else {
Start = (time_t) now;
if (!TclDateHaveRel) {
Start -= ((tm->tm_hour * 60L * 60L) +
tm->tm_min * 60L) + tm->tm_sec;
}
}
Start += TclDateRelSeconds;
if (RelativeMonth(Start, TclDateRelMonth, &Time) < 0) {
return -1;
}
Start += Time;
if (RelativeDay(Start, TclDateRelDay, &Time) < 0) {
return -1;
}
Start += Time;
if (TclDateHaveDay && !TclDateHaveDate) {
tod = NamedDay(Start, TclDateDayOrdinal, TclDateDayNumber);
Start += tod;
}
if (TclDateHaveOrdinalMonth) {
tod = NamedMonth(Start, TclDateMonthOrdinal, TclDateMonth);
Start += tod;
}
*timePtr = Start;
return 0;
}
static CONST TclDatetabelem TclDateexca[] ={
-1, 1,
0, -1,
-2, 0,
};
# define YYNPROD 56
# define YYLAST 261
static CONST TclDatetabelem TclDateact[]={
24, 40, 23, 36, 54, 81, 41, 28, 53, 26,
37, 42, 58, 38, 56, 28, 27, 26, 28, 33,
26, 32, 61, 50, 27, 80, 76, 27, 51, 75,
74, 73, 30, 72, 71, 70, 69, 52, 49, 48,
47, 45, 39, 62, 78, 46, 79, 68, 25, 65,
60, 67, 66, 55, 44, 21, 63, 11, 10, 9,
8, 35, 7, 6, 5, 4, 3, 43, 2, 1,
20, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 57, 0, 0, 59, 77, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 19, 14, 0, 0, 0,
16, 28, 22, 26, 0, 12, 13, 17, 0, 15,
27, 18, 31, 0, 0, 29, 0, 34, 28, 0,
26, 0, 0, 0, 0, 0, 0, 27, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 64,
64 };
static CONST TclDatetabelem TclDatepact[]={
-10000000, -43,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000,
-10000000,-10000000, -26, -268,-10000000, -259, -226,-10000000, -257, 10,
-227, -212, -228,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000,
-229,-10000000, -230, -240, -231,-10000000,-10000000, -264,-10000000, 9,
-10000000,-10000000, -249,-10000000,-10000000, -246,-10000000, 4, -2, 2,
7, 6,-10000000,-10000000, -11, -232,-10000000,-10000000,-10000000,-10000000,
-233,-10000000, -234, -235,-10000000, -237, -238, -239, -242,-10000000,
-10000000,-10000000, -1,-10000000,-10000000,-10000000, -12,-10000000, -243, -263,
-10000000,-10000000 };
static CONST TclDatetabelem TclDatepgo[]={
0, 48, 70, 22, 69, 68, 66, 65, 64, 63,
62, 60, 59, 58, 57, 55 };
static CONST TclDatetabelem TclDater1[]={
0, 4, 4, 5, 5, 5, 5, 5, 5, 5,
5, 5, 6, 6, 6, 6, 6, 7, 7, 7,
10, 10, 10, 10, 10, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 9, 9, 12, 12, 12,
13, 11, 11, 15, 15, 15, 15, 15, 2, 2,
1, 1, 1, 14, 3, 3 };
static CONST TclDatetabelem TclDater2[]={
0, 0, 4, 3, 3, 3, 3, 3, 3, 3,
3, 2, 5, 9, 11, 13, 15, 5, 3, 3,
3, 5, 5, 7, 5, 7, 11, 3, 11, 11,
5, 9, 5, 3, 7, 5, 7, 7, 15, 5,
9, 5, 2, 7, 5, 5, 7, 3, 3, 3,
3, 3, 3, 3, 1, 3 };
static CONST TclDatetabelem TclDatechk[]={
-10000000, -4, -5, -6, -7, -8, -9, -10, -11, -12,
-13, -14, 268, 269, 259, 272, 263, 270, 274, 258,
-2, -15, 265, 45, 43, -1, 266, 273, 264, 261,
58, 258, 47, 45, 263, -1, 271, 269, 272, 268,
258, 263, 268, -1, 44, 268, 257, 268, 268, 268,
263, 268, 268, 272, 268, 44, 263, -1, 258, -1,
46, -3, 45, 58, 261, 47, 45, 45, 58, 268,
268, 268, 268, 268, 268, 268, 268, -3, 45, 58,
268, 268 };
static CONST TclDatetabelem TclDatedef[]={
1, -2, 2, 3, 4, 5, 6, 7, 8, 9,
10, 11, 53, 18, 19, 27, 0, 33, 0, 20,
0, 42, 0, 48, 49, 47, 50, 51, 52, 12,
0, 22, 0, 0, 32, 44, 17, 0, 39, 30,
24, 35, 0, 45, 21, 0, 41, 0, 54, 25,
0, 0, 34, 37, 0, 0, 36, 46, 23, 43,
0, 13, 0, 0, 55, 0, 0, 0, 0, 31,
40, 14, 54, 26, 28, 29, 0, 15, 0, 0,
16, 38 };
typedef struct
#ifdef __cplusplus
TclDatetoktype
#endif
{ char *t_name; int t_val; } TclDatetoktype;
#ifndef YYDEBUG
# define YYDEBUG 0 /* don't allow debugging */
#endif
#if YYDEBUG
TclDatetoktype TclDatetoks[] =
{
"tAGO", 257,
"tDAY", 258,
"tDAYZONE", 259,
"tID", 260,
"tMERIDIAN", 261,
"tMINUTE_UNIT", 262,
"tMONTH", 263,
"tMONTH_UNIT", 264,
"tSTARDATE", 265,
"tSEC_UNIT", 266,
"tSNUMBER", 267,
"tUNUMBER", 268,
"tZONE", 269,
"tEPOCH", 270,
"tDST", 271,
"tISOBASE", 272,
"tDAY_UNIT", 273,
"tNEXT", 274,
"-unknown-", -1 /* ends search */
};
char * TclDatereds[] =
{
"-no such reduction-",
"spec : /* empty */",
"spec : spec item",
"item : time",
"item : zone",
"item : date",
"item : ordMonth",
"item : day",
"item : relspec",
"item : iso",
"item : trek",
"item : number",
"time : tUNUMBER tMERIDIAN",
"time : tUNUMBER ':' tUNUMBER o_merid",
"time : tUNUMBER ':' tUNUMBER '-' tUNUMBER",
"time : tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid",
"time : tUNUMBER ':' tUNUMBER ':' tUNUMBER '-' tUNUMBER",
"zone : tZONE tDST",
"zone : tZONE",
"zone : tDAYZONE",
"day : tDAY",
"day : tDAY ','",
"day : tUNUMBER tDAY",
"day : sign tUNUMBER tDAY",
"day : tNEXT tDAY",
"date : tUNUMBER '/' tUNUMBER",
"date : tUNUMBER '/' tUNUMBER '/' tUNUMBER",
"date : tISOBASE",
"date : tUNUMBER '-' tMONTH '-' tUNUMBER",
"date : tUNUMBER '-' tUNUMBER '-' tUNUMBER",
"date : tMONTH tUNUMBER",
"date : tMONTH tUNUMBER ',' tUNUMBER",
"date : tUNUMBER tMONTH",
"date : tEPOCH",
"date : tUNUMBER tMONTH tUNUMBER",
"ordMonth : tNEXT tMONTH",
"ordMonth : tNEXT tUNUMBER tMONTH",
"iso : tISOBASE tZONE tISOBASE",
"iso : tISOBASE tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER",
"iso : tISOBASE tISOBASE",
"trek : tSTARDATE tUNUMBER '.' tUNUMBER",
"relspec : relunits tAGO",
"relspec : relunits",
"relunits : sign tUNUMBER unit",
"relunits : tUNUMBER unit",
"relunits : tNEXT unit",
"relunits : tNEXT tUNUMBER unit",
"relunits : unit",
"sign : '-'",
"sign : '+'",
"unit : tSEC_UNIT",
"unit : tDAY_UNIT",
"unit : tMONTH_UNIT",
"number : tUNUMBER",
"o_merid : /* empty */",
"o_merid : tMERIDIAN",
};
#endif /* YYDEBUG */
/*
* Copyright (c) 1993 by Sun Microsystems, Inc.
*/
/*
** Skeleton parser driver for yacc output
*/
/*
** yacc user known macros and defines
*/
#define YYERROR goto TclDateerrlab
#define YYACCEPT return(0)
#define YYABORT return(1)
#define YYBACKUP( newtoken, newvalue )\
{\
if ( TclDatechar >= 0 || ( TclDater2[ TclDatetmp ] >> 1 ) != 1 )\
{\
TclDateerror( "syntax error - cannot backup" );\
goto TclDateerrlab;\
}\
TclDatechar = newtoken;\
TclDatestate = *TclDateps;\
TclDatelval = newvalue;\
goto TclDatenewstate;\
}
#define YYRECOVERING() (!!TclDateerrflag)
#define YYNEW(type) malloc(sizeof(type) * TclDatenewmax)
#define YYCOPY(to, from, type) \
(type *) memcpy(to, (char *) from, TclDatemaxdepth * sizeof (type))
#define YYENLARGE( from, type) \
(type *) realloc((char *) from, TclDatenewmax * sizeof(type))
#ifndef YYDEBUG
# define YYDEBUG 1 /* make debugging available */
#endif
/*
** user known globals
*/
int TclDatedebug; /* set to 1 to get debugging */
/*
** driver internal defines
*/
#define YYFLAG (-10000000)
/*
** global variables used by the parser
*/
YYSTYPE *TclDatepv; /* top of value stack */
int *TclDateps; /* top of state stack */
int TclDatestate; /* current state */
int TclDatetmp; /* extra var (lasts between blocks) */
int TclDatenerrs; /* number of errors */
int TclDateerrflag; /* error recovery flag */
int TclDatechar; /* current input token number */
#ifdef YYNMBCHARS
#define YYLEX() TclDatecvtok(TclDatelex())
/*
** TclDatecvtok - return a token if i is a wchar_t value that exceeds 255.
** If i<255, i itself is the token. If i>255 but the neither
** of the 30th or 31st bit is on, i is already a token.
*/
#if defined(__STDC__) || defined(__cplusplus)
int TclDatecvtok(int i)
#else
int TclDatecvtok(i) int i;
#endif
{
int first = 0;
int last = YYNMBCHARS - 1;
int mid;
wchar_t j;
if(i&0x60000000){/*Must convert to a token. */
if( TclDatembchars[last].character < i ){
return i;/*Giving up*/
}
while ((last>=first)&&(first>=0)) {/*Binary search loop*/
mid = (first+last)/2;
j = TclDatembchars[mid].character;
if( j==i ){/*Found*/
return TclDatembchars[mid].tvalue;
}else if( j= 0;
TclDate_i++ )
{
if ( TclDatetoks[TclDate_i].t_val == TclDatechar )
break;
}
printf( "%s\n", TclDatetoks[TclDate_i].t_name );
}
}
#endif /* YYDEBUG */
if ( ++TclDate_ps >= &TclDates[ TclDatemaxdepth ] ) /* room on stack? */
{
/*
** reallocate and recover. Note that pointers
** have to be reset, or bad things will happen
*/
long TclDateps_index = (TclDate_ps - TclDates);
long TclDatepv_index = (TclDate_pv - TclDatev);
long TclDatepvt_index = (TclDatepvt - TclDatev);
int TclDatenewmax;
#ifdef YYEXPAND
TclDatenewmax = YYEXPAND(TclDatemaxdepth);
#else
TclDatenewmax = 2 * TclDatemaxdepth; /* double table size */
if (TclDatemaxdepth == YYMAXDEPTH) /* first time growth */
{
char *newTclDates = (char *)YYNEW(int);
char *newTclDatev = (char *)YYNEW(YYSTYPE);
if (newTclDates != 0 && newTclDatev != 0)
{
TclDates = YYCOPY(newTclDates, TclDates, int);
TclDatev = YYCOPY(newTclDatev, TclDatev, YYSTYPE);
}
else
TclDatenewmax = 0; /* failed */
}
else /* not first time */
{
TclDates = YYENLARGE(TclDates, int);
TclDatev = YYENLARGE(TclDatev, YYSTYPE);
if (TclDates == 0 || TclDatev == 0)
TclDatenewmax = 0; /* failed */
}
#endif
if (TclDatenewmax <= TclDatemaxdepth) /* tables not expanded */
{
TclDateerror( "yacc stack overflow" );
YYABORT;
}
TclDatemaxdepth = TclDatenewmax;
TclDate_ps = TclDates + TclDateps_index;
TclDate_pv = TclDatev + TclDatepv_index;
TclDatepvt = TclDatev + TclDatepvt_index;
}
*TclDate_ps = TclDate_state;
*++TclDate_pv = TclDateval;
/*
** we have a new state - find out what to do
*/
TclDate_newstate:
if ( ( TclDate_n = TclDatepact[ TclDate_state ] ) <= YYFLAG )
goto TclDatedefault; /* simple state */
#if YYDEBUG
/*
** if debugging, need to mark whether new token grabbed
*/
TclDatetmp = TclDatechar < 0;
#endif
if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) )
TclDatechar = 0; /* reached EOF */
#if YYDEBUG
if ( TclDatedebug && TclDatetmp )
{
register int TclDate_i;
printf( "Received token " );
if ( TclDatechar == 0 )
printf( "end-of-file\n" );
else if ( TclDatechar < 0 )
printf( "-none-\n" );
else
{
for ( TclDate_i = 0; TclDatetoks[TclDate_i].t_val >= 0;
TclDate_i++ )
{
if ( TclDatetoks[TclDate_i].t_val == TclDatechar )
break;
}
printf( "%s\n", TclDatetoks[TclDate_i].t_name );
}
}
#endif /* YYDEBUG */
if ( ( ( TclDate_n += TclDatechar ) < 0 ) || ( TclDate_n >= YYLAST ) )
goto TclDatedefault;
if ( TclDatechk[ TclDate_n = TclDateact[ TclDate_n ] ] == TclDatechar ) /*valid shift*/
{
TclDatechar = -1;
TclDateval = TclDatelval;
TclDate_state = TclDate_n;
if ( TclDateerrflag > 0 )
TclDateerrflag--;
goto TclDate_stack;
}
TclDatedefault:
if ( ( TclDate_n = TclDatedef[ TclDate_state ] ) == -2 )
{
#if YYDEBUG
TclDatetmp = TclDatechar < 0;
#endif
if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) )
TclDatechar = 0; /* reached EOF */
#if YYDEBUG
if ( TclDatedebug && TclDatetmp )
{
register int TclDate_i;
printf( "Received token " );
if ( TclDatechar == 0 )
printf( "end-of-file\n" );
else if ( TclDatechar < 0 )
printf( "-none-\n" );
else
{
for ( TclDate_i = 0;
TclDatetoks[TclDate_i].t_val >= 0;
TclDate_i++ )
{
if ( TclDatetoks[TclDate_i].t_val
== TclDatechar )
{
break;
}
}
printf( "%s\n", TclDatetoks[TclDate_i].t_name );
}
}
#endif /* YYDEBUG */
/*
** look through exception table
*/
{
register CONST int *TclDatexi = TclDateexca;
while ( ( *TclDatexi != -1 ) ||
( TclDatexi[1] != TclDate_state ) )
{
TclDatexi += 2;
}
while ( ( *(TclDatexi += 2) >= 0 ) &&
( *TclDatexi != TclDatechar ) )
;
if ( ( TclDate_n = TclDatexi[1] ) < 0 )
YYACCEPT;
}
}
/*
** check for syntax error
*/
if ( TclDate_n == 0 ) /* have an error */
{
/* no worry about speed here! */
switch ( TclDateerrflag )
{
case 0: /* new error */
TclDateerror( "syntax error" );
goto skip_init;
/*
** get globals into registers.
** we have a user generated syntax type error
*/
TclDate_pv = TclDatepv;
TclDate_ps = TclDateps;
TclDate_state = TclDatestate;
skip_init:
TclDatenerrs++;
/* FALLTHRU */
case 1:
case 2: /* incompletely recovered error */
/* try again... */
TclDateerrflag = 3;
/*
** find state where "error" is a legal
** shift action
*/
while ( TclDate_ps >= TclDates )
{
TclDate_n = TclDatepact[ *TclDate_ps ] + YYERRCODE;
if ( TclDate_n >= 0 && TclDate_n < YYLAST &&
TclDatechk[TclDateact[TclDate_n]] == YYERRCODE) {
/*
** simulate shift of "error"
*/
TclDate_state = TclDateact[ TclDate_n ];
goto TclDate_stack;
}
/*
** current state has no shift on
** "error", pop stack
*/
#if YYDEBUG
# define _POP_ "Error recovery pops state %d, uncovers state %d\n"
if ( TclDatedebug )
printf( _POP_, *TclDate_ps,
TclDate_ps[-1] );
# undef _POP_
#endif
TclDate_ps--;
TclDate_pv--;
}
/*
** there is no state on stack with "error" as
** a valid shift. give up.
*/
YYABORT;
case 3: /* no shift yet; eat a token */
#if YYDEBUG
/*
** if debugging, look up token in list of
** pairs. 0 and negative shouldn't occur,
** but since timing doesn't matter when
** debugging, it doesn't hurt to leave the
** tests here.
*/
if ( TclDatedebug )
{
register int TclDate_i;
printf( "Error recovery discards " );
if ( TclDatechar == 0 )
printf( "token end-of-file\n" );
else if ( TclDatechar < 0 )
printf( "token -none-\n" );
else
{
for ( TclDate_i = 0;
TclDatetoks[TclDate_i].t_val >= 0;
TclDate_i++ )
{
if ( TclDatetoks[TclDate_i].t_val
== TclDatechar )
{
break;
}
}
printf( "token %s\n",
TclDatetoks[TclDate_i].t_name );
}
}
#endif /* YYDEBUG */
if ( TclDatechar == 0 ) /* reached EOF. quit */
YYABORT;
TclDatechar = -1;
goto TclDate_newstate;
}
}/* end if ( TclDate_n == 0 ) */
/*
** reduction by production TclDate_n
** put stack tops, etc. so things right after switch
*/
#if YYDEBUG
/*
** if debugging, print the string that is the user's
** specification of the reduction which is just about
** to be done.
*/
if ( TclDatedebug )
printf( "Reduce by (%d) \"%s\"\n",
TclDate_n, TclDatereds[ TclDate_n ] );
#endif
TclDatetmp = TclDate_n; /* value to switch over */
TclDatepvt = TclDate_pv; /* $vars top of value stack */
/*
** Look in goto table for next state
** Sorry about using TclDate_state here as temporary
** register variable, but why not, if it works...
** If TclDater2[ TclDate_n ] doesn't have the low order bit
** set, then there is no action to be done for
** this reduction. So, no saving & unsaving of
** registers done. The only difference between the
** code just after the if and the body of the if is
** the goto TclDate_stack in the body. This way the test
** can be made before the choice of what to do is needed.
*/
{
/* length of production doubled with extra bit */
register int TclDate_len = TclDater2[ TclDate_n ];
if ( !( TclDate_len & 01 ) )
{
TclDate_len >>= 1;
TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */
TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] +
*( TclDate_ps -= TclDate_len ) + 1;
if ( TclDate_state >= YYLAST ||
TclDatechk[ TclDate_state =
TclDateact[ TclDate_state ] ] != -TclDate_n )
{
TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ];
}
goto TclDate_stack;
}
TclDate_len >>= 1;
TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */
TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] +
*( TclDate_ps -= TclDate_len ) + 1;
if ( TclDate_state >= YYLAST ||
TclDatechk[ TclDate_state = TclDateact[ TclDate_state ] ] != -TclDate_n )
{
TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ];
}
}
/* save until reenter driver code */
TclDatestate = TclDate_state;
TclDateps = TclDate_ps;
TclDatepv = TclDate_pv;
}
/*
** code supplied by user is placed in this switch
*/
switch( TclDatetmp )
{
case 3:{
TclDateHaveTime++;
} break;
case 4:{
TclDateHaveZone++;
} break;
case 5:{
TclDateHaveDate++;
} break;
case 6:{
TclDateHaveOrdinalMonth++;
} break;
case 7:{
TclDateHaveDay++;
} break;
case 8:{
TclDateHaveRel++;
} break;
case 9:{
TclDateHaveTime++;
TclDateHaveDate++;
} break;
case 10:{
TclDateHaveTime++;
TclDateHaveDate++;
TclDateHaveRel++;
} break;
case 12:{
TclDateHour = TclDatepvt[-1].Number;
TclDateMinutes = 0;
TclDateSeconds = 0;
TclDateMeridian = TclDatepvt[-0].Meridian;
} break;
case 13:{
TclDateHour = TclDatepvt[-3].Number;
TclDateMinutes = TclDatepvt[-1].Number;
TclDateSeconds = 0;
TclDateMeridian = TclDatepvt[-0].Meridian;
} break;
case 14:{
TclDateHour = TclDatepvt[-4].Number;
TclDateMinutes = TclDatepvt[-2].Number;
TclDateMeridian = MER24;
TclDateDSTmode = DSToff;
TclDateTimezone = (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60);
} break;
case 15:{
TclDateHour = TclDatepvt[-5].Number;
TclDateMinutes = TclDatepvt[-3].Number;
TclDateSeconds = TclDatepvt[-1].Number;
TclDateMeridian = TclDatepvt[-0].Meridian;
} break;
case 16:{
TclDateHour = TclDatepvt[-6].Number;
TclDateMinutes = TclDatepvt[-4].Number;
TclDateSeconds = TclDatepvt[-2].Number;
TclDateMeridian = MER24;
TclDateDSTmode = DSToff;
TclDateTimezone = (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60);
} break;
case 17:{
TclDateTimezone = TclDatepvt[-1].Number;
TclDateDSTmode = DSTon;
} break;
case 18:{
TclDateTimezone = TclDatepvt[-0].Number;
TclDateDSTmode = DSToff;
} break;
case 19:{
TclDateTimezone = TclDatepvt[-0].Number;
TclDateDSTmode = DSTon;
} break;
case 20:{
TclDateDayOrdinal = 1;
TclDateDayNumber = TclDatepvt[-0].Number;
} break;
case 21:{
TclDateDayOrdinal = 1;
TclDateDayNumber = TclDatepvt[-1].Number;
} break;
case 22:{
TclDateDayOrdinal = TclDatepvt[-1].Number;
TclDateDayNumber = TclDatepvt[-0].Number;
} break;
case 23:{
TclDateDayOrdinal = TclDatepvt[-2].Number * TclDatepvt[-1].Number;
TclDateDayNumber = TclDatepvt[-0].Number;
} break;
case 24:{
TclDateDayOrdinal = 2;
TclDateDayNumber = TclDatepvt[-0].Number;
} break;
case 25:{
TclDateMonth = TclDatepvt[-2].Number;
TclDateDay = TclDatepvt[-0].Number;
} break;
case 26:{
TclDateMonth = TclDatepvt[-4].Number;
TclDateDay = TclDatepvt[-2].Number;
TclDateYear = TclDatepvt[-0].Number;
} break;
case 27:{
TclDateYear = TclDatepvt[-0].Number / 10000;
TclDateMonth = (TclDatepvt[-0].Number % 10000)/100;
TclDateDay = TclDatepvt[-0].Number % 100;
} break;
case 28:{
TclDateDay = TclDatepvt[-4].Number;
TclDateMonth = TclDatepvt[-2].Number;
TclDateYear = TclDatepvt[-0].Number;
} break;
case 29:{
TclDateMonth = TclDatepvt[-2].Number;
TclDateDay = TclDatepvt[-0].Number;
TclDateYear = TclDatepvt[-4].Number;
} break;
case 30:{
TclDateMonth = TclDatepvt[-1].Number;
TclDateDay = TclDatepvt[-0].Number;
} break;
case 31:{
TclDateMonth = TclDatepvt[-3].Number;
TclDateDay = TclDatepvt[-2].Number;
TclDateYear = TclDatepvt[-0].Number;
} break;
case 32:{
TclDateMonth = TclDatepvt[-0].Number;
TclDateDay = TclDatepvt[-1].Number;
} break;
case 33:{
TclDateMonth = 1;
TclDateDay = 1;
TclDateYear = EPOCH;
} break;
case 34:{
TclDateMonth = TclDatepvt[-1].Number;
TclDateDay = TclDatepvt[-2].Number;
TclDateYear = TclDatepvt[-0].Number;
} break;
case 35:{
TclDateMonthOrdinal = 1;
TclDateMonth = TclDatepvt[-0].Number;
} break;
case 36:{
TclDateMonthOrdinal = TclDatepvt[-1].Number;
TclDateMonth = TclDatepvt[-0].Number;
} break;
case 37:{
if (TclDatepvt[-1].Number != HOUR(- 7)) YYABORT;
TclDateYear = TclDatepvt[-2].Number / 10000;
TclDateMonth = (TclDatepvt[-2].Number % 10000)/100;
TclDateDay = TclDatepvt[-2].Number % 100;
TclDateHour = TclDatepvt[-0].Number / 10000;
TclDateMinutes = (TclDatepvt[-0].Number % 10000)/100;
TclDateSeconds = TclDatepvt[-0].Number % 100;
} break;
case 38:{
if (TclDatepvt[-5].Number != HOUR(- 7)) YYABORT;
TclDateYear = TclDatepvt[-6].Number / 10000;
TclDateMonth = (TclDatepvt[-6].Number % 10000)/100;
TclDateDay = TclDatepvt[-6].Number % 100;
TclDateHour = TclDatepvt[-4].Number;
TclDateMinutes = TclDatepvt[-2].Number;
TclDateSeconds = TclDatepvt[-0].Number;
} break;
case 39:{
TclDateYear = TclDatepvt[-1].Number / 10000;
TclDateMonth = (TclDatepvt[-1].Number % 10000)/100;
TclDateDay = TclDatepvt[-1].Number % 100;
TclDateHour = TclDatepvt[-0].Number / 10000;
TclDateMinutes = (TclDatepvt[-0].Number % 10000)/100;
TclDateSeconds = TclDatepvt[-0].Number % 100;
} break;
case 40:{
/*
* Offset computed year by -377 so that the returned years will
* be in a range accessible with a 32 bit clock seconds value
*/
TclDateYear = TclDatepvt[-2].Number/1000 + 2323 - 377;
TclDateDay = 1;
TclDateMonth = 1;
TclDateRelDay += ((TclDatepvt[-2].Number%1000)*(365 + IsLeapYear(TclDateYear)))/1000;
TclDateRelSeconds += TclDatepvt[-0].Number * 144 * 60;
} break;
case 41:{
TclDateRelSeconds *= -1;
TclDateRelMonth *= -1;
TclDateRelDay *= -1;
} break;
case 43:{ *TclDateRelPointer += TclDatepvt[-2].Number * TclDatepvt[-1].Number * TclDatepvt[-0].Number; } break;
case 44:{ *TclDateRelPointer += TclDatepvt[-1].Number * TclDatepvt[-0].Number; } break;
case 45:{ *TclDateRelPointer += TclDatepvt[-0].Number; } break;
case 46:{ *TclDateRelPointer += TclDatepvt[-1].Number * TclDatepvt[-0].Number; } break;
case 47:{ *TclDateRelPointer += TclDatepvt[-0].Number; } break;
case 48:{ TclDateval.Number = -1; } break;
case 49:{ TclDateval.Number = 1; } break;
case 50:{ TclDateval.Number = TclDatepvt[-0].Number; TclDateRelPointer = &TclDateRelSeconds; } break;
case 51:{ TclDateval.Number = TclDatepvt[-0].Number; TclDateRelPointer = &TclDateRelDay; } break;
case 52:{ TclDateval.Number = TclDatepvt[-0].Number; TclDateRelPointer = &TclDateRelMonth; } break;
case 53:{
if (TclDateHaveTime && TclDateHaveDate && !TclDateHaveRel) {
TclDateYear = TclDatepvt[-0].Number;
} else {
TclDateHaveTime++;
if (TclDatepvt[-0].Number < 100) {
TclDateHour = TclDatepvt[-0].Number;
TclDateMinutes = 0;
} else {
TclDateHour = TclDatepvt[-0].Number / 100;
TclDateMinutes = TclDatepvt[-0].Number % 100;
}
TclDateSeconds = 0;
TclDateMeridian = MER24;
}
} break;
case 54:{
TclDateval.Meridian = MER24;
} break;
case 55:{
TclDateval.Meridian = TclDatepvt[-0].Meridian;
} break;
}
goto TclDatestack; /* reset registers in driver code */
}
tcl8.4.20/generic/tclStubLib.c 0000644 0036047 0045461 00000005515 12133546540 014545 0 ustar dgp 771div /*
* tclStubLib.c --
*
* Stub object that will be statically linked into extensions that want
* to access Tcl.
*
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 1998 Paul Duffin.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
TclStubs *tclStubsPtr = NULL;
TclPlatStubs *tclPlatStubsPtr = NULL;
TclIntStubs *tclIntStubsPtr = NULL;
TclIntPlatStubs *tclIntPlatStubsPtr = NULL;
/*
* Use our own ISDIGIT to avoid linking to libc on windows
*/
#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9)
/*
*----------------------------------------------------------------------
*
* Tcl_InitStubs --
*
* Tries to initialise the stub table pointers and ensures that the
* correct version of Tcl is loaded.
*
* Results:
* The actual version of Tcl that satisfies the request, or NULL to
* indicate that an error occurred.
*
* Side effects:
* Sets the stub table pointers.
*
*----------------------------------------------------------------------
*/
#undef Tcl_InitStubs
CONST char *
Tcl_InitStubs(interp, version, exact)
Tcl_Interp *interp;
CONST char *version;
int exact;
{
Interp *iPtr = (Interp *) interp;
CONST char *actualVersion = NULL;
ClientData pkgData = NULL;
TclStubs *stubsPtr = iPtr->stubTable;
/*
* We can't optimize this check by caching tclStubsPtr because that
* prevents apps from being able to load/unload Tcl dynamically multiple
* times. [Bug 615304]
*/
if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) {
iPtr->result = "interpreter uses an incompatible stubs mechanism";
iPtr->freeProc = TCL_STATIC;
return NULL;
}
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData);
if (actualVersion == NULL) {
return NULL;
}
if (exact) {
CONST char *p = version;
int count = 0;
while (*p) {
count += !ISDIGIT(*p++);
}
if (count == 1) {
CONST char *q = actualVersion;
p = version;
while (*p && (*p == *q)) {
p++; q++;
}
if (*p || ISDIGIT(*q)) {
/* Construct error message */
stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
return NULL;
}
} else {
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
if (actualVersion == NULL) {
return NULL;
}
}
}
tclStubsPtr = (TclStubs *)pkgData;
if (tclStubsPtr->hooks) {
tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
} else {
tclPlatStubsPtr = NULL;
tclIntStubsPtr = NULL;
tclIntPlatStubsPtr = NULL;
}
return actualVersion;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclFileName.c 0000644 0036047 0045461 00000164106 12133546540 014663 0 ustar dgp 771div /*
* tclFileName.c --
*
* This file contains routines for converting file names betwen
* native and network form.
*
* Copyright (c) 1995-1998 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include
#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"
/*
* The following variable is set in the TclPlatformInit call to one
* of: TCL_PLATFORM_UNIX, or TCL_PLATFORM_WINDOWS.
*/
TclPlatformType tclPlatform = TCL_PLATFORM_UNIX;
/*
* Prototypes for local procedures defined in this file:
*/
static CONST char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *user, Tcl_DString *resultPtr));
static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path,
Tcl_DString *resultPtr, int offset,
Tcl_PathType *typePtr));
static int SkipToChar _ANSI_ARGS_((char **stringPtr,
char *match));
static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path));
static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path));
/*
*----------------------------------------------------------------------
*
* ExtractWinRoot --
*
* Matches the root portion of a Windows path and appends it
* to the specified Tcl_DString.
*
* Results:
* Returns the position in the path immediately after the root
* including any trailing slashes.
* Appends a cleaned up version of the root to the Tcl_DString
* at the specified offest.
*
* Side effects:
* Modifies the specified Tcl_DString.
*
*----------------------------------------------------------------------
*/
static CONST char *
ExtractWinRoot(path, resultPtr, offset, typePtr)
CONST char *path; /* Path to parse. */
Tcl_DString *resultPtr; /* Buffer to hold result. */
int offset; /* Offset in buffer where result should be
* stored. */
Tcl_PathType *typePtr; /* Where to store pathType result */
{
if (path[0] == '/' || path[0] == '\\') {
/* Might be a UNC or Vol-Relative path */
CONST char *host, *share, *tail;
int hlen, slen;
if (path[1] != '/' && path[1] != '\\') {
Tcl_DStringSetLength(resultPtr, offset);
*typePtr = TCL_PATH_VOLUME_RELATIVE;
Tcl_DStringAppend(resultPtr, "/", 1);
return &path[1];
}
host = &path[2];
/* Skip separators */
while (host[0] == '/' || host[0] == '\\') host++;
for (hlen = 0; host[hlen];hlen++) {
if (host[hlen] == '/' || host[hlen] == '\\')
break;
}
if (host[hlen] == 0 || host[hlen+1] == 0) {
/*
* The path given is simply of the form
* '/foo', '//foo', '/////foo' or the same
* with backslashes. If there is exactly
* one leading '/' the path is volume relative
* (see filename man page). If there are more
* than one, we are simply assuming they
* are superfluous and we trim them away.
* (An alternative interpretation would
* be that it is a host name, but we have
* been documented that that is not the case).
*/
*typePtr = TCL_PATH_VOLUME_RELATIVE;
Tcl_DStringAppend(resultPtr, "/", 1);
return &path[2];
}
Tcl_DStringSetLength(resultPtr, offset);
share = &host[hlen];
/* Skip separators */
while (share[0] == '/' || share[0] == '\\') share++;
for (slen = 0; share[slen];slen++) {
if (share[slen] == '/' || share[slen] == '\\')
break;
}
Tcl_DStringAppend(resultPtr, "//", 2);
Tcl_DStringAppend(resultPtr, host, hlen);
Tcl_DStringAppend(resultPtr, "/", 1);
Tcl_DStringAppend(resultPtr, share, slen);
tail = &share[slen];
/* Skip separators */
while (tail[0] == '/' || tail[0] == '\\') tail++;
*typePtr = TCL_PATH_ABSOLUTE;
return tail;
} else if (*path && path[1] == ':') {
/* Might be a drive sep */
Tcl_DStringSetLength(resultPtr, offset);
if (path[2] != '/' && path[2] != '\\') {
*typePtr = TCL_PATH_VOLUME_RELATIVE;
Tcl_DStringAppend(resultPtr, path, 2);
return &path[2];
} else {
char *tail = (char*)&path[3];
/* Skip separators */
while (*tail && (tail[0] == '/' || tail[0] == '\\')) tail++;
*typePtr = TCL_PATH_ABSOLUTE;
Tcl_DStringAppend(resultPtr, path, 2);
Tcl_DStringAppend(resultPtr, "/", 1);
return tail;
}
} else {
int abs = 0;
if ((path[0] == 'c' || path[0] == 'C')
&& (path[1] == 'o' || path[1] == 'O')) {
if ((path[2] == 'm' || path[2] == 'M')
&& path[3] >= '1' && path[3] <= '4') {
/* May have match for 'com[1-4]:?', which is a serial port */
if (path[4] == '\0') {
abs = 4;
} else if (path [4] == ':' && path[5] == '\0') {
abs = 5;
}
} else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') {
/* Have match for 'con' */
abs = 3;
}
} else if ((path[0] == 'l' || path[0] == 'L')
&& (path[1] == 'p' || path[1] == 'P')
&& (path[2] == 't' || path[2] == 'T')) {
if (path[3] >= '1' && path[3] <= '3') {
/* May have match for 'lpt[1-3]:?' */
if (path[4] == '\0') {
abs = 4;
} else if (path [4] == ':' && path[5] == '\0') {
abs = 5;
}
}
} else if ((path[0] == 'p' || path[0] == 'P')
&& (path[1] == 'r' || path[1] == 'R')
&& (path[2] == 'n' || path[2] == 'N')
&& path[3] == '\0') {
/* Have match for 'prn' */
abs = 3;
} else if ((path[0] == 'n' || path[0] == 'N')
&& (path[1] == 'u' || path[1] == 'U')
&& (path[2] == 'l' || path[2] == 'L')
&& path[3] == '\0') {
/* Have match for 'nul' */
abs = 3;
} else if ((path[0] == 'a' || path[0] == 'A')
&& (path[1] == 'u' || path[1] == 'U')
&& (path[2] == 'x' || path[2] == 'X')
&& path[3] == '\0') {
/* Have match for 'aux' */
abs = 3;
}
if (abs != 0) {
*typePtr = TCL_PATH_ABSOLUTE;
Tcl_DStringSetLength(resultPtr, offset);
Tcl_DStringAppend(resultPtr, path, abs);
return path + abs;
}
}
/* Anything else is treated as relative */
*typePtr = TCL_PATH_RELATIVE;
return path;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetPathType --
*
* Determines whether a given path is relative to the current
* directory, relative to the current volume, or absolute.
*
* The objectified Tcl_FSGetPathType should be used in
* preference to this function (as you can see below, this
* is just a wrapper around that other function).
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
* TCL_PATH_VOLUME_RELATIVE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_PathType
Tcl_GetPathType(path)
CONST char *path;
{
Tcl_PathType type;
Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(tempObj);
type = Tcl_FSGetPathType(tempObj);
Tcl_DecrRefCount(tempObj);
return type;
}
/*
*----------------------------------------------------------------------
*
* TclpGetNativePathType --
*
* Determines whether a given path is relative to the current
* directory, relative to the current volume, or absolute, but
* ONLY FOR THE NATIVE FILESYSTEM. This function is called from
* tclIOUtil.c (but needs to be here due to its dependence on
* static variables/functions in this file). The exported
* function Tcl_FSGetPathType should be used by extensions.
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
* TCL_PATH_VOLUME_RELATIVE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_PathType
TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef)
Tcl_Obj *pathObjPtr;
int *driveNameLengthPtr;
Tcl_Obj **driveNameRef;
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
int pathLen;
char *path = Tcl_GetStringFromObj(pathObjPtr, &pathLen);
if (path[0] == '~') {
/*
* This case is common to all platforms.
* Paths that begin with ~ are absolute.
*/
if (driveNameLengthPtr != NULL) {
char *end = path + 1;
while ((*end != '\0') && (*end != '/')) {
end++;
}
*driveNameLengthPtr = end - path;
}
} else {
switch (tclPlatform) {
case TCL_PLATFORM_UNIX: {
char *origPath = path;
/*
* Paths that begin with / are absolute.
*/
#ifdef __QNX__
/*
* Check for QNX // prefix
*/
if (*path && (pathLen > 3) && (path[0] == '/')
&& (path[1] == '/') && isdigit(UCHAR(path[2]))) {
path += 3;
while (isdigit(UCHAR(*path))) {
++path;
}
}
#endif
if (path[0] == '/') {
if (driveNameLengthPtr != NULL) {
/*
* We need this addition in case the QNX code
* was used
*/
*driveNameLengthPtr = (1 + path - origPath);
}
} else {
type = TCL_PATH_RELATIVE;
}
break;
}
case TCL_PLATFORM_WINDOWS: {
Tcl_DString ds;
CONST char *rootEnd;
Tcl_DStringInit(&ds);
rootEnd = ExtractWinRoot(path, &ds, 0, &type);
if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
*driveNameLengthPtr = rootEnd - path;
if (driveNameRef != NULL) {
*driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_IncrRefCount(*driveNameRef);
}
}
Tcl_DStringFree(&ds);
break;
}
}
}
return type;
}
/*
*---------------------------------------------------------------------------
*
* TclpNativeSplitPath --
*
* This function takes the given Tcl_Obj, which should be a valid
* path, and returns a Tcl List object containing each segment
* of that path as an element.
*
* Note this function currently calls the older Split(Plat)Path
* functions, which require more memory allocation than is
* desirable.
*
* Results:
* Returns list object with refCount of zero. If the passed in
* lenPtr is non-NULL, we use it to return the number of elements
* in the returned list.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclpNativeSplitPath(pathPtr, lenPtr)
Tcl_Obj *pathPtr; /* Path to split. */
int *lenPtr; /* int to store number of path elements. */
{
Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
/*
* Perform platform specific splitting.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
resultPtr = SplitUnixPath(Tcl_GetString(pathPtr));
break;
case TCL_PLATFORM_WINDOWS:
resultPtr = SplitWinPath(Tcl_GetString(pathPtr));
break;
}
/*
* Compute the number of elements in the result.
*/
if (lenPtr != NULL) {
Tcl_ListObjLength(NULL, resultPtr, lenPtr);
}
return resultPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SplitPath --
*
* Split a path into a list of path components. The first element
* of the list will have the same path type as the original path.
*
* Results:
* Returns a standard Tcl result. The interpreter result contains
* a list of path components.
* *argvPtr will be filled in with the address of an array
* whose elements point to the elements of path, in order.
* *argcPtr will get filled in with the number of valid elements
* in the array. A single block of memory is dynamically allocated
* to hold both the argv array and a copy of the path elements.
* The caller must eventually free this memory by calling ckfree()
* on *argvPtr. Note: *argvPtr and *argcPtr are only modified
* if the procedure returns normally.
*
* Side effects:
* Allocates memory.
*
*----------------------------------------------------------------------
*/
void
Tcl_SplitPath(path, argcPtr, argvPtr)
CONST char *path; /* Pointer to string containing a path. */
int *argcPtr; /* Pointer to location to fill in with
* the number of elements in the path. */
CONST char ***argvPtr; /* Pointer to place to store pointer to array
* of pointers to path elements. */
{
Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
Tcl_Obj *tmpPtr, *eltPtr;
int i, size, len;
char *p, *str;
/*
* Perform the splitting, using objectified, vfs-aware code.
*/
tmpPtr = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(tmpPtr);
resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
Tcl_DecrRefCount(tmpPtr);
/* Calculate space required for the result */
size = 1;
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
Tcl_GetStringFromObj(eltPtr, &len);
size += len + 1;
}
/*
* Allocate a buffer large enough to hold the contents of all of
* the list plus the argv pointers and the terminating NULL pointer.
*/
*argvPtr = (CONST char **) ckalloc((unsigned)
((((*argcPtr) + 1) * sizeof(char *)) + size));
/*
* Position p after the last argv pointer and copy the contents of
* the list in, piece by piece.
*/
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
str = Tcl_GetStringFromObj(eltPtr, &len);
memcpy((VOID *) p, (VOID *) str, (size_t) len+1);
p += len+1;
}
/*
* Now set up the argv pointers.
*/
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
for (i = 0; i < *argcPtr; i++) {
(*argvPtr)[i] = p;
while ((*p++) != '\0') {}
}
(*argvPtr)[i] = NULL;
/*
* Free the result ptr given to us by Tcl_FSSplitPath
*/
Tcl_DecrRefCount(resultPtr);
}
/*
*----------------------------------------------------------------------
*
* SplitUnixPath --
*
* This routine is used by Tcl_(FS)SplitPath to handle splitting
* Unix paths.
*
* Results:
* Returns a newly allocated Tcl list object.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj*
SplitUnixPath(path)
CONST char *path; /* Pointer to string containing a path. */
{
int length;
CONST char *p, *elementStart;
Tcl_Obj *result = Tcl_NewObj();
/*
* Deal with the root directory as a special case.
*/
#ifdef __QNX__
/*
* Check for QNX // prefix
*/
if ((path[0] == '/') && (path[1] == '/')
&& isdigit(UCHAR(path[2]))) { /* INTL: digit */
path += 3;
while (isdigit(UCHAR(*path))) { /* INTL: digit */
++path;
}
}
#endif
if (path[0] == '/') {
Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1));
p = path+1;
} else {
p = path;
}
/*
* Split on slashes. Embedded elements that start with tilde will be
* prefixed with "./" so they are not affected by tilde substitution.
*/
for (;;) {
elementStart = p;
while ((*p != '\0') && (*p != '/')) {
p++;
}
length = p - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
if ((elementStart[0] == '~') && (elementStart != path)) {
nextElt = Tcl_NewStringObj("./",2);
Tcl_AppendToObj(nextElt, elementStart, length);
} else {
nextElt = Tcl_NewStringObj(elementStart, length);
}
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
if (*p++ == '\0') {
break;
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* SplitWinPath --
*
* This routine is used by Tcl_(FS)SplitPath to handle splitting
* Windows paths.
*
* Results:
* Returns a newly allocated Tcl list object.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj*
SplitWinPath(path)
CONST char *path; /* Pointer to string containing a path. */
{
int length;
CONST char *p, *elementStart;
Tcl_PathType type = TCL_PATH_ABSOLUTE;
Tcl_DString buf;
Tcl_Obj *result = Tcl_NewObj();
Tcl_DStringInit(&buf);
p = ExtractWinRoot(path, &buf, 0, &type);
/*
* Terminate the root portion, if we matched something.
*/
if (p != path) {
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf)));
}
Tcl_DStringFree(&buf);
/*
* Split on slashes. Embedded elements that start with tilde
* or a drive letter will be prefixed with "./" so they are not
* affected by tilde substitution.
*/
do {
elementStart = p;
while ((*p != '\0') && (*p != '/') && (*p != '\\')) {
p++;
}
length = p - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
if ((elementStart != path)
&& ((elementStart[0] == '~')
|| (isalpha(UCHAR(elementStart[0]))
&& elementStart[1] == ':'))) {
nextElt = Tcl_NewStringObj("./",2);
Tcl_AppendToObj(nextElt, elementStart, length);
} else {
nextElt = Tcl_NewStringObj(elementStart, length);
}
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
} while (*p++ != '\0');
return result;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSJoinToPath --
*
* This function takes the given object, which should usually be a
* valid path or NULL, and joins onto it the array of paths
* segments given.
*
* Results:
* Returns object with refCount of zero
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSJoinToPath(basePtr, objc, objv)
Tcl_Obj *basePtr;
int objc;
Tcl_Obj *CONST objv[];
{
int i;
Tcl_Obj *lobj, *ret;
if (basePtr == NULL) {
lobj = Tcl_NewListObj(0, NULL);
} else {
lobj = Tcl_NewListObj(1, &basePtr);
}
for (i = 0; i 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
Tcl_GetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and trailing
* slashes.
*/
Tcl_SetObjLength(prefix, length + (int) strlen(p));
dest = Tcl_GetString(prefix) + length;
for (; *p != '\0'; p++) {
if (*p == '/') {
while (p[1] == '/') {
p++;
}
if (p[1] != '\0') {
if (needsSep) {
*dest++ = '/';
}
}
} else {
*dest++ = *p;
needsSep = 1;
}
}
length = dest - Tcl_GetString(prefix);
Tcl_SetObjLength(prefix, length);
break;
case TCL_PLATFORM_WINDOWS:
/*
* Check to see if we need to append a separator.
*/
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
Tcl_GetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and
* trailing slashes.
*/
Tcl_SetObjLength(prefix, length + (int) strlen(p));
dest = Tcl_GetString(prefix) + length;
for (; *p != '\0'; p++) {
if ((*p == '/') || (*p == '\\')) {
while ((p[1] == '/') || (p[1] == '\\')) {
p++;
}
if ((p[1] != '\0') && needsSep) {
*dest++ = '/';
}
} else {
*dest++ = *p;
needsSep = 1;
}
}
length = dest - Tcl_GetString(prefix);
Tcl_SetObjLength(prefix, length);
break;
}
return;
}
/*
*----------------------------------------------------------------------
*
* Tcl_JoinPath --
*
* Combine a list of paths in a platform specific manner. The
* function 'Tcl_FSJoinPath' should be used in preference where
* possible.
*
* Results:
* Appends the joined path to the end of the specified
* Tcl_DString returning a pointer to the resulting string. Note
* that the Tcl_DString must already be initialized.
*
* Side effects:
* Modifies the Tcl_DString.
*
*----------------------------------------------------------------------
*/
char *
Tcl_JoinPath(argc, argv, resultPtr)
int argc;
CONST char * CONST *argv;
Tcl_DString *resultPtr; /* Pointer to previously initialized DString */
{
int i, len;
Tcl_Obj *listObj = Tcl_NewObj();
Tcl_Obj *resultObj;
char *resultStr;
/* Build the list of paths */
for (i = 0; i < argc; i++) {
Tcl_ListObjAppendElement(NULL, listObj,
Tcl_NewStringObj(argv[i], -1));
}
/* Ask the objectified code to join the paths */
Tcl_IncrRefCount(listObj);
resultObj = Tcl_FSJoinPath(listObj, argc);
Tcl_IncrRefCount(resultObj);
Tcl_DecrRefCount(listObj);
/* Store the result */
resultStr = Tcl_GetStringFromObj(resultObj, &len);
Tcl_DStringAppend(resultPtr, resultStr, len);
Tcl_DecrRefCount(resultObj);
/* Return a pointer to the result */
return Tcl_DStringValue(resultPtr);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_TranslateFileName --
*
* Converts a file name into a form usable by the native system
* interfaces. If the name starts with a tilde, it will produce a
* name where the tilde and following characters have been replaced
* by the home directory location for the named user.
*
* Results:
* The return value is a pointer to a string containing the name
* after tilde substitution. If there was no tilde substitution,
* the return value is a pointer to a copy of the original string.
* If there was an error in processing the name, then an error
* message is left in the interp's result (if interp was not NULL)
* and the return value is NULL. Space for the return value is
* allocated in bufferPtr; the caller must call Tcl_DStringFree()
* to free the space if the return value was not NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
Tcl_TranslateFileName(interp, name, bufferPtr)
Tcl_Interp *interp; /* Interpreter in which to store error
* message (if necessary). */
CONST char *name; /* File name, which may begin with "~" (to
* indicate current user's home directory) or
* "~" (to indicate any user's home
* directory). */
Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
* with name after tilde substitution. */
{
Tcl_Obj *path = Tcl_NewStringObj(name, -1);
Tcl_Obj *transPtr;
Tcl_IncrRefCount(path);
transPtr = Tcl_FSGetTranslatedPath(interp, path);
if (transPtr == NULL) {
Tcl_DecrRefCount(path);
return NULL;
}
Tcl_DStringInit(bufferPtr);
Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1);
Tcl_DecrRefCount(path);
Tcl_DecrRefCount(transPtr);
/*
* Convert forward slashes to backslashes in Windows paths because
* some system interfaces don't accept forward slashes.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
register char *p;
for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
if (*p == '/') {
*p = '\\';
}
}
}
return Tcl_DStringValue(bufferPtr);
}
/*
*----------------------------------------------------------------------
*
* TclGetExtension --
*
* This function returns a pointer to the beginning of the
* extension part of a file name.
*
* Results:
* Returns a pointer into name which indicates where the extension
* starts. If there is no extension, returns NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
TclGetExtension(name)
char *name; /* File name to parse. */
{
char *p, *lastSep;
/*
* First find the last directory separator.
*/
lastSep = NULL; /* Needed only to prevent gcc warnings. */
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
lastSep = strrchr(name, '/');
break;
case TCL_PLATFORM_WINDOWS:
lastSep = NULL;
for (p = name; *p != '\0'; p++) {
if (strchr("/\\:", *p) != NULL) {
lastSep = p;
}
}
break;
}
p = strrchr(name, '.');
if ((p != NULL) && (lastSep != NULL) && (lastSep > p)) {
p = NULL;
}
/*
* In earlier versions, we used to back up to the first period in a series
* so that "foo..o" would be split into "foo" and "..o". This is a
* confusing and usually incorrect behavior, so now we split at the last
* period in the name.
*/
return p;
}
/*
*----------------------------------------------------------------------
*
* DoTildeSubst --
*
* Given a string following a tilde, this routine returns the
* corresponding home directory.
*
* Results:
* The result is a pointer to a static string containing the home
* directory in native format. If there was an error in processing
* the substitution, then an error message is left in the interp's
* result and the return value is NULL. On success, the results
* are appended to resultPtr, and the contents of resultPtr are
* returned.
*
* Side effects:
* Information may be left in resultPtr.
*
*----------------------------------------------------------------------
*/
static CONST char *
DoTildeSubst(interp, user, resultPtr)
Tcl_Interp *interp; /* Interpreter in which to store error
* message (if necessary). */
CONST char *user; /* Name of user whose home directory should be
* substituted, or "" for current user. */
Tcl_DString *resultPtr; /* Initialized DString filled with name
* after tilde substitution. */
{
CONST char *dir;
if (*user == '\0') {
Tcl_DString dirString;
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't find HOME environment ",
"variable to expand path", (char *) NULL);
}
return NULL;
}
Tcl_JoinPath(1, &dir, resultPtr);
Tcl_DStringFree(&dirString);
} else {
if (TclpGetUserHome(user, resultPtr) == NULL) {
if (interp) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
(char *) NULL);
}
return NULL;
}
}
return Tcl_DStringValue(resultPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GlobObjCmd --
*
* This procedure is invoked to process the "glob" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_GlobObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int index, i, globFlags, length, join, dir, result;
char *string, *separators;
Tcl_Obj *typePtr, *resultPtr, *look;
Tcl_Obj *pathOrDir = NULL;
Tcl_DString prefix;
static CONST char *options[] = {
"-directory", "-join", "-nocomplain", "-path", "-tails",
"-types", "--", NULL
};
enum options {
GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS,
GLOB_TYPE, GLOB_LAST
};
enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
Tcl_GlobTypeData *globTypes = NULL;
globFlags = 0;
join = 0;
dir = PATH_NONE;
typePtr = NULL;
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
!= TCL_OK) {
string = Tcl_GetStringFromObj(objv[i], &length);
if (string[0] == '-') {
/*
* It looks like the command contains an option so signal
* an error
*/
return TCL_ERROR;
} else {
/*
* This clearly isn't an option; assume it's the first
* glob pattern. We must clear the error
*/
Tcl_ResetResult(interp);
break;
}
}
switch (index) {
case GLOB_NOCOMPLAIN: /* -nocomplain */
globFlags |= TCL_GLOBMODE_NO_COMPLAIN;
break;
case GLOB_DIR: /* -dir */
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-directory\"", -1));
return TCL_ERROR;
}
if (dir != PATH_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-directory\" cannot be used with \"-path\"",
-1));
return TCL_ERROR;
}
dir = PATH_DIR;
globFlags |= TCL_GLOBMODE_DIR;
pathOrDir = objv[i+1];
i++;
break;
case GLOB_JOIN: /* -join */
join = 1;
break;
case GLOB_TAILS: /* -tails */
globFlags |= TCL_GLOBMODE_TAILS;
break;
case GLOB_PATH: /* -path */
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-path\"", -1));
return TCL_ERROR;
}
if (dir != PATH_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-path\" cannot be used with \"-directory\"",
-1));
return TCL_ERROR;
}
dir = PATH_GENERAL;
pathOrDir = objv[i+1];
i++;
break;
case GLOB_TYPE: /* -types */
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-types\"", -1));
return TCL_ERROR;
}
typePtr = objv[i+1];
if (Tcl_ListObjLength(interp, typePtr, &length) != TCL_OK) {
return TCL_ERROR;
}
i++;
break;
case GLOB_LAST: /* -- */
i++;
goto endOfForLoop;
}
}
endOfForLoop:
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
return TCL_ERROR;
}
if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-tails\" must be used with either \"-directory\" or \"-path\"",
-1));
return TCL_ERROR;
}
separators = NULL; /* lint. */
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
break;
case TCL_PLATFORM_WINDOWS:
separators = "/\\:";
break;
}
if (dir == PATH_GENERAL) {
int pathlength;
char *last;
char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
*/
last = first + pathlength;
for (; last != first; last--) {
if (strchr(separators, *(last-1)) != NULL) {
break;
}
}
if (last == first + pathlength) {
/* It's really a directory */
dir = PATH_DIR;
} else {
Tcl_DString pref;
char *search, *find;
Tcl_DStringInit(&pref);
if (last == first) {
/* The whole thing is a prefix */
Tcl_DStringAppend(&pref, first, -1);
pathOrDir = NULL;
} else {
/* Have to split off the end */
Tcl_DStringAppend(&pref, last, first+pathlength-last);
pathOrDir = Tcl_NewStringObj(first, last-first-1);
/*
* We must ensure that we haven't cut off too much,
* and turned a valid path like '/' or 'C:/' into
* an incorrect path like '' or 'C:'. The way we
* do this is to add a separator if there are none
* presently in the prefix.
*/
if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) {
Tcl_AppendToObj(pathOrDir, last-1, 1);
}
}
/* Need to quote 'prefix' */
Tcl_DStringInit(&prefix);
search = Tcl_DStringValue(&pref);
while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
Tcl_DStringAppend(&prefix, search, find-search);
Tcl_DStringAppend(&prefix, "\\", 1);
Tcl_DStringAppend(&prefix, find, 1);
search = find+1;
if (*search == '\0') {
break;
}
}
if (*search != '\0') {
Tcl_DStringAppend(&prefix, search, -1);
}
Tcl_DStringFree(&pref);
}
}
if (pathOrDir != NULL) {
Tcl_IncrRefCount(pathOrDir);
}
if (typePtr != NULL) {
/*
* The rest of the possible type arguments (except 'd') are
* platform specific. We don't complain when they are used
* on an incompatible platform.
*/
Tcl_ListObjLength(interp, typePtr, &length);
if (length <= 0) {
goto skipTypes;
}
globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData));
globTypes->type = 0;
globTypes->perm = 0;
globTypes->macType = NULL;
globTypes->macCreator = NULL;
while(--length >= 0) {
int len;
char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
str = Tcl_GetStringFromObj(look, &len);
if (strcmp("readonly", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_RONLY;
} else if (strcmp("hidden", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_HIDDEN;
} else if (len == 1) {
switch (str[0]) {
case 'r':
globTypes->perm |= TCL_GLOB_PERM_R;
break;
case 'w':
globTypes->perm |= TCL_GLOB_PERM_W;
break;
case 'x':
globTypes->perm |= TCL_GLOB_PERM_X;
break;
case 'b':
globTypes->type |= TCL_GLOB_TYPE_BLOCK;
break;
case 'c':
globTypes->type |= TCL_GLOB_TYPE_CHAR;
break;
case 'd':
globTypes->type |= TCL_GLOB_TYPE_DIR;
break;
case 'p':
globTypes->type |= TCL_GLOB_TYPE_PIPE;
break;
case 'f':
globTypes->type |= TCL_GLOB_TYPE_FILE;
break;
case 'l':
globTypes->type |= TCL_GLOB_TYPE_LINK;
break;
case 's':
globTypes->type |= TCL_GLOB_TYPE_SOCK;
break;
default:
goto badTypesArg;
}
} else if (len == 4) {
/* This is assumed to be a MacOS file type */
if (globTypes->macType != NULL) {
goto badMacTypesArg;
}
globTypes->macType = look;
Tcl_IncrRefCount(look);
} else {
Tcl_Obj* item;
if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
(len == 3)) {
Tcl_ListObjIndex(interp, look, 0, &item);
if (!strcmp("macintosh", Tcl_GetString(item))) {
Tcl_ListObjIndex(interp, look, 1, &item);
if (!strcmp("type", Tcl_GetString(item))) {
Tcl_ListObjIndex(interp, look, 2, &item);
if (globTypes->macType != NULL) {
goto badMacTypesArg;
}
globTypes->macType = item;
Tcl_IncrRefCount(item);
continue;
} else if (!strcmp("creator", Tcl_GetString(item))) {
Tcl_ListObjIndex(interp, look, 2, &item);
if (globTypes->macCreator != NULL) {
goto badMacTypesArg;
}
globTypes->macCreator = item;
Tcl_IncrRefCount(item);
continue;
}
}
}
/*
* Error cases. We reset
* the 'join' flag to zero, since we haven't yet
* made use of it.
*/
badTypesArg:
resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
Tcl_AppendObjToObj(resultPtr, look);
result = TCL_ERROR;
join = 0;
goto endOfGlob;
badMacTypesArg:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"only one MacOS type or creator argument"
" to \"-types\" allowed", -1));
result = TCL_ERROR;
join = 0;
goto endOfGlob;
}
}
}
skipTypes:
/*
* Now we perform the actual glob below. This may involve joining
* together the pattern arguments, dealing with particular file types
* etc. We use a 'goto' to ensure we free any memory allocated along
* the way.
*/
objc -= i;
objv += i;
result = TCL_OK;
if (join) {
if (dir != PATH_GENERAL) {
Tcl_DStringInit(&prefix);
}
for (i = 0; i < objc; i++) {
string = Tcl_GetStringFromObj(objv[i], &length);
Tcl_DStringAppend(&prefix, string, length);
if (i != objc -1) {
Tcl_DStringAppend(&prefix, separators, 1);
}
}
if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir,
globFlags, globTypes) != TCL_OK) {
result = TCL_ERROR;
goto endOfGlob;
}
} else {
if (dir == PATH_GENERAL) {
Tcl_DString str;
for (i = 0; i < objc; i++) {
Tcl_DStringInit(&str);
if (dir == PATH_GENERAL) {
Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix),
Tcl_DStringLength(&prefix));
}
string = Tcl_GetStringFromObj(objv[i], &length);
Tcl_DStringAppend(&str, string, length);
if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir,
globFlags, globTypes) != TCL_OK) {
result = TCL_ERROR;
Tcl_DStringFree(&str);
goto endOfGlob;
}
}
Tcl_DStringFree(&str);
} else {
for (i = 0; i < objc; i++) {
string = Tcl_GetString(objv[i]);
if (TclGlob(interp, string, pathOrDir,
globFlags, globTypes) != TCL_OK) {
result = TCL_ERROR;
goto endOfGlob;
}
}
}
}
if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp),
&length) != TCL_OK) {
/* This should never happen. Maybe we should be more dramatic */
result = TCL_ERROR;
goto endOfGlob;
}
if (length == 0) {
Tcl_AppendResult(interp, "no files matched glob pattern",
(join || (objc == 1)) ? " \"" : "s \"", (char *) NULL);
if (join) {
Tcl_AppendResult(interp, Tcl_DStringValue(&prefix),
(char *) NULL);
} else {
char *sep = "";
for (i = 0; i < objc; i++) {
string = Tcl_GetString(objv[i]);
Tcl_AppendResult(interp, sep, string, (char *) NULL);
sep = " ";
}
}
Tcl_AppendResult(interp, "\"", (char *) NULL);
result = TCL_ERROR;
}
}
endOfGlob:
if (join || (dir == PATH_GENERAL)) {
Tcl_DStringFree(&prefix);
}
if (pathOrDir != NULL) {
Tcl_DecrRefCount(pathOrDir);
}
if (globTypes != NULL) {
if (globTypes->macType != NULL) {
Tcl_DecrRefCount(globTypes->macType);
}
if (globTypes->macCreator != NULL) {
Tcl_DecrRefCount(globTypes->macCreator);
}
ckfree((char *) globTypes);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclGlob --
*
* This procedure prepares arguments for the TclDoGlob call.
* It sets the separator string based on the platform, performs
* tilde substitution, and calls TclDoGlob.
*
* The interpreter's result, on entry to this function, must
* be a valid Tcl list (e.g. it could be empty), since we will
* lappend any new results to that list. If it is not a valid
* list, this function will fail to do anything very meaningful.
*
* Results:
* The return value is a standard Tcl result indicating whether
* an error occurred in globbing. After a normal return the
* result in interp (set by TclDoGlob) holds all of the file names
* given by the pattern and unquotedPrefix arguments. After an
* error the result in interp will hold an error message, unless
* the 'TCL_GLOBMODE_NO_COMPLAIN' flag was given, in which case
* an error results in a TCL_OK return leaving the interpreter's
* result unmodified.
*
* Side effects:
* The 'pattern' is written to.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
Tcl_Interp *interp; /* Interpreter for returning error message
* or appending list of matching file names. */
char *pattern; /* Glob pattern to match. Must not refer
* to a static string. */
Tcl_Obj *unquotedPrefix; /* Prefix to glob pattern, if non-null, which
* is considered literally. */
int globFlags; /* Stores or'ed combination of flags */
Tcl_GlobTypeData *types; /* Struct containing acceptable types.
* May be NULL. */
{
char *separators;
CONST char *head;
char *tail, *start;
char c;
int result, prefixLen;
Tcl_DString buffer;
Tcl_Obj *oldResult;
separators = NULL; /* lint. */
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
break;
case TCL_PLATFORM_WINDOWS:
separators = "/\\:";
break;
}
Tcl_DStringInit(&buffer);
if (unquotedPrefix != NULL) {
start = Tcl_GetString(unquotedPrefix);
} else {
start = pattern;
}
/*
* Perform tilde substitution, if needed.
*/
if (start[0] == '~') {
/*
* Find the first path separator after the tilde.
*/
for (tail = start; *tail != '\0'; tail++) {
if (*tail == '\\') {
if (strchr(separators, tail[1]) != NULL) {
break;
}
} else if (strchr(separators, *tail) != NULL) {
break;
}
}
/*
* Determine the home directory for the specified user.
*/
c = *tail;
*tail = '\0';
if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
/*
* We will ignore any error message here, and we
* don't want to mess up the interpreter's result.
*/
head = DoTildeSubst(NULL, start+1, &buffer);
} else {
head = DoTildeSubst(interp, start+1, &buffer);
}
*tail = c;
if (head == NULL) {
if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
return TCL_OK;
} else {
return TCL_ERROR;
}
}
if (head != Tcl_DStringValue(&buffer)) {
Tcl_DStringAppend(&buffer, head, -1);
}
if (unquotedPrefix != NULL) {
Tcl_DStringAppend(&buffer, tail, -1);
tail = pattern;
}
} else {
tail = pattern;
if (unquotedPrefix != NULL) {
Tcl_DStringAppend(&buffer,Tcl_GetString(unquotedPrefix),-1);
}
}
/*
* We want to remember the length of the current prefix,
* in case we are using TCL_GLOBMODE_TAILS. Also if we
* are using TCL_GLOBMODE_DIR, we must make sure the
* prefix ends in a directory separator.
*/
prefixLen = Tcl_DStringLength(&buffer);
if (prefixLen > 0) {
c = Tcl_DStringValue(&buffer)[prefixLen-1];
if (strchr(separators, c) == NULL) {
/*
* If the prefix is a directory, make sure it ends in a
* directory separator.
*/
if (globFlags & TCL_GLOBMODE_DIR) {
Tcl_DStringAppend(&buffer,separators,1);
/* Try to borrow that separator from the tail */
if (*tail == *separators) {
tail++;
}
}
prefixLen++;
}
}
/*
* We need to get the old result, in case it is over-written
* below when we still need it.
*/
oldResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(oldResult);
Tcl_ResetResult(interp);
result = TclDoGlob(interp, separators, &buffer, tail, types);
if (result != TCL_OK) {
if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
/* Put back the old result and reset the return code */
Tcl_SetObjResult(interp, oldResult);
result = TCL_OK;
}
} else {
/*
* Now we must concatenate the 'oldResult' and the current
* result, and then place that into the interpreter.
*
* If we only want the tails, we must strip off the prefix now.
* It may seem more efficient to pass the tails flag down into
* TclDoGlob, Tcl_FSMatchInDirectory, but those functions are
* continually adjusting the prefix as the various pieces of
* the pattern are assimilated, so that would add a lot of
* complexity to the code. This way is a little slower (when
* the -tails flag is given), but much simpler to code.
*/
int objc, i;
Tcl_Obj **objv;
/* Ensure sole ownership */
if (Tcl_IsShared(oldResult)) {
Tcl_DecrRefCount(oldResult);
oldResult = Tcl_DuplicateObj(oldResult);
Tcl_IncrRefCount(oldResult);
}
Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp),
&objc, &objv);
for (i = 0; i< objc; i++) {
Tcl_Obj* elt;
if (globFlags & TCL_GLOBMODE_TAILS) {
int len;
char *oldStr = Tcl_GetStringFromObj(objv[i],&len);
if (len == prefixLen) {
if ((pattern[0] == '\0')
|| (strchr(separators, pattern[0]) == NULL)) {
elt = Tcl_NewStringObj(".",1);
} else {
elt = Tcl_NewStringObj("/",1);
}
} else {
elt = Tcl_NewStringObj(oldStr + prefixLen,
len - prefixLen);
}
} else {
elt = objv[i];
}
/* Assumption that 'oldResult' is a valid list */
Tcl_ListObjAppendElement(interp, oldResult, elt);
}
Tcl_SetObjResult(interp, oldResult);
}
/*
* Release our temporary copy. All code paths above must
* end here so we free our reference.
*/
Tcl_DecrRefCount(oldResult);
Tcl_DStringFree(&buffer);
return result;
}
/*
*----------------------------------------------------------------------
*
* SkipToChar --
*
* This function traverses a glob pattern looking for the next
* unquoted occurance of the specified character at the same braces
* nesting level.
*
* Results:
* Updates stringPtr to point to the matching character, or to
* the end of the string if nothing matched. The return value
* is 1 if a match was found at the top level, otherwise it is 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
SkipToChar(stringPtr, match)
char **stringPtr; /* Pointer string to check. */
char *match; /* Pointer to character to find. */
{
int quoted, level;
register char *p;
quoted = 0;
level = 0;
for (p = *stringPtr; *p != '\0'; p++) {
if (quoted) {
quoted = 0;
continue;
}
if ((level == 0) && (*p == *match)) {
*stringPtr = p;
return 1;
}
if (*p == '{') {
level++;
} else if (*p == '}') {
level--;
} else if (*p == '\\') {
quoted = 1;
}
}
*stringPtr = p;
return 0;
}
/*
*----------------------------------------------------------------------
*
* TclDoGlob --
*
* This recursive procedure forms the heart of the globbing
* code. It performs a depth-first traversal of the tree
* given by the path name to be globbed. The directory and
* remainder are assumed to be native format paths. The prefix
* contained in 'headPtr' is not used as a glob pattern, simply
* as a path specifier, so it can contain unquoted glob-sensitive
* characters (if the directories to which it points contain
* such strange characters).
*
* Results:
* The return value is a standard Tcl result indicating whether
* an error occurred in globbing. After a normal return the
* result in interp will be set to hold all of the file names
* given by the dir and rem arguments. After an error the
* result in interp will hold an error message.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclDoGlob(interp, separators, headPtr, tail, types)
Tcl_Interp *interp; /* Interpreter to use for error reporting
* (e.g. unmatched brace). */
char *separators; /* String containing separator characters
* that should be used to identify globbing
* boundaries. */
Tcl_DString *headPtr; /* Completely expanded prefix. */
char *tail; /* The unexpanded remainder of the path.
* Must not be a pointer to a static string. */
Tcl_GlobTypeData *types; /* List object containing list of acceptable
* types. May be NULL. */
{
int baseLength, quoted, count;
int result = TCL_OK;
char *name, *p, *openBrace, *closeBrace, *firstSpecialChar, savedChar;
/*
char lastChar = 0;
*/
int length = Tcl_DStringLength(headPtr);
/*
if (length > 0) {
lastChar = Tcl_DStringValue(headPtr)[length-1];
}
*/
/*
* Consume any leading directory separators, leaving tail pointing
* just past the last initial separator.
*/
count = 0;
name = tail;
for (; *tail != '\0'; tail++) {
if (*tail == '\\') {
/*
* If the first character is escaped, either we have a directory
* separator, or we have any other character. In the latter case
* the rest of tail is a pattern, and we must break from the loop.
* This is particularly important on Windows where '\' is both
* the escaping character and a directory separator.
*/
if (strchr(separators, tail[1]) != NULL) {
tail++;
} else {
break;
}
} else if (strchr(separators, *tail) == NULL) {
break;
}
if (*tail == '\\') {
Tcl_DStringAppend(headPtr, separators, 1);
} else {
Tcl_DStringAppend(headPtr, tail, 1);
}
count++;
}
/*
* Deal with path separators. On the Mac, we have to watch out
* for multiple separators, since they are special in Mac-style
* paths.
*/
switch (tclPlatform) {
case TCL_PLATFORM_WINDOWS:
/*
* If this is a drive relative path, add the colon and the
* trailing slash if needed. Otherwise add the slash if
* this is the first absolute element, or a later relative
* element. Add an extra slash if this is a UNC path.
if (*name == ':') {
Tcl_DStringAppend(headPtr, ":", 1);
if (count > 1) {
Tcl_DStringAppend(headPtr, "/", 1);
}
} else if ((*tail != '\0')
&& (((length > 0)
&& (strchr(separators, lastChar) == NULL))
|| ((length == 0) && (count > 0)))) {
Tcl_DStringAppend(headPtr, "/", 1);
if ((length == 0) && (count > 1)) {
Tcl_DStringAppend(headPtr, "/", 1);
}
}
*/
break;
case TCL_PLATFORM_UNIX: {
/*
* Add a separator if this is the first absolute element, or
* a later relative element.
if ((*tail != '\0')
&& (((length > 0)
&& (strchr(separators, lastChar) == NULL))
|| ((length == 0) && (count > 0)))) {
Tcl_DStringAppend(headPtr, "/", 1);
}
*/
break;
}
}
/*
* Look for the first matching pair of braces or the first
* directory separator that is not inside a pair of braces.
*/
openBrace = closeBrace = NULL;
quoted = 0;
for (p = tail; *p != '\0'; p++) {
if (quoted) {
quoted = 0;
} else if (*p == '\\') {
quoted = 1;
if (strchr(separators, p[1]) != NULL) {
break; /* Quoted directory separator. */
}
} else if (strchr(separators, *p) != NULL) {
break; /* Unquoted directory separator. */
} else if (*p == '{') {
openBrace = p;
p++;
if (SkipToChar(&p, "}")) {
closeBrace = p; /* Balanced braces. */
break;
}
Tcl_SetResult(interp, "unmatched open-brace in file name",
TCL_STATIC);
return TCL_ERROR;
} else if (*p == '}') {
Tcl_SetResult(interp, "unmatched close-brace in file name",
TCL_STATIC);
return TCL_ERROR;
}
}
/*
* Substitute the alternate patterns from the braces and recurse.
*/
if (openBrace != NULL) {
char *element;
Tcl_DString newName;
Tcl_DStringInit(&newName);
/*
* For each element within in the outermost pair of braces,
* append the element and the remainder to the fixed portion
* before the first brace and recursively call TclDoGlob.
*/
Tcl_DStringAppend(&newName, tail, openBrace-tail);
baseLength = Tcl_DStringLength(&newName);
length = Tcl_DStringLength(headPtr);
*closeBrace = '\0';
for (p = openBrace; p != closeBrace; ) {
p++;
element = p;
SkipToChar(&p, ",");
Tcl_DStringSetLength(headPtr, length);
Tcl_DStringSetLength(&newName, baseLength);
Tcl_DStringAppend(&newName, element, p-element);
Tcl_DStringAppend(&newName, closeBrace+1, -1);
result = TclDoGlob(interp, separators, headPtr,
Tcl_DStringValue(&newName), types);
if (result != TCL_OK) {
break;
}
}
*closeBrace = '}';
Tcl_DStringFree(&newName);
return result;
}
/*
* At this point, there are no more brace substitutions to perform on
* this path component. The variable p is pointing at a quoted or
* unquoted directory separator or the end of the string. So we need
* to check for special globbing characters in the current pattern.
* We avoid modifying tail if p is pointing at the end of the string.
*/
if (*p != '\0') {
/*
* Note that we are modifying the string in place. This won't work
* if the string is a static.
*/
savedChar = *p;
*p = '\0';
firstSpecialChar = strpbrk(tail, "*[]?\\");
*p = savedChar;
} else {
firstSpecialChar = strpbrk(tail, "*[]?\\");
}
if (firstSpecialChar != NULL) {
int ret;
Tcl_Obj *head = Tcl_NewStringObj(Tcl_DStringValue(headPtr),-1);
Tcl_IncrRefCount(head);
/*
* Look for matching files in the given directory. The
* implementation of this function is platform specific. For
* each file that matches, it will add the match onto the
* resultPtr given.
*/
if (*p == '\0') {
ret = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp),
head, tail, types);
} else {
/*
* We do the recursion ourselves. This makes implementing
* Tcl_FSMatchInDirectory for each filesystem much easier.
*/
Tcl_GlobTypeData dirOnly = { TCL_GLOB_TYPE_DIR, 0, NULL, NULL };
char save = *p;
Tcl_Obj *resultPtr;
resultPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(resultPtr);
*p = '\0';
ret = Tcl_FSMatchInDirectory(interp, resultPtr,
head, tail, &dirOnly);
*p = save;
if (ret == TCL_OK) {
int resLength, repair = -1;
ret = Tcl_ListObjLength(interp, resultPtr, &resLength);
if (ret == TCL_OK) {
int i;
for (i =0; i< resLength; i++) {
Tcl_Obj *elt;
Tcl_DString ds;
Tcl_ListObjIndex(NULL, resultPtr, i, &elt);
Tcl_DStringInit(&ds);
if (Tcl_GetString(elt)[0] == '~') {
Tcl_Obj *paths = Tcl_GetObjResult(interp);
Tcl_ListObjLength(NULL, paths, &repair);
Tcl_DStringAppend(&ds, "./", 2);
}
Tcl_DStringAppend(&ds, Tcl_GetString(elt), -1);
Tcl_DStringAppend(&ds, "/",1);
ret = TclDoGlob(interp, separators, &ds, p+1, types);
Tcl_DStringFree(&ds);
if (ret != TCL_OK) {
break;
}
if (repair >= 0) {
Tcl_Obj *paths = Tcl_GetObjResult(interp);
int end;
Tcl_ListObjLength(NULL, paths, &end);
while (repair < end) {
CONST char *bytes;
int numBytes;
Tcl_Obj *fixme, *newObj;
Tcl_ListObjIndex(NULL, paths, repair, &fixme);
bytes = Tcl_GetStringFromObj(fixme, &numBytes);
newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
Tcl_ListObjReplace(NULL, paths, repair, 1,
1, &newObj);
repair++;
}
repair = -1;
}
}
}
}
Tcl_DecrRefCount(resultPtr);
}
Tcl_DecrRefCount(head);
return ret;
}
Tcl_DStringAppend(headPtr, tail, p-tail);
if (*p != '\0') {
return TclDoGlob(interp, separators, headPtr, p, types);
} else {
/*
* This is the code path reached by a command like 'glob foo'.
*
* There are no more wildcards in the pattern and no more
* unprocessed characters in the tail, so now we can construct
* the path, and pass it to Tcl_FSMatchInDirectory with an
* empty pattern to verify the existence of the file and check
* it is of the correct type (if a 'types' flag it given -- if
* no such flag was given, we could just use 'Tcl_FSLStat', but
* for simplicity we keep to a common approach).
*/
Tcl_Obj *nameObj;
switch (tclPlatform) {
case TCL_PLATFORM_WINDOWS: {
if (Tcl_DStringLength(headPtr) == 0) {
if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
|| (*name == '/')) {
Tcl_DStringAppend(headPtr, "/", 1);
} else {
Tcl_DStringAppend(headPtr, ".", 1);
}
}
/*
* Convert to forward slashes. This is required to pass
* some Tcl tests. We should probably remove the conversions
* here and in tclWinFile.c, since they aren't needed since
* the dropping of support for Win32s.
*/
for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
}
}
break;
}
case TCL_PLATFORM_UNIX: {
if (Tcl_DStringLength(headPtr) == 0) {
if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
Tcl_DStringAppend(headPtr, "/", 1);
} else {
Tcl_DStringAppend(headPtr, ".", 1);
}
}
break;
}
}
/* Common for all platforms */
name = Tcl_DStringValue(headPtr);
nameObj = Tcl_NewStringObj(name, Tcl_DStringLength(headPtr));
Tcl_IncrRefCount(nameObj);
result = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp),
nameObj, NULL, types);
Tcl_DecrRefCount(nameObj);
return result;
}
}
/*
*---------------------------------------------------------------------------
*
* TclFileDirname
*
* This procedure calculates the directory above a given
* path: basically 'file dirname'. It is used both by
* the 'dirname' subcommand of file and by code in tclIOUtil.c.
*
* Results:
* NULL if an error occurred, otherwise a Tcl_Obj owned by
* the caller (i.e. most likely with refCount 1).
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclFileDirname(interp, pathPtr)
Tcl_Interp *interp; /* Used for error reporting */
Tcl_Obj *pathPtr; /* Path to take dirname of */
{
int splitElements;
Tcl_Obj *splitPtr;
Tcl_Obj *splitResultPtr = NULL;
/*
* The behaviour we want here is slightly different to
* the standard Tcl_FSSplitPath in the handling of home
* directories; Tcl_FSSplitPath preserves the "~" while
* this code computes the actual full path name, if we
* had just a single component.
*/
splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
if ((splitElements == 1) && (Tcl_GetString(pathPtr)[0] == '~')) {
Tcl_DecrRefCount(splitPtr);
splitPtr = Tcl_FSGetNormalizedPath(interp, pathPtr);
if (splitPtr == NULL) {
return NULL;
}
splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
}
/*
* Return all but the last component. If there is only one
* component, return it if the path was non-relative, otherwise
* return the current directory.
*/
if (splitElements > 1) {
splitResultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1);
} else if (splitElements == 0 ||
(Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) {
splitResultPtr = Tcl_NewStringObj(".", 1);
} else {
Tcl_ListObjIndex(NULL, splitPtr, 0, &splitResultPtr);
}
Tcl_IncrRefCount(splitResultPtr);
Tcl_DecrRefCount(splitPtr);
return splitResultPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_AllocStatBuf
*
* This procedure allocates a Tcl_StatBuf on the heap. It exists
* so that extensions may be used unchanged on systems where
* largefile support is optional.
*
* Results:
* A pointer to a Tcl_StatBuf which may be deallocated by being
* passed to ckfree().
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_StatBuf *
Tcl_AllocStatBuf() {
return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf));
}
tcl8.4.20/generic/tclLoad.c 0000644 0036047 0045461 00000047672 11737050674 014101 0 ustar dgp 771div /*
* tclLoad.c --
*
* This file provides the generic portion (those that are the same
* on all platforms) of Tcl's dynamic loading facilities.
*
* Copyright (c) 1995-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.
*/
#include "tclInt.h"
/*
* The following structure describes a package that has been loaded
* either dynamically (with the "load" command) or statically (as
* indicated by a call to TclGetLoadedPackages). All such packages
* are linked together into a single list for the process. Packages
* are never unloaded, until the application exits, when
* TclFinalizeLoad is called, and these structures are freed.
*/
typedef struct LoadedPackage {
char *fileName; /* Name of the file from which the
* package was loaded. An empty string
* means the package is loaded statically.
* Malloc-ed. */
char *packageName; /* Name of package prefix for the package,
* properly capitalized (first letter UC,
* others LC), no "_", as in "Net".
* Malloc-ed. */
Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be
* passed to (*unLoadProcPtr)() when the file
* is no longer needed. If fileName is NULL,
* then this field is irrelevant. */
Tcl_PackageInitProc *initProc;
/* Initialization procedure to call to
* incorporate this package into a trusted
* interpreter. */
Tcl_PackageInitProc *safeInitProc;
/* Initialization procedure to call to
* incorporate this package into a safe
* interpreter (one that will execute
* untrusted scripts). NULL means the
* package can't be used in unsafe
* interpreters. */
Tcl_FSUnloadFileProc *unLoadProcPtr;
/* Procedure to use to unload this package.
* If NULL, then we do not attempt to unload
* the package. If fileName is NULL, then
* this field is irrelevant. */
struct LoadedPackage *nextPtr;
/* Next in list of all packages loaded into
* this application process. NULL means
* end of list. */
} LoadedPackage;
/*
* TCL_THREADS
* There is a global list of packages that is anchored at firstPackagePtr.
* Access to this list is governed by a mutex.
*/
static LoadedPackage *firstPackagePtr = NULL;
/* First in list of all packages loaded into
* this process. */
TCL_DECLARE_MUTEX(packageMutex)
/*
* The following structure represents a particular package that has
* been incorporated into a particular interpreter (by calling its
* initialization procedure). There is a list of these structures for
* each interpreter, with an AssocData value (key "load") for the
* interpreter that points to the first package (if any).
*/
typedef struct InterpPackage {
LoadedPackage *pkgPtr; /* Points to detailed information about
* package. */
struct InterpPackage *nextPtr;
/* Next package in this interpreter, or
* NULL for end of list. */
} InterpPackage;
/*
* Prototypes for procedures that are private to this file:
*/
static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp));
/*
*----------------------------------------------------------------------
*
* Tcl_LoadObjCmd --
*
* This procedure is invoked to process the "load" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LoadObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Interp *target;
LoadedPackage *pkgPtr, *defaultPtr;
Tcl_DString pkgName, tmp, initName, safeInitName;
Tcl_PackageInitProc *initProc, *safeInitProc;
InterpPackage *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch;
char *p, *fullFileName, *packageName;
Tcl_LoadHandle loadHandle;
Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
Tcl_UniChar ch;
int offset;
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
fullFileName = Tcl_GetString(objv[1]);
Tcl_DStringInit(&pkgName);
Tcl_DStringInit(&initName);
Tcl_DStringInit(&safeInitName);
Tcl_DStringInit(&tmp);
packageName = NULL;
if (objc >= 3) {
packageName = Tcl_GetString(objv[2]);
if (packageName[0] == '\0') {
packageName = NULL;
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
Tcl_SetResult(interp,
"must specify either file name or package name",
TCL_STATIC);
code = TCL_ERROR;
goto done;
}
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc == 4) {
char *slaveIntName;
slaveIntName = Tcl_GetString(objv[3]);
target = Tcl_GetSlave(interp, slaveIntName);
if (target == NULL) {
return TCL_ERROR;
}
}
/*
* Scan through the packages that are currently loaded to see if the
* package we want is already loaded. We'll use a loaded package if
* it meets any of the following conditions:
* - Its name and file match the once we're looking for.
* - Its file matches, and we weren't given a name.
* - Its name matches, the file name was specified as empty, and there
* is only no statically loaded package with the same name.
*/
Tcl_MutexLock(&packageMutex);
defaultPtr = NULL;
for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
if (packageName == NULL) {
namesMatch = 0;
} else {
Tcl_DStringSetLength(&pkgName, 0);
Tcl_DStringAppend(&pkgName, packageName, -1);
Tcl_DStringSetLength(&tmp, 0);
Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
Tcl_UtfToLower(Tcl_DStringValue(&pkgName));
Tcl_UtfToLower(Tcl_DStringValue(&tmp));
if (strcmp(Tcl_DStringValue(&tmp),
Tcl_DStringValue(&pkgName)) == 0) {
namesMatch = 1;
} else {
namesMatch = 0;
}
}
Tcl_DStringSetLength(&pkgName, 0);
filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
if (filesMatch && (namesMatch || (packageName == NULL))) {
break;
}
if (namesMatch && (fullFileName[0] == 0)) {
defaultPtr = pkgPtr;
}
if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
/*
* Can't have two different packages loaded from the same
* file.
*/
Tcl_AppendResult(interp, "file \"", fullFileName,
"\" is already loaded for package \"",
pkgPtr->packageName, "\"", (char *) NULL);
code = TCL_ERROR;
Tcl_MutexUnlock(&packageMutex);
goto done;
}
}
Tcl_MutexUnlock(&packageMutex);
if (pkgPtr == NULL) {
pkgPtr = defaultPtr;
}
/*
* Scan through the list of packages already loaded in the target
* interpreter. If the package we want is already loaded there,
* then there's nothing for us to to.
*/
if (pkgPtr != NULL) {
ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
(Tcl_InterpDeleteProc **) NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
code = TCL_OK;
goto done;
}
}
}
if (pkgPtr == NULL) {
/*
* The desired file isn't currently loaded, so load it. It's an
* error if the desired package is a static one.
*/
if (fullFileName[0] == 0) {
Tcl_AppendResult(interp, "package \"", packageName,
"\" isn't loaded statically", (char *) NULL);
code = TCL_ERROR;
goto done;
}
/*
* Figure out the module name if it wasn't provided explicitly.
*/
if (packageName != NULL) {
Tcl_DStringAppend(&pkgName, packageName, -1);
} else {
int retc;
/*
* Threading note - this call used to be protected by a mutex.
*/
retc = TclGuessPackageName(fullFileName, &pkgName);
if (!retc) {
Tcl_Obj *splitPtr;
Tcl_Obj *pkgGuessPtr;
int pElements;
char *pkgGuess;
/*
* The platform-specific code couldn't figure out the
* module name. Make a guess by taking the last element
* of the file name, stripping off any leading "lib",
* and then using all of the alphabetic and underline
* characters that follow that.
*/
splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
pkgGuess = Tcl_GetString(pkgGuessPtr);
if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
&& (pkgGuess[2] == 'b')) {
pkgGuess += 3;
}
#ifdef __CYGWIN__
if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y')
&& (pkgGuess[2] == 'g')) {
pkgGuess += 3;
}
#endif /* __CYGWIN__ */
for (p = pkgGuess; *p != 0; p += offset) {
offset = Tcl_UtfToUniChar(p, &ch);
if ((ch > 0x100)
|| !(isalpha(UCHAR(ch)) /* INTL: ISO only */
|| (UCHAR(ch) == '_'))) {
break;
}
}
if (p == pkgGuess) {
Tcl_DecrRefCount(splitPtr);
Tcl_AppendResult(interp,
"couldn't figure out package name for ",
fullFileName, (char *) NULL);
code = TCL_ERROR;
goto done;
}
Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));
Tcl_DecrRefCount(splitPtr);
}
}
/*
* Fix the capitalization in the package name so that the first
* character is in caps (or title case) but the others are all
* lower-case.
*/
Tcl_DStringSetLength(&pkgName,
Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));
/*
* Compute the names of the two initialization procedures,
* based on the package name.
*/
Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
Tcl_DStringAppend(&initName, "_Init", 5);
Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
/*
* Call platform-specific code to load the package and find the
* two initialization procedures.
*/
Tcl_MutexLock(&packageMutex);
code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName),
Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
&loadHandle,&unLoadProcPtr);
Tcl_MutexUnlock(&packageMutex);
if (code != TCL_OK) {
goto done;
}
if (initProc == NULL) {
Tcl_AppendResult(interp, "couldn't find procedure ",
Tcl_DStringValue(&initName), (char *) NULL);
if (unLoadProcPtr != NULL) {
(*unLoadProcPtr)(loadHandle);
}
code = TCL_ERROR;
goto done;
}
/*
* Create a new record to describe this package.
*/
pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
pkgPtr->fileName = (char *) ckalloc((unsigned)
(strlen(fullFileName) + 1));
strcpy(pkgPtr->fileName, fullFileName);
pkgPtr->packageName = (char *) ckalloc((unsigned)
(Tcl_DStringLength(&pkgName) + 1));
strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
pkgPtr->loadHandle = loadHandle;
pkgPtr->unLoadProcPtr = unLoadProcPtr;
pkgPtr->initProc = initProc;
pkgPtr->safeInitProc = safeInitProc;
Tcl_MutexLock(&packageMutex);
pkgPtr->nextPtr = firstPackagePtr;
firstPackagePtr = pkgPtr;
Tcl_MutexUnlock(&packageMutex);
}
/*
* Invoke the package's initialization procedure (either the
* normal one or the safe one, depending on whether or not the
* interpreter is safe).
*/
if (Tcl_IsSafe(target)) {
if (pkgPtr->safeInitProc != NULL) {
code = (*pkgPtr->safeInitProc)(target);
} else {
Tcl_AppendResult(interp,
"can't use package in a safe interpreter: ",
"no ", pkgPtr->packageName, "_SafeInit procedure",
(char *) NULL);
code = TCL_ERROR;
goto done;
}
} else {
code = (*pkgPtr->initProc)(target);
}
/*
* Record the fact that the package has been loaded in the
* target interpreter.
*/
if (code == TCL_OK) {
/*
* Refetch ipFirstPtr: loading the package may have introduced
* additional static packages at the head of the linked list!
*/
ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
(Tcl_InterpDeleteProc **) NULL);
ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
(ClientData) ipPtr);
} else {
TclTransferResult(target, code, interp);
}
done:
Tcl_DStringFree(&pkgName);
Tcl_DStringFree(&initName);
Tcl_DStringFree(&safeInitName);
Tcl_DStringFree(&tmp);
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_StaticPackage --
*
* This procedure is invoked to indicate that a particular
* package has been linked statically with an application.
*
* Results:
* None.
*
* Side effects:
* Once this procedure completes, the package becomes loadable
* via the "load" command with an empty file name.
*
*----------------------------------------------------------------------
*/
void
Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
Tcl_Interp *interp; /* If not NULL, it means that the
* package has already been loaded
* into the given interpreter by
* calling the appropriate init proc. */
CONST char *pkgName; /* Name of package (must be properly
* capitalized: first letter upper
* case, others lower case). */
Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate
* this package into a trusted
* interpreter. */
Tcl_PackageInitProc *safeInitProc; /* Procedure to call to incorporate
* this package into a safe interpreter
* (one that will execute untrusted
* scripts). NULL means the package
* can't be used in safe
* interpreters. */
{
LoadedPackage *pkgPtr;
InterpPackage *ipPtr, *ipFirstPtr;
/*
* Check to see if someone else has already reported this package as
* statically loaded in the process.
*/
Tcl_MutexLock(&packageMutex);
for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
if ((pkgPtr->initProc == initProc)
&& (pkgPtr->safeInitProc == safeInitProc)
&& (strcmp(pkgPtr->packageName, pkgName) == 0)) {
break;
}
}
Tcl_MutexUnlock(&packageMutex);
/*
* If the package is not yet recorded as being loaded statically,
* add it to the list now.
*/
if ( pkgPtr == NULL ) {
pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
pkgPtr->fileName[0] = 0;
pkgPtr->packageName = (char *) ckalloc((unsigned)
(strlen(pkgName) + 1));
strcpy(pkgPtr->packageName, pkgName);
pkgPtr->loadHandle = NULL;
pkgPtr->initProc = initProc;
pkgPtr->safeInitProc = safeInitProc;
Tcl_MutexLock(&packageMutex);
pkgPtr->nextPtr = firstPackagePtr;
firstPackagePtr = pkgPtr;
Tcl_MutexUnlock(&packageMutex);
}
if (interp != NULL) {
/*
* If we're loading the package into an interpreter,
* determine whether it's already loaded.
*/
ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
(Tcl_InterpDeleteProc **) NULL);
for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) {
if ( ipPtr->pkgPtr == pkgPtr ) {
return;
}
}
/*
* Package isn't loade in the current interp yet. Mark it as
* now being loaded.
*/
ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,
(ClientData) ipPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclGetLoadedPackages --
*
* This procedure returns information about all of the files
* that are loaded (either in a particular intepreter, or
* for all interpreters).
*
* Results:
* The return value is a standard Tcl completion code. If
* successful, a list of lists is placed in the interp's result.
* Each sublist corresponds to one loaded file; its first
* element is the name of the file (or an empty string for
* something that's statically loaded) and the second element
* is the name of the package in that file.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclGetLoadedPackages(interp, targetName)
Tcl_Interp *interp; /* Interpreter in which to return
* information or error message. */
char *targetName; /* Name of target interpreter or NULL.
* If NULL, return info about all interps;
* otherwise, just return info about this
* interpreter. */
{
Tcl_Interp *target;
LoadedPackage *pkgPtr;
InterpPackage *ipPtr;
char *prefix;
if (targetName == NULL) {
/*
* Return information about all of the available packages.
*/
prefix = "{";
Tcl_MutexLock(&packageMutex);
for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
pkgPtr = pkgPtr->nextPtr) {
Tcl_AppendResult(interp, prefix, (char *) NULL);
Tcl_AppendElement(interp, pkgPtr->fileName);
Tcl_AppendElement(interp, pkgPtr->packageName);
Tcl_AppendResult(interp, "}", (char *) NULL);
prefix = " {";
}
Tcl_MutexUnlock(&packageMutex);
return TCL_OK;
}
/*
* Return information about only the packages that are loaded in
* a given interpreter.
*/
target = Tcl_GetSlave(interp, targetName);
if (target == NULL) {
return TCL_ERROR;
}
ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
(Tcl_InterpDeleteProc **) NULL);
prefix = "{";
for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
pkgPtr = ipPtr->pkgPtr;
Tcl_AppendResult(interp, prefix, (char *) NULL);
Tcl_AppendElement(interp, pkgPtr->fileName);
Tcl_AppendElement(interp, pkgPtr->packageName);
Tcl_AppendResult(interp, "}", (char *) NULL);
prefix = " {";
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* LoadCleanupProc --
*
* This procedure is called to delete all of the InterpPackage
* structures for an interpreter when the interpreter is deleted.
* It gets invoked via the Tcl AssocData mechanism.
*
* Results:
* None.
*
* Side effects:
* Storage for all of the InterpPackage procedures for interp
* get deleted.
*
*----------------------------------------------------------------------
*/
static void
LoadCleanupProc(clientData, interp)
ClientData clientData; /* Pointer to first InterpPackage structure
* for interp. */
Tcl_Interp *interp; /* Interpreter that is being deleted. */
{
InterpPackage *ipPtr, *nextPtr;
ipPtr = (InterpPackage *) clientData;
while (ipPtr != NULL) {
nextPtr = ipPtr->nextPtr;
ckfree((char *) ipPtr);
ipPtr = nextPtr;
}
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeLoad --
*
* This procedure is invoked just before the application exits.
* It frees all of the LoadedPackage structures.
*
* Results:
* None.
*
* Side effects:
* Memory is freed.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeLoad()
{
LoadedPackage *pkgPtr;
/*
* No synchronization here because there should just be
* one thread alive at this point. Logically,
* packageMutex should be grabbed at this point, but
* the Mutexes get finalized before the call to this routine.
* The only subsystem left alive at this point is the
* memory allocator.
*/
while (firstPackagePtr != NULL) {
pkgPtr = firstPackagePtr;
firstPackagePtr = pkgPtr->nextPtr;
#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
/*
* Some Unix dlls are poorly behaved - registering things like
* atexit calls that can't be unregistered. If you unload
* such dlls, you get a core on exit because it wants to
* call a function in the dll after it's been unloaded.
*/
if (pkgPtr->fileName[0] != '\0') {
Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
if (unLoadProcPtr != NULL) {
(*unLoadProcPtr)(pkgPtr->loadHandle);
}
}
#endif
ckfree(pkgPtr->fileName);
ckfree(pkgPtr->packageName);
ckfree((char *) pkgPtr);
}
}
tcl8.4.20/generic/regc_locale.c 0000644 0036047 0045461 00000140001 12052456743 014730 0 ustar dgp 771div /*
* regc_locale.c --
*
* This file contains the Unicode locale specific regexp routines.
* This file is #included by regcomp.c.
*
* Copyright (c) 1998 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/* ASCII character-name table */
static CONST struct cname {
CONST char *name;
CONST char code;
} cnames[] = {
{"NUL", '\0'},
{"SOH", '\001'},
{"STX", '\002'},
{"ETX", '\003'},
{"EOT", '\004'},
{"ENQ", '\005'},
{"ACK", '\006'},
{"BEL", '\007'},
{"alert", '\007'},
{"BS", '\010'},
{"backspace", '\b'},
{"HT", '\011'},
{"tab", '\t'},
{"LF", '\012'},
{"newline", '\n'},
{"VT", '\013'},
{"vertical-tab", '\v'},
{"FF", '\014'},
{"form-feed", '\f'},
{"CR", '\015'},
{"carriage-return", '\r'},
{"SO", '\016'},
{"SI", '\017'},
{"DLE", '\020'},
{"DC1", '\021'},
{"DC2", '\022'},
{"DC3", '\023'},
{"DC4", '\024'},
{"NAK", '\025'},
{"SYN", '\026'},
{"ETB", '\027'},
{"CAN", '\030'},
{"EM", '\031'},
{"SUB", '\032'},
{"ESC", '\033'},
{"IS4", '\034'},
{"FS", '\034'},
{"IS3", '\035'},
{"GS", '\035'},
{"IS2", '\036'},
{"RS", '\036'},
{"IS1", '\037'},
{"US", '\037'},
{"space", ' '},
{"exclamation-mark",'!'},
{"quotation-mark", '"'},
{"number-sign", '#'},
{"dollar-sign", '$'},
{"percent-sign", '%'},
{"ampersand", '&'},
{"apostrophe", '\''},
{"left-parenthesis",'('},
{"right-parenthesis", ')'},
{"asterisk", '*'},
{"plus-sign", '+'},
{"comma", ','},
{"hyphen", '-'},
{"hyphen-minus", '-'},
{"period", '.'},
{"full-stop", '.'},
{"slash", '/'},
{"solidus", '/'},
{"zero", '0'},
{"one", '1'},
{"two", '2'},
{"three", '3'},
{"four", '4'},
{"five", '5'},
{"six", '6'},
{"seven", '7'},
{"eight", '8'},
{"nine", '9'},
{"colon", ':'},
{"semicolon", ';'},
{"less-than-sign", '<'},
{"equals-sign", '='},
{"greater-than-sign", '>'},
{"question-mark", '?'},
{"commercial-at", '@'},
{"left-square-bracket", '['},
{"backslash", '\\'},
{"reverse-solidus", '\\'},
{"right-square-bracket", ']'},
{"circumflex", '^'},
{"circumflex-accent", '^'},
{"underscore", '_'},
{"low-line", '_'},
{"grave-accent", '`'},
{"left-brace", '{'},
{"left-curly-bracket", '{'},
{"vertical-line", '|'},
{"right-brace", '}'},
{"right-curly-bracket", '}'},
{"tilde", '~'},
{"DEL", '\177'},
{NULL, 0}
};
/*
* Unicode character-class tables.
*/
typedef struct crange {
chr start;
chr end;
} crange;
/*
* Declarations of Unicode character ranges. This code
* is automatically generated by the tools/uniClass.tcl script
* and used in generic/regc_locale.c. Do not modify by hand.
*/
/*
* Unicode: alphabetic characters.
*/
static CONST crange alphaRangeTable[] = {
{0x41, 0x5a}, {0x61, 0x7a}, {0xc0, 0xd6}, {0xd8, 0xf6},
{0xf8, 0x2c1}, {0x2c6, 0x2d1}, {0x2e0, 0x2e4}, {0x370, 0x374},
{0x37a, 0x37d}, {0x388, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x3f5},
{0x3f7, 0x481}, {0x48a, 0x527}, {0x531, 0x556}, {0x561, 0x587},
{0x5d0, 0x5ea}, {0x5f0, 0x5f2}, {0x620, 0x64a}, {0x671, 0x6d3},
{0x6fa, 0x6fc}, {0x712, 0x72f}, {0x74d, 0x7a5}, {0x7ca, 0x7ea},
{0x800, 0x815}, {0x840, 0x858}, {0x8a2, 0x8ac}, {0x904, 0x939},
{0x958, 0x961}, {0x971, 0x977}, {0x979, 0x97f}, {0x985, 0x98c},
{0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, {0x9df, 0x9e1},
{0xa05, 0xa0a}, {0xa13, 0xa28}, {0xa2a, 0xa30}, {0xa59, 0xa5c},
{0xa72, 0xa74}, {0xa85, 0xa8d}, {0xa8f, 0xa91}, {0xa93, 0xaa8},
{0xaaa, 0xab0}, {0xab5, 0xab9}, {0xb05, 0xb0c}, {0xb13, 0xb28},
{0xb2a, 0xb30}, {0xb35, 0xb39}, {0xb5f, 0xb61}, {0xb85, 0xb8a},
{0xb8e, 0xb90}, {0xb92, 0xb95}, {0xba8, 0xbaa}, {0xbae, 0xbb9},
{0xc05, 0xc0c}, {0xc0e, 0xc10}, {0xc12, 0xc28}, {0xc2a, 0xc33},
{0xc35, 0xc39}, {0xc85, 0xc8c}, {0xc8e, 0xc90}, {0xc92, 0xca8},
{0xcaa, 0xcb3}, {0xcb5, 0xcb9}, {0xd05, 0xd0c}, {0xd0e, 0xd10},
{0xd12, 0xd3a}, {0xd7a, 0xd7f}, {0xd85, 0xd96}, {0xd9a, 0xdb1},
{0xdb3, 0xdbb}, {0xdc0, 0xdc6}, {0xe01, 0xe30}, {0xe40, 0xe46},
{0xe94, 0xe97}, {0xe99, 0xe9f}, {0xea1, 0xea3}, {0xead, 0xeb0},
{0xec0, 0xec4}, {0xedc, 0xedf}, {0xf40, 0xf47}, {0xf49, 0xf6c},
{0xf88, 0xf8c}, {0x1000, 0x102a}, {0x1050, 0x1055}, {0x105a, 0x105d},
{0x106e, 0x1070}, {0x1075, 0x1081}, {0x10a0, 0x10c5}, {0x10d0, 0x10fa},
{0x10fc, 0x1248}, {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d},
{0x1260, 0x1288}, {0x128a, 0x128d}, {0x1290, 0x12b0}, {0x12b2, 0x12b5},
{0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12d6}, {0x12d8, 0x1310},
{0x1312, 0x1315}, {0x1318, 0x135a}, {0x1380, 0x138f}, {0x13a0, 0x13f4},
{0x1401, 0x166c}, {0x166f, 0x167f}, {0x1681, 0x169a}, {0x16a0, 0x16ea},
{0x1700, 0x170c}, {0x170e, 0x1711}, {0x1720, 0x1731}, {0x1740, 0x1751},
{0x1760, 0x176c}, {0x176e, 0x1770}, {0x1780, 0x17b3}, {0x1820, 0x1877},
{0x1880, 0x18a8}, {0x18b0, 0x18f5}, {0x1900, 0x191c}, {0x1950, 0x196d},
{0x1970, 0x1974}, {0x1980, 0x19ab}, {0x19c1, 0x19c7}, {0x1a00, 0x1a16},
{0x1a20, 0x1a54}, {0x1b05, 0x1b33}, {0x1b45, 0x1b4b}, {0x1b83, 0x1ba0},
{0x1bba, 0x1be5}, {0x1c00, 0x1c23}, {0x1c4d, 0x1c4f}, {0x1c5a, 0x1c7d},
{0x1ce9, 0x1cec}, {0x1cee, 0x1cf1}, {0x1d00, 0x1dbf}, {0x1e00, 0x1f15},
{0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, {0x1f48, 0x1f4d}, {0x1f50, 0x1f57},
{0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fbc}, {0x1fc2, 0x1fc4},
{0x1fc6, 0x1fcc}, {0x1fd0, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fe0, 0x1fec},
{0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffc}, {0x2090, 0x209c}, {0x210a, 0x2113},
{0x2119, 0x211d}, {0x212a, 0x212d}, {0x212f, 0x2139}, {0x213c, 0x213f},
{0x2145, 0x2149}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2ce4},
{0x2ceb, 0x2cee}, {0x2d00, 0x2d25}, {0x2d30, 0x2d67}, {0x2d80, 0x2d96},
{0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, {0x2db8, 0x2dbe},
{0x2dc0, 0x2dc6}, {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, {0x2dd8, 0x2dde},
{0x3031, 0x3035}, {0x3041, 0x3096}, {0x309d, 0x309f}, {0x30a1, 0x30fa},
{0x30fc, 0x30ff}, {0x3105, 0x312d}, {0x3131, 0x318e}, {0x31a0, 0x31ba},
{0x31f0, 0x31ff}, {0x3400, 0x4db5}, {0x4e00, 0x9fcc}, {0xa000, 0xa48c},
{0xa4d0, 0xa4fd}, {0xa500, 0xa60c}, {0xa610, 0xa61f}, {0xa640, 0xa66e},
{0xa67f, 0xa697}, {0xa6a0, 0xa6e5}, {0xa717, 0xa71f}, {0xa722, 0xa788},
{0xa78b, 0xa78e}, {0xa790, 0xa793}, {0xa7a0, 0xa7aa}, {0xa7f8, 0xa801},
{0xa803, 0xa805}, {0xa807, 0xa80a}, {0xa80c, 0xa822}, {0xa840, 0xa873},
{0xa882, 0xa8b3}, {0xa8f2, 0xa8f7}, {0xa90a, 0xa925}, {0xa930, 0xa946},
{0xa960, 0xa97c}, {0xa984, 0xa9b2}, {0xaa00, 0xaa28}, {0xaa40, 0xaa42},
{0xaa44, 0xaa4b}, {0xaa60, 0xaa76}, {0xaa80, 0xaaaf}, {0xaab9, 0xaabd},
{0xaadb, 0xaadd}, {0xaae0, 0xaaea}, {0xaaf2, 0xaaf4}, {0xab01, 0xab06},
{0xab09, 0xab0e}, {0xab11, 0xab16}, {0xab20, 0xab26}, {0xab28, 0xab2e},
{0xabc0, 0xabe2}, {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb},
{0xf900, 0xfa6d}, {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17},
{0xfb1f, 0xfb28}, {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1},
{0xfbd3, 0xfd3d}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb},
{0xfe70, 0xfe74}, {0xfe76, 0xfefc}, {0xff21, 0xff3a}, {0xff41, 0xff5a},
{0xff66, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7},
{0xffda, 0xffdc}
#if TCL_UTF_MAX > 4
,{0x10000, 0x1000b}, {0x1000d, 0x10026}, {0x10028, 0x1003a}, {0x1003f, 0x1004d},
{0x10050, 0x1005d}, {0x10080, 0x100fa}, {0x10280, 0x1029c}, {0x102a0, 0x102d0},
{0x10300, 0x1031e}, {0x10330, 0x10340}, {0x10342, 0x10349}, {0x10380, 0x1039d},
{0x103a0, 0x103c3}, {0x103c8, 0x103cf}, {0x10400, 0x1049d}, {0x10800, 0x10805},
{0x1080a, 0x10835}, {0x1083f, 0x10855}, {0x10900, 0x10915}, {0x10920, 0x10939},
{0x10980, 0x109b7}, {0x10a10, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a33},
{0x10a60, 0x10a7c}, {0x10b00, 0x10b35}, {0x10b40, 0x10b55}, {0x10b60, 0x10b72},
{0x10c00, 0x10c48}, {0x11003, 0x11037}, {0x11083, 0x110af}, {0x110d0, 0x110e8},
{0x11103, 0x11126}, {0x11183, 0x111b2}, {0x111c1, 0x111c4}, {0x11680, 0x116aa},
{0x12000, 0x1236e}, {0x13000, 0x1342e}, {0x16800, 0x16a38}, {0x16f00, 0x16f44},
{0x16f93, 0x16f9f}, {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac},
{0x1d4ae, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a},
{0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d51e, 0x1d539}, {0x1d53b, 0x1d53e},
{0x1d540, 0x1d544}, {0x1d54a, 0x1d550}, {0x1d552, 0x1d6a5}, {0x1d6a8, 0x1d6c0},
{0x1d6c2, 0x1d6da}, {0x1d6dc, 0x1d6fa}, {0x1d6fc, 0x1d714}, {0x1d716, 0x1d734},
{0x1d736, 0x1d74e}, {0x1d750, 0x1d76e}, {0x1d770, 0x1d788}, {0x1d78a, 0x1d7a8},
{0x1d7aa, 0x1d7c2}, {0x1d7c4, 0x1d7cb}, {0x1ee00, 0x1ee03}, {0x1ee05, 0x1ee1f},
{0x1ee29, 0x1ee32}, {0x1ee34, 0x1ee37}, {0x1ee4d, 0x1ee4f}, {0x1ee67, 0x1ee6a},
{0x1ee6c, 0x1ee72}, {0x1ee74, 0x1ee77}, {0x1ee79, 0x1ee7c}, {0x1ee80, 0x1ee89},
{0x1ee8b, 0x1ee9b}, {0x1eea1, 0x1eea3}, {0x1eea5, 0x1eea9}, {0x1eeab, 0x1eebb},
{0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, {0x2b740, 0x2b81d}, {0x2f800, 0x2fa1d}
#endif
};
#define NUM_ALPHA_RANGE (sizeof(alphaRangeTable)/sizeof(crange))
static CONST chr alphaCharTable[] = {
0xaa, 0xb5, 0xba, 0x2ec, 0x2ee, 0x376, 0x377, 0x386, 0x38c,
0x559, 0x66e, 0x66f, 0x6d5, 0x6e5, 0x6e6, 0x6ee, 0x6ef, 0x6ff,
0x710, 0x7b1, 0x7f4, 0x7f5, 0x7fa, 0x81a, 0x824, 0x828, 0x8a0,
0x93d, 0x950, 0x98f, 0x990, 0x9b2, 0x9bd, 0x9ce, 0x9dc, 0x9dd,
0x9f0, 0x9f1, 0xa0f, 0xa10, 0xa32, 0xa33, 0xa35, 0xa36, 0xa38,
0xa39, 0xa5e, 0xab2, 0xab3, 0xabd, 0xad0, 0xae0, 0xae1, 0xb0f,
0xb10, 0xb32, 0xb33, 0xb3d, 0xb5c, 0xb5d, 0xb71, 0xb83, 0xb99,
0xb9a, 0xb9c, 0xb9e, 0xb9f, 0xba3, 0xba4, 0xbd0, 0xc3d, 0xc58,
0xc59, 0xc60, 0xc61, 0xcbd, 0xcde, 0xce0, 0xce1, 0xcf1, 0xcf2,
0xd3d, 0xd4e, 0xd60, 0xd61, 0xdbd, 0xe32, 0xe33, 0xe81, 0xe82,
0xe84, 0xe87, 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab,
0xeb2, 0xeb3, 0xebd, 0xec6, 0xf00, 0x103f, 0x1061, 0x1065, 0x1066,
0x108e, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x17d7, 0x17dc, 0x18aa, 0x1aa7,
0x1bae, 0x1baf, 0x1cf5, 0x1cf6, 0x1f59, 0x1f5b, 0x1f5d, 0x1fbe, 0x2071,
0x207f, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x214e, 0x2183,
0x2184, 0x2cf2, 0x2cf3, 0x2d27, 0x2d2d, 0x2d6f, 0x2e2f, 0x3005, 0x3006,
0x303b, 0x303c, 0xa62a, 0xa62b, 0xa8fb, 0xa9cf, 0xaa7a, 0xaab1, 0xaab5,
0xaab6, 0xaac0, 0xaac2, 0xfb1d, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44
#if TCL_UTF_MAX > 4
,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x109be, 0x109bf, 0x10a00,
0x16f50, 0x1b000, 0x1b001, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb,
0x1d546, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, 0x1ee3b, 0x1ee42, 0x1ee47,
0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, 0x1ee59, 0x1ee5b, 0x1ee5d,
0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e
#endif
};
#define NUM_ALPHA_CHAR (sizeof(alphaCharTable)/sizeof(chr))
/*
* Unicode: control characters.
*/
static CONST crange controlRangeTable[] = {
{0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f}, {0x202a, 0x202e},
{0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb}
#if TCL_UTF_MAX > 4
,{0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, {0xf0000, 0xffffd}, {0x100000, 0x10fffd}
#endif
};
#define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange))
static CONST chr controlCharTable[] = {
0xad, 0x6dd, 0x70f, 0xfeff
#if TCL_UTF_MAX > 4
,0x110bd, 0xe0001
#endif
};
#define NUM_CONTROL_CHAR (sizeof(controlCharTable)/sizeof(chr))
/*
* Unicode: decimal digit characters.
*/
static CONST crange digitRangeTable[] = {
{0x30, 0x39}, {0x660, 0x669}, {0x6f0, 0x6f9}, {0x7c0, 0x7c9},
{0x966, 0x96f}, {0x9e6, 0x9ef}, {0xa66, 0xa6f}, {0xae6, 0xaef},
{0xb66, 0xb6f}, {0xbe6, 0xbef}, {0xc66, 0xc6f}, {0xce6, 0xcef},
{0xd66, 0xd6f}, {0xe50, 0xe59}, {0xed0, 0xed9}, {0xf20, 0xf29},
{0x1040, 0x1049}, {0x1090, 0x1099}, {0x17e0, 0x17e9}, {0x1810, 0x1819},
{0x1946, 0x194f}, {0x19d0, 0x19d9}, {0x1a80, 0x1a89}, {0x1a90, 0x1a99},
{0x1b50, 0x1b59}, {0x1bb0, 0x1bb9}, {0x1c40, 0x1c49}, {0x1c50, 0x1c59},
{0xa620, 0xa629}, {0xa8d0, 0xa8d9}, {0xa900, 0xa909}, {0xa9d0, 0xa9d9},
{0xaa50, 0xaa59}, {0xabf0, 0xabf9}, {0xff10, 0xff19}
#if TCL_UTF_MAX > 4
,{0x104a0, 0x104a9}, {0x11066, 0x1106f}, {0x110f0, 0x110f9}, {0x11136, 0x1113f},
{0x111d0, 0x111d9}, {0x116c0, 0x116c9}, {0x1d7ce, 0x1d7ff}
#endif
};
#define NUM_DIGIT_RANGE (sizeof(digitRangeTable)/sizeof(crange))
/*
* no singletons of digit characters.
*/
/*
* Unicode: punctuation characters.
*/
static CONST crange punctRangeTable[] = {
{0x21, 0x23}, {0x25, 0x2a}, {0x2c, 0x2f}, {0x5b, 0x5d},
{0x55a, 0x55f}, {0x66a, 0x66d}, {0x700, 0x70d}, {0x7f7, 0x7f9},
{0x830, 0x83e}, {0xf04, 0xf12}, {0xf3a, 0xf3d}, {0xfd0, 0xfd4},
{0x104a, 0x104f}, {0x1360, 0x1368}, {0x16eb, 0x16ed}, {0x17d4, 0x17d6},
{0x17d8, 0x17da}, {0x1800, 0x180a}, {0x1aa0, 0x1aa6}, {0x1aa8, 0x1aad},
{0x1b5a, 0x1b60}, {0x1bfc, 0x1bff}, {0x1c3b, 0x1c3f}, {0x1cc0, 0x1cc7},
{0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205e},
{0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, {0x29d8, 0x29db},
{0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b}, {0x3001, 0x3003},
{0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, {0xa6f2, 0xa6f7},
{0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, {0xaa5c, 0xaa5f},
{0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03},
{0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff5f, 0xff65}
#if TCL_UTF_MAX > 4
,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10b39, 0x10b3f}, {0x11047, 0x1104d},
{0x110be, 0x110c1}, {0x11140, 0x11143}, {0x111c5, 0x111c8}, {0x12470, 0x12473}
#endif
};
#define NUM_PUNCT_RANGE (sizeof(punctRangeTable)/sizeof(crange))
static CONST chr punctCharTable[] = {
0x3a, 0x3b, 0x3f, 0x40, 0x5f, 0x7b, 0x7d, 0xa1, 0xa7,
0xab, 0xb6, 0xb7, 0xbb, 0xbf, 0x37e, 0x387, 0x589, 0x58a,
0x5be, 0x5c0, 0x5c3, 0x5c6, 0x5f3, 0x5f4, 0x609, 0x60a, 0x60c,
0x60d, 0x61b, 0x61e, 0x61f, 0x6d4, 0x85e, 0x964, 0x965, 0x970,
0xaf0, 0xdf4, 0xe4f, 0xe5a, 0xe5b, 0xf14, 0xf85, 0xfd9, 0xfda,
0x10fb, 0x1400, 0x166d, 0x166e, 0x169b, 0x169c, 0x1735, 0x1736, 0x1944,
0x1945, 0x1a1e, 0x1a1f, 0x1c7e, 0x1c7f, 0x1cd3, 0x207d, 0x207e, 0x208d,
0x208e, 0x2329, 0x232a, 0x27c5, 0x27c6, 0x29fc, 0x29fd, 0x2cfe, 0x2cff,
0x2d70, 0x3030, 0x303d, 0x30a0, 0x30fb, 0xa4fe, 0xa4ff, 0xa673, 0xa67e,
0xa8ce, 0xa8cf, 0xa92e, 0xa92f, 0xa95f, 0xa9de, 0xa9df, 0xaade, 0xaadf,
0xaaf0, 0xaaf1, 0xabeb, 0xfd3e, 0xfd3f, 0xfe63, 0xfe68, 0xfe6a, 0xfe6b,
0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, 0xff5b, 0xff5d
#if TCL_UTF_MAX > 4
,0x1039f, 0x103d0, 0x10857, 0x1091f, 0x1093f, 0x10a7f, 0x110bb, 0x110bc
#endif
};
#define NUM_PUNCT_CHAR (sizeof(punctCharTable)/sizeof(chr))
/*
* Unicode: white space characters.
*/
static CONST crange spaceRangeTable[] = {
{0x9, 0xd}, {0x2000, 0x200a}
};
#define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange))
static CONST chr spaceCharTable[] = {
0x20, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, 0x3000
};
#define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr))
/*
* Unicode: lowercase characters.
*/
static CONST crange lowerRangeTable[] = {
{0x61, 0x7a}, {0xdf, 0xf6}, {0xf8, 0xff}, {0x17e, 0x180},
{0x199, 0x19b}, {0x1bd, 0x1bf}, {0x233, 0x239}, {0x24f, 0x293},
{0x295, 0x2af}, {0x37b, 0x37d}, {0x3ac, 0x3ce}, {0x3d5, 0x3d7},
{0x3ef, 0x3f3}, {0x430, 0x45f}, {0x561, 0x587}, {0x1d00, 0x1d2b},
{0x1d6b, 0x1d77}, {0x1d79, 0x1d9a}, {0x1e95, 0x1e9d}, {0x1eff, 0x1f07},
{0x1f10, 0x1f15}, {0x1f20, 0x1f27}, {0x1f30, 0x1f37}, {0x1f40, 0x1f45},
{0x1f50, 0x1f57}, {0x1f60, 0x1f67}, {0x1f70, 0x1f7d}, {0x1f80, 0x1f87},
{0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, {0x1fb0, 0x1fb4}, {0x1fc2, 0x1fc4},
{0x1fd0, 0x1fd3}, {0x1fe0, 0x1fe7}, {0x1ff2, 0x1ff4}, {0x2146, 0x2149},
{0x2c30, 0x2c5e}, {0x2c76, 0x2c7b}, {0x2d00, 0x2d25}, {0xa72f, 0xa731},
{0xa771, 0xa778}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xff41, 0xff5a}
#if TCL_UTF_MAX > 4
,{0x10428, 0x1044f}, {0x1d41a, 0x1d433}, {0x1d44e, 0x1d454}, {0x1d456, 0x1d467},
{0x1d482, 0x1d49b}, {0x1d4b6, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d4cf},
{0x1d4ea, 0x1d503}, {0x1d51e, 0x1d537}, {0x1d552, 0x1d56b}, {0x1d586, 0x1d59f},
{0x1d5ba, 0x1d5d3}, {0x1d5ee, 0x1d607}, {0x1d622, 0x1d63b}, {0x1d656, 0x1d66f},
{0x1d68a, 0x1d6a5}, {0x1d6c2, 0x1d6da}, {0x1d6dc, 0x1d6e1}, {0x1d6fc, 0x1d714},
{0x1d716, 0x1d71b}, {0x1d736, 0x1d74e}, {0x1d750, 0x1d755}, {0x1d770, 0x1d788},
{0x1d78a, 0x1d78f}, {0x1d7aa, 0x1d7c2}, {0x1d7c4, 0x1d7c9}
#endif
};
#define NUM_LOWER_RANGE (sizeof(lowerRangeTable)/sizeof(crange))
static CONST chr lowerCharTable[] = {
0xb5, 0x101, 0x103, 0x105, 0x107, 0x109, 0x10b, 0x10d, 0x10f,
0x111, 0x113, 0x115, 0x117, 0x119, 0x11b, 0x11d, 0x11f, 0x121,
0x123, 0x125, 0x127, 0x129, 0x12b, 0x12d, 0x12f, 0x131, 0x133,
0x135, 0x137, 0x138, 0x13a, 0x13c, 0x13e, 0x140, 0x142, 0x144,
0x146, 0x148, 0x149, 0x14b, 0x14d, 0x14f, 0x151, 0x153, 0x155,
0x157, 0x159, 0x15b, 0x15d, 0x15f, 0x161, 0x163, 0x165, 0x167,
0x169, 0x16b, 0x16d, 0x16f, 0x171, 0x173, 0x175, 0x177, 0x17a,
0x17c, 0x183, 0x185, 0x188, 0x18c, 0x18d, 0x192, 0x195, 0x19e,
0x1a1, 0x1a3, 0x1a5, 0x1a8, 0x1aa, 0x1ab, 0x1ad, 0x1b0, 0x1b4,
0x1b6, 0x1b9, 0x1ba, 0x1c6, 0x1c9, 0x1cc, 0x1ce, 0x1d0, 0x1d2,
0x1d4, 0x1d6, 0x1d8, 0x1da, 0x1dc, 0x1dd, 0x1df, 0x1e1, 0x1e3,
0x1e5, 0x1e7, 0x1e9, 0x1eb, 0x1ed, 0x1ef, 0x1f0, 0x1f3, 0x1f5,
0x1f9, 0x1fb, 0x1fd, 0x1ff, 0x201, 0x203, 0x205, 0x207, 0x209,
0x20b, 0x20d, 0x20f, 0x211, 0x213, 0x215, 0x217, 0x219, 0x21b,
0x21d, 0x21f, 0x221, 0x223, 0x225, 0x227, 0x229, 0x22b, 0x22d,
0x22f, 0x231, 0x23c, 0x23f, 0x240, 0x242, 0x247, 0x249, 0x24b,
0x24d, 0x371, 0x373, 0x377, 0x390, 0x3d0, 0x3d1, 0x3d9, 0x3db,
0x3dd, 0x3df, 0x3e1, 0x3e3, 0x3e5, 0x3e7, 0x3e9, 0x3eb, 0x3ed,
0x3f5, 0x3f8, 0x3fb, 0x3fc, 0x461, 0x463, 0x465, 0x467, 0x469,
0x46b, 0x46d, 0x46f, 0x471, 0x473, 0x475, 0x477, 0x479, 0x47b,
0x47d, 0x47f, 0x481, 0x48b, 0x48d, 0x48f, 0x491, 0x493, 0x495,
0x497, 0x499, 0x49b, 0x49d, 0x49f, 0x4a1, 0x4a3, 0x4a5, 0x4a7,
0x4a9, 0x4ab, 0x4ad, 0x4af, 0x4b1, 0x4b3, 0x4b5, 0x4b7, 0x4b9,
0x4bb, 0x4bd, 0x4bf, 0x4c2, 0x4c4, 0x4c6, 0x4c8, 0x4ca, 0x4cc,
0x4ce, 0x4cf, 0x4d1, 0x4d3, 0x4d5, 0x4d7, 0x4d9, 0x4db, 0x4dd,
0x4df, 0x4e1, 0x4e3, 0x4e5, 0x4e7, 0x4e9, 0x4eb, 0x4ed, 0x4ef,
0x4f1, 0x4f3, 0x4f5, 0x4f7, 0x4f9, 0x4fb, 0x4fd, 0x4ff, 0x501,
0x503, 0x505, 0x507, 0x509, 0x50b, 0x50d, 0x50f, 0x511, 0x513,
0x515, 0x517, 0x519, 0x51b, 0x51d, 0x51f, 0x521, 0x523, 0x525,
0x527, 0x1e01, 0x1e03, 0x1e05, 0x1e07, 0x1e09, 0x1e0b, 0x1e0d, 0x1e0f,
0x1e11, 0x1e13, 0x1e15, 0x1e17, 0x1e19, 0x1e1b, 0x1e1d, 0x1e1f, 0x1e21,
0x1e23, 0x1e25, 0x1e27, 0x1e29, 0x1e2b, 0x1e2d, 0x1e2f, 0x1e31, 0x1e33,
0x1e35, 0x1e37, 0x1e39, 0x1e3b, 0x1e3d, 0x1e3f, 0x1e41, 0x1e43, 0x1e45,
0x1e47, 0x1e49, 0x1e4b, 0x1e4d, 0x1e4f, 0x1e51, 0x1e53, 0x1e55, 0x1e57,
0x1e59, 0x1e5b, 0x1e5d, 0x1e5f, 0x1e61, 0x1e63, 0x1e65, 0x1e67, 0x1e69,
0x1e6b, 0x1e6d, 0x1e6f, 0x1e71, 0x1e73, 0x1e75, 0x1e77, 0x1e79, 0x1e7b,
0x1e7d, 0x1e7f, 0x1e81, 0x1e83, 0x1e85, 0x1e87, 0x1e89, 0x1e8b, 0x1e8d,
0x1e8f, 0x1e91, 0x1e93, 0x1e9f, 0x1ea1, 0x1ea3, 0x1ea5, 0x1ea7, 0x1ea9,
0x1eab, 0x1ead, 0x1eaf, 0x1eb1, 0x1eb3, 0x1eb5, 0x1eb7, 0x1eb9, 0x1ebb,
0x1ebd, 0x1ebf, 0x1ec1, 0x1ec3, 0x1ec5, 0x1ec7, 0x1ec9, 0x1ecb, 0x1ecd,
0x1ecf, 0x1ed1, 0x1ed3, 0x1ed5, 0x1ed7, 0x1ed9, 0x1edb, 0x1edd, 0x1edf,
0x1ee1, 0x1ee3, 0x1ee5, 0x1ee7, 0x1ee9, 0x1eeb, 0x1eed, 0x1eef, 0x1ef1,
0x1ef3, 0x1ef5, 0x1ef7, 0x1ef9, 0x1efb, 0x1efd, 0x1fb6, 0x1fb7, 0x1fbe,
0x1fc6, 0x1fc7, 0x1fd6, 0x1fd7, 0x1ff6, 0x1ff7, 0x210a, 0x210e, 0x210f,
0x2113, 0x212f, 0x2134, 0x2139, 0x213c, 0x213d, 0x214e, 0x2184, 0x2c61,
0x2c65, 0x2c66, 0x2c68, 0x2c6a, 0x2c6c, 0x2c71, 0x2c73, 0x2c74, 0x2c81,
0x2c83, 0x2c85, 0x2c87, 0x2c89, 0x2c8b, 0x2c8d, 0x2c8f, 0x2c91, 0x2c93,
0x2c95, 0x2c97, 0x2c99, 0x2c9b, 0x2c9d, 0x2c9f, 0x2ca1, 0x2ca3, 0x2ca5,
0x2ca7, 0x2ca9, 0x2cab, 0x2cad, 0x2caf, 0x2cb1, 0x2cb3, 0x2cb5, 0x2cb7,
0x2cb9, 0x2cbb, 0x2cbd, 0x2cbf, 0x2cc1, 0x2cc3, 0x2cc5, 0x2cc7, 0x2cc9,
0x2ccb, 0x2ccd, 0x2ccf, 0x2cd1, 0x2cd3, 0x2cd5, 0x2cd7, 0x2cd9, 0x2cdb,
0x2cdd, 0x2cdf, 0x2ce1, 0x2ce3, 0x2ce4, 0x2cec, 0x2cee, 0x2cf3, 0x2d27,
0x2d2d, 0xa641, 0xa643, 0xa645, 0xa647, 0xa649, 0xa64b, 0xa64d, 0xa64f,
0xa651, 0xa653, 0xa655, 0xa657, 0xa659, 0xa65b, 0xa65d, 0xa65f, 0xa661,
0xa663, 0xa665, 0xa667, 0xa669, 0xa66b, 0xa66d, 0xa681, 0xa683, 0xa685,
0xa687, 0xa689, 0xa68b, 0xa68d, 0xa68f, 0xa691, 0xa693, 0xa695, 0xa697,
0xa723, 0xa725, 0xa727, 0xa729, 0xa72b, 0xa72d, 0xa733, 0xa735, 0xa737,
0xa739, 0xa73b, 0xa73d, 0xa73f, 0xa741, 0xa743, 0xa745, 0xa747, 0xa749,
0xa74b, 0xa74d, 0xa74f, 0xa751, 0xa753, 0xa755, 0xa757, 0xa759, 0xa75b,
0xa75d, 0xa75f, 0xa761, 0xa763, 0xa765, 0xa767, 0xa769, 0xa76b, 0xa76d,
0xa76f, 0xa77a, 0xa77c, 0xa77f, 0xa781, 0xa783, 0xa785, 0xa787, 0xa78c,
0xa78e, 0xa791, 0xa793, 0xa7a1, 0xa7a3, 0xa7a5, 0xa7a7, 0xa7a9, 0xa7fa
#if TCL_UTF_MAX > 4
,0x1d4bb, 0x1d7cb
#endif
};
#define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr))
/*
* Unicode: uppercase characters.
*/
static CONST crange upperRangeTable[] = {
{0x41, 0x5a}, {0xc0, 0xd6}, {0xd8, 0xde}, {0x189, 0x18b},
{0x18e, 0x191}, {0x196, 0x198}, {0x1b1, 0x1b3}, {0x1f6, 0x1f8},
{0x243, 0x246}, {0x388, 0x38a}, {0x391, 0x3a1}, {0x3a3, 0x3ab},
{0x3d2, 0x3d4}, {0x3fd, 0x42f}, {0x531, 0x556}, {0x10a0, 0x10c5},
{0x1f08, 0x1f0f}, {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, {0x1f38, 0x1f3f},
{0x1f48, 0x1f4d}, {0x1f68, 0x1f6f}, {0x1fb8, 0x1fbb}, {0x1fc8, 0x1fcb},
{0x1fd8, 0x1fdb}, {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffb}, {0x210b, 0x210d},
{0x2110, 0x2112}, {0x2119, 0x211d}, {0x212a, 0x212d}, {0x2130, 0x2133},
{0x2c00, 0x2c2e}, {0x2c62, 0x2c64}, {0x2c6d, 0x2c70}, {0x2c7e, 0x2c80},
{0xff21, 0xff3a}
#if TCL_UTF_MAX > 4
,{0x10400, 0x10427}, {0x1d400, 0x1d419}, {0x1d434, 0x1d44d}, {0x1d468, 0x1d481},
{0x1d4a9, 0x1d4ac}, {0x1d4ae, 0x1d4b5}, {0x1d4d0, 0x1d4e9}, {0x1d507, 0x1d50a},
{0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d53b, 0x1d53e}, {0x1d540, 0x1d544},
{0x1d54a, 0x1d550}, {0x1d56c, 0x1d585}, {0x1d5a0, 0x1d5b9}, {0x1d5d4, 0x1d5ed},
{0x1d608, 0x1d621}, {0x1d63c, 0x1d655}, {0x1d670, 0x1d689}, {0x1d6a8, 0x1d6c0},
{0x1d6e2, 0x1d6fa}, {0x1d71c, 0x1d734}, {0x1d756, 0x1d76e}, {0x1d790, 0x1d7a8}
#endif
};
#define NUM_UPPER_RANGE (sizeof(upperRangeTable)/sizeof(crange))
static CONST chr upperCharTable[] = {
0x100, 0x102, 0x104, 0x106, 0x108, 0x10a, 0x10c, 0x10e, 0x110,
0x112, 0x114, 0x116, 0x118, 0x11a, 0x11c, 0x11e, 0x120, 0x122,
0x124, 0x126, 0x128, 0x12a, 0x12c, 0x12e, 0x130, 0x132, 0x134,
0x136, 0x139, 0x13b, 0x13d, 0x13f, 0x141, 0x143, 0x145, 0x147,
0x14a, 0x14c, 0x14e, 0x150, 0x152, 0x154, 0x156, 0x158, 0x15a,
0x15c, 0x15e, 0x160, 0x162, 0x164, 0x166, 0x168, 0x16a, 0x16c,
0x16e, 0x170, 0x172, 0x174, 0x176, 0x178, 0x179, 0x17b, 0x17d,
0x181, 0x182, 0x184, 0x186, 0x187, 0x193, 0x194, 0x19c, 0x19d,
0x19f, 0x1a0, 0x1a2, 0x1a4, 0x1a6, 0x1a7, 0x1a9, 0x1ac, 0x1ae,
0x1af, 0x1b5, 0x1b7, 0x1b8, 0x1bc, 0x1c4, 0x1c7, 0x1ca, 0x1cd,
0x1cf, 0x1d1, 0x1d3, 0x1d5, 0x1d7, 0x1d9, 0x1db, 0x1de, 0x1e0,
0x1e2, 0x1e4, 0x1e6, 0x1e8, 0x1ea, 0x1ec, 0x1ee, 0x1f1, 0x1f4,
0x1fa, 0x1fc, 0x1fe, 0x200, 0x202, 0x204, 0x206, 0x208, 0x20a,
0x20c, 0x20e, 0x210, 0x212, 0x214, 0x216, 0x218, 0x21a, 0x21c,
0x21e, 0x220, 0x222, 0x224, 0x226, 0x228, 0x22a, 0x22c, 0x22e,
0x230, 0x232, 0x23a, 0x23b, 0x23d, 0x23e, 0x241, 0x248, 0x24a,
0x24c, 0x24e, 0x370, 0x372, 0x376, 0x386, 0x38c, 0x38e, 0x38f,
0x3cf, 0x3d8, 0x3da, 0x3dc, 0x3de, 0x3e0, 0x3e2, 0x3e4, 0x3e6,
0x3e8, 0x3ea, 0x3ec, 0x3ee, 0x3f4, 0x3f7, 0x3f9, 0x3fa, 0x460,
0x462, 0x464, 0x466, 0x468, 0x46a, 0x46c, 0x46e, 0x470, 0x472,
0x474, 0x476, 0x478, 0x47a, 0x47c, 0x47e, 0x480, 0x48a, 0x48c,
0x48e, 0x490, 0x492, 0x494, 0x496, 0x498, 0x49a, 0x49c, 0x49e,
0x4a0, 0x4a2, 0x4a4, 0x4a6, 0x4a8, 0x4aa, 0x4ac, 0x4ae, 0x4b0,
0x4b2, 0x4b4, 0x4b6, 0x4b8, 0x4ba, 0x4bc, 0x4be, 0x4c0, 0x4c1,
0x4c3, 0x4c5, 0x4c7, 0x4c9, 0x4cb, 0x4cd, 0x4d0, 0x4d2, 0x4d4,
0x4d6, 0x4d8, 0x4da, 0x4dc, 0x4de, 0x4e0, 0x4e2, 0x4e4, 0x4e6,
0x4e8, 0x4ea, 0x4ec, 0x4ee, 0x4f0, 0x4f2, 0x4f4, 0x4f6, 0x4f8,
0x4fa, 0x4fc, 0x4fe, 0x500, 0x502, 0x504, 0x506, 0x508, 0x50a,
0x50c, 0x50e, 0x510, 0x512, 0x514, 0x516, 0x518, 0x51a, 0x51c,
0x51e, 0x520, 0x522, 0x524, 0x526, 0x10c7, 0x10cd, 0x1e00, 0x1e02,
0x1e04, 0x1e06, 0x1e08, 0x1e0a, 0x1e0c, 0x1e0e, 0x1e10, 0x1e12, 0x1e14,
0x1e16, 0x1e18, 0x1e1a, 0x1e1c, 0x1e1e, 0x1e20, 0x1e22, 0x1e24, 0x1e26,
0x1e28, 0x1e2a, 0x1e2c, 0x1e2e, 0x1e30, 0x1e32, 0x1e34, 0x1e36, 0x1e38,
0x1e3a, 0x1e3c, 0x1e3e, 0x1e40, 0x1e42, 0x1e44, 0x1e46, 0x1e48, 0x1e4a,
0x1e4c, 0x1e4e, 0x1e50, 0x1e52, 0x1e54, 0x1e56, 0x1e58, 0x1e5a, 0x1e5c,
0x1e5e, 0x1e60, 0x1e62, 0x1e64, 0x1e66, 0x1e68, 0x1e6a, 0x1e6c, 0x1e6e,
0x1e70, 0x1e72, 0x1e74, 0x1e76, 0x1e78, 0x1e7a, 0x1e7c, 0x1e7e, 0x1e80,
0x1e82, 0x1e84, 0x1e86, 0x1e88, 0x1e8a, 0x1e8c, 0x1e8e, 0x1e90, 0x1e92,
0x1e94, 0x1e9e, 0x1ea0, 0x1ea2, 0x1ea4, 0x1ea6, 0x1ea8, 0x1eaa, 0x1eac,
0x1eae, 0x1eb0, 0x1eb2, 0x1eb4, 0x1eb6, 0x1eb8, 0x1eba, 0x1ebc, 0x1ebe,
0x1ec0, 0x1ec2, 0x1ec4, 0x1ec6, 0x1ec8, 0x1eca, 0x1ecc, 0x1ece, 0x1ed0,
0x1ed2, 0x1ed4, 0x1ed6, 0x1ed8, 0x1eda, 0x1edc, 0x1ede, 0x1ee0, 0x1ee2,
0x1ee4, 0x1ee6, 0x1ee8, 0x1eea, 0x1eec, 0x1eee, 0x1ef0, 0x1ef2, 0x1ef4,
0x1ef6, 0x1ef8, 0x1efa, 0x1efc, 0x1efe, 0x1f59, 0x1f5b, 0x1f5d, 0x1f5f,
0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x213e, 0x213f, 0x2145,
0x2183, 0x2c60, 0x2c67, 0x2c69, 0x2c6b, 0x2c72, 0x2c75, 0x2c82, 0x2c84,
0x2c86, 0x2c88, 0x2c8a, 0x2c8c, 0x2c8e, 0x2c90, 0x2c92, 0x2c94, 0x2c96,
0x2c98, 0x2c9a, 0x2c9c, 0x2c9e, 0x2ca0, 0x2ca2, 0x2ca4, 0x2ca6, 0x2ca8,
0x2caa, 0x2cac, 0x2cae, 0x2cb0, 0x2cb2, 0x2cb4, 0x2cb6, 0x2cb8, 0x2cba,
0x2cbc, 0x2cbe, 0x2cc0, 0x2cc2, 0x2cc4, 0x2cc6, 0x2cc8, 0x2cca, 0x2ccc,
0x2cce, 0x2cd0, 0x2cd2, 0x2cd4, 0x2cd6, 0x2cd8, 0x2cda, 0x2cdc, 0x2cde,
0x2ce0, 0x2ce2, 0x2ceb, 0x2ced, 0x2cf2, 0xa640, 0xa642, 0xa644, 0xa646,
0xa648, 0xa64a, 0xa64c, 0xa64e, 0xa650, 0xa652, 0xa654, 0xa656, 0xa658,
0xa65a, 0xa65c, 0xa65e, 0xa660, 0xa662, 0xa664, 0xa666, 0xa668, 0xa66a,
0xa66c, 0xa680, 0xa682, 0xa684, 0xa686, 0xa688, 0xa68a, 0xa68c, 0xa68e,
0xa690, 0xa692, 0xa694, 0xa696, 0xa722, 0xa724, 0xa726, 0xa728, 0xa72a,
0xa72c, 0xa72e, 0xa732, 0xa734, 0xa736, 0xa738, 0xa73a, 0xa73c, 0xa73e,
0xa740, 0xa742, 0xa744, 0xa746, 0xa748, 0xa74a, 0xa74c, 0xa74e, 0xa750,
0xa752, 0xa754, 0xa756, 0xa758, 0xa75a, 0xa75c, 0xa75e, 0xa760, 0xa762,
0xa764, 0xa766, 0xa768, 0xa76a, 0xa76c, 0xa76e, 0xa779, 0xa77b, 0xa77d,
0xa77e, 0xa780, 0xa782, 0xa784, 0xa786, 0xa78b, 0xa78d, 0xa790, 0xa792,
0xa7a0, 0xa7a2, 0xa7a4, 0xa7a6, 0xa7a8, 0xa7aa
#if TCL_UTF_MAX > 4
,0x1d49c, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d504, 0x1d505, 0x1d538,
0x1d539, 0x1d546, 0x1d7ca
#endif
};
#define NUM_UPPER_CHAR (sizeof(upperCharTable)/sizeof(chr))
/*
* Unicode: unicode print characters excluding space.
*/
static CONST crange graphRangeTable[] = {
{0x21, 0x7e}, {0xa1, 0xac}, {0xae, 0x377}, {0x37a, 0x37e},
{0x384, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x527}, {0x531, 0x556},
{0x559, 0x55f}, {0x561, 0x587}, {0x591, 0x5c7}, {0x5d0, 0x5ea},
{0x5f0, 0x5f4}, {0x606, 0x61b}, {0x61e, 0x6dc}, {0x6de, 0x70d},
{0x710, 0x74a}, {0x74d, 0x7b1}, {0x7c0, 0x7fa}, {0x800, 0x82d},
{0x830, 0x83e}, {0x840, 0x85b}, {0x8a2, 0x8ac}, {0x8e4, 0x8fe},
{0x900, 0x977}, {0x979, 0x97f}, {0x981, 0x983}, {0x985, 0x98c},
{0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, {0x9bc, 0x9c4},
{0x9cb, 0x9ce}, {0x9df, 0x9e3}, {0x9e6, 0x9fb}, {0xa01, 0xa03},
{0xa05, 0xa0a}, {0xa13, 0xa28}, {0xa2a, 0xa30}, {0xa3e, 0xa42},
{0xa4b, 0xa4d}, {0xa59, 0xa5c}, {0xa66, 0xa75}, {0xa81, 0xa83},
{0xa85, 0xa8d}, {0xa8f, 0xa91}, {0xa93, 0xaa8}, {0xaaa, 0xab0},
{0xab5, 0xab9}, {0xabc, 0xac5}, {0xac7, 0xac9}, {0xacb, 0xacd},
{0xae0, 0xae3}, {0xae6, 0xaf1}, {0xb01, 0xb03}, {0xb05, 0xb0c},
{0xb13, 0xb28}, {0xb2a, 0xb30}, {0xb35, 0xb39}, {0xb3c, 0xb44},
{0xb4b, 0xb4d}, {0xb5f, 0xb63}, {0xb66, 0xb77}, {0xb85, 0xb8a},
{0xb8e, 0xb90}, {0xb92, 0xb95}, {0xba8, 0xbaa}, {0xbae, 0xbb9},
{0xbbe, 0xbc2}, {0xbc6, 0xbc8}, {0xbca, 0xbcd}, {0xbe6, 0xbfa},
{0xc01, 0xc03}, {0xc05, 0xc0c}, {0xc0e, 0xc10}, {0xc12, 0xc28},
{0xc2a, 0xc33}, {0xc35, 0xc39}, {0xc3d, 0xc44}, {0xc46, 0xc48},
{0xc4a, 0xc4d}, {0xc60, 0xc63}, {0xc66, 0xc6f}, {0xc78, 0xc7f},
{0xc85, 0xc8c}, {0xc8e, 0xc90}, {0xc92, 0xca8}, {0xcaa, 0xcb3},
{0xcb5, 0xcb9}, {0xcbc, 0xcc4}, {0xcc6, 0xcc8}, {0xcca, 0xccd},
{0xce0, 0xce3}, {0xce6, 0xcef}, {0xd05, 0xd0c}, {0xd0e, 0xd10},
{0xd12, 0xd3a}, {0xd3d, 0xd44}, {0xd46, 0xd48}, {0xd4a, 0xd4e},
{0xd60, 0xd63}, {0xd66, 0xd75}, {0xd79, 0xd7f}, {0xd85, 0xd96},
{0xd9a, 0xdb1}, {0xdb3, 0xdbb}, {0xdc0, 0xdc6}, {0xdcf, 0xdd4},
{0xdd8, 0xddf}, {0xdf2, 0xdf4}, {0xe01, 0xe3a}, {0xe3f, 0xe5b},
{0xe94, 0xe97}, {0xe99, 0xe9f}, {0xea1, 0xea3}, {0xead, 0xeb9},
{0xebb, 0xebd}, {0xec0, 0xec4}, {0xec8, 0xecd}, {0xed0, 0xed9},
{0xedc, 0xedf}, {0xf00, 0xf47}, {0xf49, 0xf6c}, {0xf71, 0xf97},
{0xf99, 0xfbc}, {0xfbe, 0xfcc}, {0xfce, 0xfda}, {0x1000, 0x10c5},
{0x10d0, 0x1248}, {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d},
{0x1260, 0x1288}, {0x128a, 0x128d}, {0x1290, 0x12b0}, {0x12b2, 0x12b5},
{0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12d6}, {0x12d8, 0x1310},
{0x1312, 0x1315}, {0x1318, 0x135a}, {0x135d, 0x137c}, {0x1380, 0x1399},
{0x13a0, 0x13f4}, {0x1400, 0x167f}, {0x1681, 0x169c}, {0x16a0, 0x16f0},
{0x1700, 0x170c}, {0x170e, 0x1714}, {0x1720, 0x1736}, {0x1740, 0x1753},
{0x1760, 0x176c}, {0x176e, 0x1770}, {0x1780, 0x17dd}, {0x17e0, 0x17e9},
{0x17f0, 0x17f9}, {0x1800, 0x180d}, {0x1810, 0x1819}, {0x1820, 0x1877},
{0x1880, 0x18aa}, {0x18b0, 0x18f5}, {0x1900, 0x191c}, {0x1920, 0x192b},
{0x1930, 0x193b}, {0x1944, 0x196d}, {0x1970, 0x1974}, {0x1980, 0x19ab},
{0x19b0, 0x19c9}, {0x19d0, 0x19da}, {0x19de, 0x1a1b}, {0x1a1e, 0x1a5e},
{0x1a60, 0x1a7c}, {0x1a7f, 0x1a89}, {0x1a90, 0x1a99}, {0x1aa0, 0x1aad},
{0x1b00, 0x1b4b}, {0x1b50, 0x1b7c}, {0x1b80, 0x1bf3}, {0x1bfc, 0x1c37},
{0x1c3b, 0x1c49}, {0x1c4d, 0x1c7f}, {0x1cc0, 0x1cc7}, {0x1cd0, 0x1cf6},
{0x1d00, 0x1de6}, {0x1dfc, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f20, 0x1f45},
{0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4},
{0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef},
{0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, {0x2010, 0x2027}, {0x2030, 0x205e},
{0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20ba}, {0x20d0, 0x20f0},
{0x2100, 0x2189}, {0x2190, 0x23f3}, {0x2400, 0x2426}, {0x2440, 0x244a},
{0x2460, 0x26ff}, {0x2701, 0x2b4c}, {0x2b50, 0x2b59}, {0x2c00, 0x2c2e},
{0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, {0x2cf9, 0x2d25}, {0x2d30, 0x2d67},
{0x2d7f, 0x2d96}, {0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6},
{0x2db8, 0x2dbe}, {0x2dc0, 0x2dc6}, {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6},
{0x2dd8, 0x2dde}, {0x2de0, 0x2e3b}, {0x2e80, 0x2e99}, {0x2e9b, 0x2ef3},
{0x2f00, 0x2fd5}, {0x2ff0, 0x2ffb}, {0x3001, 0x303f}, {0x3041, 0x3096},
{0x3099, 0x30ff}, {0x3105, 0x312d}, {0x3131, 0x318e}, {0x3190, 0x31ba},
{0x31c0, 0x31e3}, {0x31f0, 0x321e}, {0x3220, 0x32fe}, {0x3300, 0x4db5},
{0x4dc0, 0x9fcc}, {0xa000, 0xa48c}, {0xa490, 0xa4c6}, {0xa4d0, 0xa62b},
{0xa640, 0xa697}, {0xa69f, 0xa6f7}, {0xa700, 0xa78e}, {0xa790, 0xa793},
{0xa7a0, 0xa7aa}, {0xa7f8, 0xa82b}, {0xa830, 0xa839}, {0xa840, 0xa877},
{0xa880, 0xa8c4}, {0xa8ce, 0xa8d9}, {0xa8e0, 0xa8fb}, {0xa900, 0xa953},
{0xa95f, 0xa97c}, {0xa980, 0xa9cd}, {0xa9cf, 0xa9d9}, {0xaa00, 0xaa36},
{0xaa40, 0xaa4d}, {0xaa50, 0xaa59}, {0xaa5c, 0xaa7b}, {0xaa80, 0xaac2},
{0xaadb, 0xaaf6}, {0xab01, 0xab06}, {0xab09, 0xab0e}, {0xab11, 0xab16},
{0xab20, 0xab26}, {0xab28, 0xab2e}, {0xabc0, 0xabed}, {0xabf0, 0xabf9},
{0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xf900, 0xfa6d},
{0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb36},
{0xfb38, 0xfb3c}, {0xfb46, 0xfbc1}, {0xfbd3, 0xfd3f}, {0xfd50, 0xfd8f},
{0xfd92, 0xfdc7}, {0xfdf0, 0xfdfd}, {0xfe00, 0xfe19}, {0xfe20, 0xfe26},
{0xfe30, 0xfe52}, {0xfe54, 0xfe66}, {0xfe68, 0xfe6b}, {0xfe70, 0xfe74},
{0xfe76, 0xfefc}, {0xff01, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf},
{0xffd2, 0xffd7}, {0xffda, 0xffdc}, {0xffe0, 0xffe6}, {0xffe8, 0xffee}
#if TCL_UTF_MAX > 4
,{0x10000, 0x1000b}, {0x1000d, 0x10026}, {0x10028, 0x1003a}, {0x1003f, 0x1004d},
{0x10050, 0x1005d}, {0x10080, 0x100fa}, {0x10100, 0x10102}, {0x10107, 0x10133},
{0x10137, 0x1018a}, {0x10190, 0x1019b}, {0x101d0, 0x101fd}, {0x10280, 0x1029c},
{0x102a0, 0x102d0}, {0x10300, 0x1031e}, {0x10320, 0x10323}, {0x10330, 0x1034a},
{0x10380, 0x1039d}, {0x1039f, 0x103c3}, {0x103c8, 0x103d5}, {0x10400, 0x1049d},
{0x104a0, 0x104a9}, {0x10800, 0x10805}, {0x1080a, 0x10835}, {0x1083f, 0x10855},
{0x10857, 0x1085f}, {0x10900, 0x1091b}, {0x1091f, 0x10939}, {0x10980, 0x109b7},
{0x10a00, 0x10a03}, {0x10a0c, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a33},
{0x10a38, 0x10a3a}, {0x10a3f, 0x10a47}, {0x10a50, 0x10a58}, {0x10a60, 0x10a7f},
{0x10b00, 0x10b35}, {0x10b39, 0x10b55}, {0x10b58, 0x10b72}, {0x10b78, 0x10b7f},
{0x10c00, 0x10c48}, {0x10e60, 0x10e7e}, {0x11000, 0x1104d}, {0x11052, 0x1106f},
{0x11080, 0x110bc}, {0x110be, 0x110c1}, {0x110d0, 0x110e8}, {0x110f0, 0x110f9},
{0x11100, 0x11134}, {0x11136, 0x11143}, {0x11180, 0x111c8}, {0x111d0, 0x111d9},
{0x11680, 0x116b7}, {0x116c0, 0x116c9}, {0x12000, 0x1236e}, {0x12400, 0x12462},
{0x12470, 0x12473}, {0x13000, 0x1342e}, {0x16800, 0x16a38}, {0x16f00, 0x16f44},
{0x16f50, 0x16f7e}, {0x16f8f, 0x16f9f}, {0x1d000, 0x1d0f5}, {0x1d100, 0x1d126},
{0x1d129, 0x1d172}, {0x1d17b, 0x1d1dd}, {0x1d200, 0x1d245}, {0x1d300, 0x1d356},
{0x1d360, 0x1d371}, {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac},
{0x1d4ae, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a},
{0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d51e, 0x1d539}, {0x1d53b, 0x1d53e},
{0x1d540, 0x1d544}, {0x1d54a, 0x1d550}, {0x1d552, 0x1d6a5}, {0x1d6a8, 0x1d7cb},
{0x1d7ce, 0x1d7ff}, {0x1ee00, 0x1ee03}, {0x1ee05, 0x1ee1f}, {0x1ee29, 0x1ee32},
{0x1ee34, 0x1ee37}, {0x1ee4d, 0x1ee4f}, {0x1ee67, 0x1ee6a}, {0x1ee6c, 0x1ee72},
{0x1ee74, 0x1ee77}, {0x1ee79, 0x1ee7c}, {0x1ee80, 0x1ee89}, {0x1ee8b, 0x1ee9b},
{0x1eea1, 0x1eea3}, {0x1eea5, 0x1eea9}, {0x1eeab, 0x1eebb}, {0x1f000, 0x1f02b},
{0x1f030, 0x1f093}, {0x1f0a0, 0x1f0ae}, {0x1f0b1, 0x1f0be}, {0x1f0c1, 0x1f0cf},
{0x1f0d1, 0x1f0df}, {0x1f100, 0x1f10a}, {0x1f110, 0x1f12e}, {0x1f130, 0x1f16b},
{0x1f170, 0x1f19a}, {0x1f1e6, 0x1f202}, {0x1f210, 0x1f23a}, {0x1f240, 0x1f248},
{0x1f300, 0x1f320}, {0x1f330, 0x1f335}, {0x1f337, 0x1f37c}, {0x1f380, 0x1f393},
{0x1f3a0, 0x1f3c4}, {0x1f3c6, 0x1f3ca}, {0x1f3e0, 0x1f3f0}, {0x1f400, 0x1f43e},
{0x1f442, 0x1f4f7}, {0x1f4f9, 0x1f4fc}, {0x1f500, 0x1f53d}, {0x1f540, 0x1f543},
{0x1f550, 0x1f567}, {0x1f5fb, 0x1f640}, {0x1f645, 0x1f64f}, {0x1f680, 0x1f6c5},
{0x1f700, 0x1f773}, {0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, {0x2b740, 0x2b81d},
{0x2f800, 0x2fa1d}, {0xe0100, 0xe01ef}
#endif
};
#define NUM_GRAPH_RANGE (sizeof(graphRangeTable)/sizeof(crange))
static CONST chr graphCharTable[] = {
0x38c, 0x589, 0x58a, 0x58f, 0x85e, 0x8a0, 0x98f, 0x990, 0x9b2,
0x9c7, 0x9c8, 0x9d7, 0x9dc, 0x9dd, 0xa0f, 0xa10, 0xa32, 0xa33,
0xa35, 0xa36, 0xa38, 0xa39, 0xa3c, 0xa47, 0xa48, 0xa51, 0xa5e,
0xab2, 0xab3, 0xad0, 0xb0f, 0xb10, 0xb32, 0xb33, 0xb47, 0xb48,
0xb56, 0xb57, 0xb5c, 0xb5d, 0xb82, 0xb83, 0xb99, 0xb9a, 0xb9c,
0xb9e, 0xb9f, 0xba3, 0xba4, 0xbd0, 0xbd7, 0xc55, 0xc56, 0xc58,
0xc59, 0xc82, 0xc83, 0xcd5, 0xcd6, 0xcde, 0xcf1, 0xcf2, 0xd02,
0xd03, 0xd57, 0xd82, 0xd83, 0xdbd, 0xdca, 0xdd6, 0xe81, 0xe82,
0xe84, 0xe87, 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab,
0xec6, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x1772, 0x1773, 0x1940, 0x1f59,
0x1f5b, 0x1f5d, 0x2070, 0x2071, 0x2d27, 0x2d2d, 0x2d6f, 0x2d70, 0xa9de,
0xa9df, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfffc, 0xfffd
#if TCL_UTF_MAX > 4
,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x1093f, 0x109be, 0x109bf,
0x10a05, 0x10a06, 0x1b000, 0x1b001, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6,
0x1d4bb, 0x1d546, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, 0x1ee3b, 0x1ee42,
0x1ee47, 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, 0x1ee59, 0x1ee5b,
0x1ee5d, 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e, 0x1eef0, 0x1eef1, 0x1f250,
0x1f251, 0x1f440
#endif
};
#define NUM_GRAPH_CHAR (sizeof(graphCharTable)/sizeof(chr))
/*
* End of auto-generated Unicode character ranges declarations.
*/
#define CH NOCELT
/*
- element - map collating-element name to celt
^ static celt element(struct vars *, CONST chr *, CONST chr *);
*/
static celt
element(v, startp, endp)
struct vars *v; /* context */
CONST chr *startp; /* points to start of name */
CONST chr *endp; /* points just past end of name */
{
CONST struct cname *cn;
size_t len;
Tcl_DString ds;
CONST char *np;
/*
* Generic: one-chr names stand for themselves.
*/
assert(startp < endp);
len = endp - startp;
if (len == 1) {
return *startp;
}
NOTE(REG_ULOCALE);
/*
* Search table.
*/
Tcl_DStringInit(&ds);
np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
for (cn=cnames; cn->name!=NULL; cn++) {
if (strlen(cn->name)==len && strncmp(cn->name, np, len)==0) {
break; /* NOTE BREAK OUT */
}
}
Tcl_DStringFree(&ds);
if (cn->name != NULL) {
return CHR(cn->code);
}
/*
* Couldn't find it.
*/
ERR(REG_ECOLLATE);
return 0;
}
/*
- range - supply cvec for a range, including legality check
^ static struct cvec *range(struct vars *, celt, celt, int);
*/
static struct cvec *
range(v, a, b, cases)
struct vars *v; /* context */
celt a; /* range start */
celt b; /* range end, might equal a */
int cases; /* case-independent? */
{
int nchrs;
struct cvec *cv;
celt c, lc, uc, tc;
if (a != b && !before(a, b)) {
ERR(REG_ERANGE);
return NULL;
}
if (!cases) { /* easy version */
cv = getcvec(v, 0, 1);
NOERRN();
addrange(cv, a, b);
return cv;
}
/*
* When case-independent, it's hard to decide when cvec ranges are usable,
* so for now at least, we won't try. We allocate enough space for two
* case variants plus a little extra for the two title case variants.
*/
nchrs = (b - a + 1)*2 + 4;
cv = getcvec(v, nchrs, 0);
NOERRN();
for (c=a; c<=b; c++) {
addchr(cv, c);
lc = Tcl_UniCharToLower((chr)c);
uc = Tcl_UniCharToUpper((chr)c);
tc = Tcl_UniCharToTitle((chr)c);
if (c != lc) {
addchr(cv, lc);
}
if (c != uc) {
addchr(cv, uc);
}
if (c != tc && tc != uc) {
addchr(cv, tc);
}
}
return cv;
}
/*
- before - is celt x before celt y, for purposes of range legality?
^ static int before(celt, celt);
*/
static int /* predicate */
before(x, y)
celt x, y; /* collating elements */
{
if (x < y) {
return 1;
}
return 0;
}
/*
- eclass - supply cvec for an equivalence class
* Must include case counterparts on request.
^ static struct cvec *eclass(struct vars *, celt, int);
*/
static struct cvec *
eclass(v, c, cases)
struct vars *v; /* context */
celt c; /* Collating element representing
* the equivalence class. */
int cases; /* all cases? */
{
struct cvec *cv;
/*
* Crude fake equivalence class for testing.
*/
if ((v->cflags®_FAKE) && c == 'x') {
cv = getcvec(v, 4, 0);
addchr(cv, (chr)'x');
addchr(cv, (chr)'y');
if (cases) {
addchr(cv, (chr)'X');
addchr(cv, (chr)'Y');
}
return cv;
}
/*
* Otherwise, none.
*/
if (cases) {
return allcases(v, c);
}
cv = getcvec(v, 1, 0);
assert(cv != NULL);
addchr(cv, (chr)c);
return cv;
}
/*
- cclass - supply cvec for a character class
* Must include case counterparts on request.
^ static struct cvec *cclass(struct vars *, CONST chr *, CONST chr *, int);
*/
static struct cvec *
cclass(v, startp, endp, cases)
struct vars *v; /* context */
CONST chr *startp; /* where the name starts */
CONST chr *endp; /* just past the end of the name */
int cases; /* case-independent? */
{
size_t len;
struct cvec *cv = NULL;
Tcl_DString ds;
CONST char *np;
CONST char *CONST *namePtr;
int i, index;
/*
* The following arrays define the valid character class names.
*/
static CONST char *CONST classNames[] = {
"alnum", "alpha", "ascii", "blank", "cntrl", "digit", "graph",
"lower", "print", "punct", "space", "upper", "xdigit", NULL
};
enum classes {
CC_ALNUM, CC_ALPHA, CC_ASCII, CC_BLANK, CC_CNTRL, CC_DIGIT, CC_GRAPH,
CC_LOWER, CC_PRINT, CC_PUNCT, CC_SPACE, CC_UPPER, CC_XDIGIT
};
/*
* Extract the class name
*/
len = endp - startp;
Tcl_DStringInit(&ds);
np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
/*
* Map the name to the corresponding enumerated value.
*/
index = -1;
for (namePtr=classNames,i=0 ; *namePtr!=NULL ; namePtr++,i++) {
if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) {
index = i;
break;
}
}
Tcl_DStringFree(&ds);
if (index == -1) {
ERR(REG_ECTYPE);
return NULL;
}
/*
* Remap lower and upper to alpha if the match is case insensitive.
*/
if (cases && ((index == CC_LOWER) || (index == CC_UPPER))) {
index = CC_ALNUM;
}
/*
* Now compute the character class contents.
*/
switch((enum classes) index) {
case CC_ALNUM:
cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE);
if (cv) {
for (i=0 ; (size_t)i 0; len--, x++, y++) {
if ((*x!=*y) && (Tcl_UniCharToLower(*x) != Tcl_UniCharToLower(*y))) {
return 1;
}
}
return 0;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclUniData.c 0000644 0036047 0045461 00000303254 12052456744 014535 0 ustar dgp 771div /*
* tclUniData.c --
*
* Declarations of Unicode character information tables. This file is
* automatically generated by the tools/uniParse.tcl script. Do not
* modify this file by hand.
*
* Copyright (c) 1998 by Scriptics Corporation.
* All rights reserved.
*/
/*
* A 16-bit Unicode character is split into two parts in order to index
* into the following tables. The lower OFFSET_BITS comprise an offset
* into a page of characters. The upper bits comprise the page number.
*/
#define OFFSET_BITS 5
/*
* The pageMap is indexed by page number and returns an alternate page number
* that identifies a unique page of characters. Many Unicode characters map
* to the same alternate page number.
*/
static CONST unsigned short pageMap[] = {
0, 32, 64, 96, 0, 128, 160, 192, 224, 256, 288, 320, 352, 384, 416,
448, 224, 480, 512, 544, 576, 608, 640, 672, 704, 704, 736, 768, 800,
832, 864, 896, 928, 960, 992, 224, 1024, 224, 1056, 224, 224, 1088,
1120, 1152, 1184, 1216, 1248, 1280, 1312, 1344, 1376, 1408, 1344, 1344,
1440, 1472, 1504, 1536, 1568, 1344, 1344, 1600, 1632, 1664, 1696, 1728,
1760, 1792, 1792, 1824, 1792, 1856, 1888, 1920, 1952, 1984, 2016, 2048,
2080, 2112, 2144, 2176, 2208, 2240, 2272, 2304, 2336, 2368, 2016, 2400,
2432, 2464, 2496, 2528, 2560, 2592, 2624, 2656, 2688, 2720, 2752, 2784,
2816, 2848, 2752, 2880, 2912, 2944, 2976, 3008, 3040, 3072, 3104, 3136,
3168, 1792, 3200, 3232, 3264, 1792, 3296, 3328, 3360, 3392, 3424, 3456,
3488, 1792, 1344, 3520, 3552, 3584, 3616, 3648, 3680, 3712, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 3744, 1344, 3776, 3808,
3840, 1344, 3872, 1344, 3904, 3936, 3968, 1344, 1344, 4000, 4032, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 4064, 4096, 1344, 1344, 4128, 4160, 4192,
4224, 4256, 1344, 4288, 4320, 4352, 4384, 1344, 4416, 4448, 1344, 4480,
1344, 4512, 4544, 4576, 4608, 4640, 1344, 4672, 4704, 4736, 4768, 1344,
4800, 4832, 4864, 4896, 1792, 1792, 4928, 4960, 4992, 5024, 5056, 5088,
1344, 5120, 1344, 5152, 5184, 5216, 1792, 1792, 5248, 5280, 5312, 5344,
5376, 5408, 5440, 5376, 704, 5472, 224, 224, 224, 224, 5504, 224, 224,
224, 5536, 5568, 5600, 5632, 5664, 5696, 5728, 5760, 5792, 5824, 5856,
5888, 5920, 5952, 5984, 6016, 6048, 6080, 6112, 6144, 6176, 6208, 6240,
6272, 6304, 6304, 6304, 6304, 6304, 6304, 6304, 6304, 6336, 6368, 4736,
6400, 6432, 6464, 6496, 6528, 4736, 6560, 6592, 6624, 6656, 6688, 6720,
6752, 4736, 4736, 4736, 4736, 4736, 6784, 6816, 6848, 4736, 4736, 4736,
6880, 4736, 4736, 4736, 4736, 6912, 4736, 4736, 6944, 6976, 4736, 7008,
7040, 4736, 4736, 4736, 4736, 4736, 4736, 4736, 4736, 6304, 6304, 6304,
6304, 7072, 6304, 7104, 7136, 6304, 6304, 6304, 6304, 6304, 6304, 6304,
6304, 4736, 7168, 7200, 1792, 1792, 1792, 1792, 1792, 7232, 7264, 7296,
7328, 224, 224, 224, 7360, 7392, 7424, 1344, 7456, 7488, 7520, 7520,
704, 7552, 7584, 1792, 1792, 7616, 4736, 4736, 7648, 4736, 4736, 4736,
4736, 4736, 4736, 7680, 7712, 7744, 7776, 3104, 1344, 7808, 4032, 1344,
7840, 7872, 7904, 1344, 1344, 7936, 7968, 4736, 8000, 8032, 8064, 8096,
4736, 8064, 8128, 4736, 8032, 4736, 4736, 4736, 4736, 4736, 4736, 4736,
4736, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 4512, 4736, 4736, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 8160,
1792, 8192, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 8224, 4736, 8256, 5216, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 8288, 8320, 224, 8352, 8384, 1344, 1344, 8416, 8448, 8480, 224,
8512, 8544, 8576, 1792, 8608, 8640, 8672, 1344, 8704, 8736, 8768, 8800,
8832, 1632, 8864, 8896, 4544, 1888, 8928, 8960, 1792, 1344, 8992, 9024,
9056, 1344, 9088, 9120, 9152, 9184, 9216, 1792, 1792, 1792, 1792, 1344,
9248, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 9280, 9312, 9344, 9376, 9376, 9376, 9376, 9376, 9376, 9376,
9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376,
9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376,
9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376,
9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376,
9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408,
9408, 9408, 9408, 9408, 9408, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 9440, 1344, 1344, 9472, 1792, 9504, 9536, 9568,
1344, 1344, 9600, 9632, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 9664, 9696, 1344, 9728, 1344, 9760, 9792, 9824, 9856, 9888,
9920, 1344, 1344, 1344, 9952, 9984, 64, 10016, 10048, 10080, 10112,
10144, 10176
#if TCL_UTF_MAX > 3
,10208, 10240, 10272, 1792, 1344, 1344, 1344, 7968, 10304, 10336, 10368,
10400, 10432, 1792, 10464, 10496, 1792, 1792, 1792, 1792, 4544, 1344,
10528, 1792, 10112, 10560, 10592, 1792, 10624, 1344, 10656, 1792, 10688,
10720, 10752, 1344, 10784, 10816, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 10848, 10880, 10912,
1792, 1792, 1792, 1792, 1792, 10944, 10976, 1792, 1792, 1344, 11008,
1792, 1792, 11040, 11072, 11104, 11136, 1792, 1792, 1792, 1792, 1344,
11168, 11200, 11232, 1792, 1792, 1792, 1792, 1344, 1344, 11264, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 11296, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 11328, 11360, 11392, 11424, 5056, 11456,
11488, 11520, 11552, 11584, 11616, 1792, 5056, 11648, 11680, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1344, 11712, 10816, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 11744, 1792, 1792,
1792, 1792, 10368, 10368, 10368, 11776, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
11744, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 11808, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1344, 1344, 11840, 11872, 11904, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 11936,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 4736, 4736, 4736, 4736, 4736, 4736, 4736, 7680, 4736,
11968, 4736, 12000, 12032, 12064, 12096, 1792, 4736, 4736, 12128, 1792,
1792, 1792, 1792, 1792, 4736, 4736, 12160, 12192, 1792, 1792, 1792,
1792, 12224, 12256, 12288, 12320, 12352, 12384, 12416, 12448, 12480,
12512, 12544, 12576, 12608, 12224, 12256, 12640, 12320, 12672, 12704,
12736, 12448, 12768, 12800, 12832, 12864, 12896, 12928, 12960, 12992,
13024, 13056, 13088, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
13120, 13152, 13184, 13216, 13248, 13280, 1792, 13312, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 4736, 13344, 4736, 4736, 7648,
13376, 13408, 1792, 13440, 13472, 4736, 13344, 13504, 1792, 1792, 13536,
13568, 13504, 13600, 1792, 1792, 1792, 1792, 1792, 4736, 13632, 4736,
13664, 7648, 4736, 13696, 13728, 4736, 8032, 13760, 4736, 4736, 4736,
4736, 13792, 4736, 12096, 13824, 13856, 1792, 1792, 1792, 13888, 4736,
4736, 13920, 1792, 4736, 4736, 13952, 1792, 4736, 4736, 4736, 7648,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 7488, 1792,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4000, 1344, 1344,
1344, 1344, 1344, 1344, 10784, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792,
1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 10784
#endif /* TCL_UTF_MAX > 3 */
};
/*
* The groupMap is indexed by combining the alternate page number with
* the page offset and returns a group number that identifies a unique
* set of character attributes.
*/
static CONST unsigned char groupMap[] = {
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8,
3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 7, 7, 7, 3, 3, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 5, 3, 6, 11, 12, 11, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 5, 7, 6, 7, 1, 2, 3, 4, 4, 4, 4, 14, 3, 11, 14, 15, 16,
7, 17, 14, 11, 14, 7, 18, 18, 11, 19, 3, 3, 11, 18, 15, 20, 18, 18,
18, 3, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 7, 10, 10, 10, 10, 10, 10, 10, 21,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 7, 13, 13, 13, 13, 13, 13, 13, 22, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 25, 26, 23, 24, 23,
24, 23, 24, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 27,
23, 24, 23, 24, 23, 24, 28, 29, 30, 23, 24, 23, 24, 31, 23, 24, 32,
32, 23, 24, 21, 33, 34, 35, 23, 24, 32, 36, 37, 38, 39, 23, 24, 40,
21, 38, 41, 42, 43, 23, 24, 23, 24, 23, 24, 44, 23, 24, 44, 21, 21,
23, 24, 44, 23, 24, 45, 45, 23, 24, 23, 24, 46, 23, 24, 21, 15, 23,
24, 21, 47, 15, 15, 15, 15, 48, 49, 50, 48, 49, 50, 48, 49, 50, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 51, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
21, 48, 49, 50, 23, 24, 52, 53, 23, 24, 23, 24, 23, 24, 23, 24, 54,
21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 21, 21, 21, 21, 21, 21, 55, 23, 24, 56, 57, 58, 58, 23, 24,
59, 60, 61, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 62, 63, 64, 65,
66, 21, 67, 67, 21, 68, 21, 69, 21, 21, 21, 21, 67, 21, 21, 70, 21,
71, 72, 21, 73, 74, 21, 75, 21, 21, 21, 74, 21, 76, 77, 21, 21, 78,
21, 21, 21, 21, 21, 21, 21, 79, 21, 21, 80, 21, 21, 80, 21, 21, 21,
21, 80, 81, 82, 82, 83, 21, 21, 21, 21, 21, 84, 21, 15, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
85, 85, 85, 85, 85, 85, 85, 85, 11, 11, 11, 11, 85, 85, 85, 85, 85,
85, 85, 85, 85, 85, 85, 85, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 11, 11, 85, 85, 85, 85, 85, 11, 11, 11, 11, 11, 11, 11, 85,
11, 85, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 87, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 23, 24, 23,
24, 85, 11, 23, 24, 0, 0, 85, 42, 42, 42, 3, 0, 0, 0, 0, 0, 11, 11,
88, 3, 89, 89, 89, 0, 90, 0, 91, 91, 21, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 0, 10, 10, 10, 10, 10, 10,
10, 10, 10, 92, 93, 93, 93, 21, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 94, 13, 13, 13, 13, 13, 13, 13, 13,
13, 95, 96, 96, 97, 98, 99, 100, 100, 100, 101, 102, 103, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 104, 105, 106, 21, 107, 108, 7, 23, 24, 109, 23, 24,
21, 54, 54, 54, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
110, 110, 110, 110, 110, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
105, 105, 105, 105, 23, 24, 14, 86, 86, 86, 86, 86, 111, 111, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 112, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 113, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 114,
114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114,
114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114,
114, 114, 114, 114, 114, 114, 114, 114, 114, 0, 0, 85, 3, 3, 3, 3,
3, 3, 0, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115,
115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115,
115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 21, 0,
3, 8, 0, 0, 0, 0, 4, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
8, 86, 3, 86, 86, 3, 86, 86, 3, 86, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, 3, 3, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 0, 7, 7, 7, 3, 3,
4, 3, 3, 14, 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 0,
0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 15, 86, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 15, 86, 86, 86,
86, 86, 86, 86, 17, 14, 86, 86, 86, 86, 86, 86, 85, 85, 86, 86, 14,
86, 86, 86, 86, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 14,
14, 15, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 17, 15, 86, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, 86, 86,
86, 85, 85, 14, 3, 3, 3, 85, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86,
86, 86, 86, 85, 86, 86, 86, 86, 86, 86, 86, 86, 86, 85, 86, 86, 86,
85, 86, 86, 86, 86, 86, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 0, 0, 3, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 86, 86, 86, 116,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 86, 116, 86, 15, 116, 116, 116, 86, 86, 86, 86, 86, 86,
86, 86, 116, 116, 116, 116, 86, 116, 116, 15, 86, 86, 86, 86, 86, 86,
86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 3, 3, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 3, 85, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15,
15, 15, 15, 15, 0, 86, 116, 116, 0, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 0, 15, 0, 0, 0, 15, 15, 15, 15, 0, 0, 86, 15, 116, 116, 116, 86,
86, 86, 86, 0, 0, 116, 116, 0, 0, 116, 116, 86, 15, 0, 0, 0, 0, 0,
0, 0, 0, 116, 0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 86, 86, 0, 0, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 4, 4, 18, 18, 18, 18, 18, 18, 14, 4,
0, 0, 0, 0, 0, 86, 86, 116, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0,
15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15,
15, 0, 15, 15, 0, 15, 15, 0, 0, 86, 0, 116, 116, 116, 86, 86, 0, 0,
0, 0, 86, 86, 0, 0, 86, 86, 86, 0, 0, 0, 86, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 0, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 86, 86, 15, 15, 15, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86,
116, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15,
15, 15, 0, 0, 86, 15, 116, 116, 116, 86, 86, 86, 86, 86, 0, 86, 86,
116, 0, 116, 116, 86, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 15, 15, 86, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 4,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15,
15, 0, 0, 86, 15, 116, 86, 116, 86, 86, 86, 86, 0, 0, 116, 116, 0,
0, 116, 116, 86, 0, 0, 0, 0, 0, 0, 0, 0, 86, 116, 0, 0, 0, 0, 15, 15,
0, 15, 15, 15, 86, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, 15,
18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 15, 0, 15,
15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 0,
15, 15, 0, 15, 0, 15, 15, 0, 0, 0, 15, 15, 0, 0, 0, 15, 15, 15, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116,
116, 86, 116, 116, 0, 0, 0, 116, 116, 116, 0, 116, 116, 116, 86, 0,
0, 15, 0, 0, 0, 0, 0, 0, 116, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 14, 14, 14, 14, 14, 14,
4, 14, 0, 0, 0, 0, 0, 0, 116, 116, 116, 0, 15, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 0, 15, 86, 86,
86, 116, 116, 116, 116, 0, 86, 86, 86, 0, 86, 86, 86, 86, 0, 0, 0,
0, 0, 0, 0, 86, 86, 0, 15, 15, 0, 0, 0, 0, 0, 0, 15, 15, 86, 86, 0,
0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18,
18, 18, 18, 18, 14, 0, 0, 116, 116, 0, 15, 15, 15, 15, 15, 15, 15,
15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 86, 15, 116, 86, 116,
116, 116, 116, 116, 0, 86, 116, 116, 0, 116, 116, 86, 86, 0, 0, 0,
0, 0, 0, 0, 116, 116, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 15, 86, 86, 0,
0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 116,
116, 116, 86, 86, 86, 86, 0, 116, 116, 116, 0, 116, 116, 116, 86, 15,
0, 0, 0, 0, 0, 0, 0, 0, 116, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 86, 86,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 0, 0, 0,
14, 15, 15, 15, 15, 15, 15, 0, 0, 116, 116, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0,
0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 0, 0, 0, 0, 116, 116, 116,
86, 86, 86, 0, 86, 0, 116, 116, 116, 116, 116, 116, 116, 116, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 116, 116, 3, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 86, 15, 15, 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0,
4, 15, 15, 15, 15, 15, 15, 85, 86, 86, 86, 86, 86, 86, 86, 86, 3, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 15, 15, 0, 15, 0, 0,
15, 15, 0, 15, 0, 0, 15, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 0, 15, 0, 0, 15, 15, 0, 15,
15, 15, 15, 86, 15, 15, 86, 86, 86, 86, 86, 86, 0, 86, 86, 15, 0, 0,
15, 15, 15, 15, 15, 0, 85, 0, 86, 86, 86, 86, 86, 86, 0, 0, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 0, 0, 15, 15, 15, 15, 15, 14, 14, 14, 3, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 14, 3, 14, 14, 14, 86, 86, 14,
14, 14, 14, 14, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 14, 86, 14, 86, 14, 86, 5, 6, 5, 6, 116, 116, 15,
15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 3,
86, 86, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 86, 86, 0, 14, 14, 14, 14, 14, 14, 14, 14, 86, 14, 14, 14,
14, 14, 14, 0, 14, 14, 3, 3, 3, 3, 3, 14, 14, 14, 14, 3, 3, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, 116, 86, 86,
86, 86, 116, 86, 86, 86, 86, 86, 86, 116, 86, 86, 116, 116, 86, 86,
15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15,
15, 15, 116, 116, 86, 86, 15, 15, 15, 15, 86, 86, 86, 15, 116, 116,
116, 15, 15, 116, 116, 116, 116, 116, 116, 116, 15, 15, 15, 86, 86,
86, 86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 116,
116, 86, 86, 116, 116, 116, 116, 116, 116, 86, 15, 116, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 116, 116, 116, 86, 14, 14, 117, 117, 117, 117, 117,
117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117,
117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117,
117, 117, 117, 117, 117, 0, 117, 0, 0, 0, 0, 0, 117, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 3, 85, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15,
0, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15,
15, 0, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 0, 86, 86, 86, 3, 3, 3, 3, 3, 3, 3, 3, 3,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 2, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 5, 6, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3,
3, 118, 118, 118, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 3, 3, 0,
0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15,
0, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86,
116, 86, 86, 86, 86, 86, 86, 86, 116, 116, 116, 116, 116, 116, 116,
116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3,
3, 85, 3, 3, 3, 4, 15, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0,
0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 86, 86, 86, 2, 0, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 85, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 0, 0, 0, 0, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 86, 86, 116, 116, 116, 116, 86,
86, 116, 116, 116, 0, 0, 0, 0, 116, 116, 86, 116, 116, 116, 116, 116,
116, 86, 86, 86, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15,
15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, 116, 116, 116, 116, 116,
116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 15, 15, 15,
15, 15, 15, 15, 116, 116, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 116, 116, 116,
0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 116, 86, 116, 86, 86, 86, 86, 86, 86, 86,
0, 86, 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116,
116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 86,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 85, 3, 3, 3, 3, 3,
3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86,
86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 116,
86, 86, 86, 86, 86, 116, 86, 116, 116, 116, 116, 116, 86, 116, 116,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86,
86, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 116, 86, 86, 86, 86, 116, 116, 86, 86, 116, 86, 116, 116, 15, 15,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 86, 116, 86, 86, 116, 116, 116, 86, 116, 86, 86, 86, 116, 116,
0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 116, 116, 116,
116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116,
86, 86, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 85, 85, 85, 85, 85, 85, 3, 3, 3, 3, 3,
3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 3, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 86, 86,
15, 15, 15, 15, 86, 15, 15, 15, 15, 116, 116, 86, 15, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85,
85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
85, 85, 85, 85, 85, 85, 85, 85, 85, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 85, 119, 21, 21, 21, 120, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 86, 86, 86, 86, 86, 86,
86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
86, 86, 86, 86, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 121, 21, 21,
122, 21, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, 124, 124,
124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 0, 0, 124, 124, 124,
124, 124, 124, 0, 0, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124,
124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 123, 123,
124, 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123,
0, 0, 124, 124, 124, 124, 124, 124, 0, 0, 21, 123, 21, 123, 21, 123,
21, 123, 0, 124, 0, 124, 0, 124, 0, 124, 123, 123, 123, 123, 123, 123,
123, 123, 124, 124, 124, 124, 124, 124, 124, 124, 125, 125, 126, 126,
126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 0, 0, 123, 123, 123,
123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, 131, 123,
123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131,
131, 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131,
131, 131, 131, 123, 123, 21, 132, 21, 0, 21, 21, 124, 124, 133, 133,
134, 11, 135, 11, 11, 11, 21, 132, 21, 0, 21, 21, 136, 136, 136, 136,
134, 11, 11, 11, 123, 123, 21, 21, 0, 0, 21, 21, 124, 124, 137, 137,
0, 11, 11, 11, 123, 123, 21, 21, 21, 106, 21, 21, 124, 124, 138, 138,
109, 11, 11, 11, 0, 0, 21, 132, 21, 0, 21, 21, 139, 139, 140, 140,
134, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, 17,
8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, 3, 3,
3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3,
16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17,
17, 17, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, 18, 18,
18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100, 100,
21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100, 100,
100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145, 100,
100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14, 21,
21, 100, 100, 7, 7, 7, 7, 7, 100, 21, 21, 21, 21, 14, 7, 14, 14, 147,
14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148,
148, 148, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149,
149, 149, 149, 149, 118, 118, 118, 23, 24, 118, 118, 118, 118, 18,
0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14,
14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7,
14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14,
14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14,
14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 150, 150, 150, 150, 150, 150, 150, 150,
150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150,
150, 150, 150, 150, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151,
151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151,
151, 151, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14,
14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 7, 7, 7, 7, 7, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6,
5, 6, 5, 6, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5,
6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 5, 6, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 14, 14, 7, 7, 7, 7, 7, 7, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 0, 0, 0, 0, 0, 0, 114, 114, 114, 114, 114, 114, 114, 114,
114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114,
114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114,
114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 0, 115, 115,
115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115,
115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115,
115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115,
115, 115, 115, 0, 23, 24, 152, 153, 154, 155, 156, 23, 24, 23, 24,
23, 24, 157, 158, 159, 160, 21, 23, 24, 21, 23, 24, 21, 21, 21, 21,
21, 85, 85, 161, 161, 23, 24, 23, 24, 21, 14, 14, 14, 14, 14, 14, 23,
24, 23, 24, 86, 86, 86, 23, 24, 0, 0, 0, 0, 0, 3, 3, 3, 3, 18, 3, 3,
162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162,
162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162,
162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 0, 162, 0, 0, 0,
0, 0, 162, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 85,
3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 0, 3, 3, 16, 20, 16, 20, 3, 3, 3, 16, 20, 3, 16, 20, 3,
3, 3, 3, 3, 3, 3, 3, 3, 8, 3, 3, 8, 3, 16, 20, 3, 3, 16, 20, 5, 6,
5, 6, 5, 6, 5, 6, 3, 3, 3, 3, 3, 85, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
8, 8, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
0, 0, 0, 2, 3, 3, 3, 14, 85, 15, 118, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6,
14, 14, 5, 6, 5, 6, 5, 6, 5, 6, 8, 5, 6, 6, 14, 118, 118, 118, 118,
118, 118, 118, 118, 118, 86, 86, 86, 86, 116, 116, 8, 85, 85, 85, 85,
85, 14, 14, 118, 118, 118, 85, 15, 3, 14, 14, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 86, 86, 11, 11, 85, 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 3, 85, 85, 85, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 14, 14,
18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 14, 14, 14, 14, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18,
18, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 3, 3, 3, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 15, 86, 111, 111, 111, 3, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
3, 85, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 86, 15, 15,
15, 15, 15, 15, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 86,
86, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 11, 11, 11, 11, 11, 11,
11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
85, 85, 85, 85, 85, 85, 85, 85, 85, 11, 11, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 85, 21, 21, 21, 21, 21, 21, 21, 21, 23, 24,
23, 24, 163, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 85, 11, 11, 23,
24, 164, 21, 0, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 165, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 85, 85, 21, 15, 15, 15, 15,
15, 15, 15, 86, 15, 15, 15, 86, 15, 15, 15, 15, 86, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 116, 116, 86, 86, 116, 14, 14, 14, 14, 0, 0, 0, 0, 18, 18,
18, 18, 18, 18, 14, 14, 4, 14, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 3,
3, 0, 0, 0, 0, 0, 0, 0, 0, 116, 116, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 116, 116, 116, 116, 116, 116, 116,
116, 116, 116, 116, 116, 116, 116, 116, 116, 86, 0, 0, 0, 0, 0, 0,
0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
15, 15, 15, 15, 15, 15, 3, 3, 3, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 86, 116, 116, 86, 86, 86, 86, 116, 116, 86,
116, 116, 116, 116, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 85, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15,
15, 15, 15, 86, 86, 86, 86, 86, 86, 116, 116, 86, 86, 116, 116, 86,
86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 86, 15, 15, 15, 15, 15,
15, 15, 15, 86, 116, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 3, 3,
3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
85, 15, 15, 15, 15, 15, 15, 14, 14, 14, 15, 116, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 86,
86, 86, 15, 15, 86, 86, 15, 15, 15, 15, 15, 86, 86, 15, 86, 15, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15, 15, 85, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 116,
86, 86, 116, 116, 3, 3, 15, 85, 85, 116, 86, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15,
15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 116, 116, 86, 116, 116, 86, 116, 116,
3, 116, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 0, 0, 0, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166,
166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166,
166, 166, 166, 166, 166, 166, 166, 166, 167, 167, 167, 167, 167, 167,
167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167,
167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 15,
86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 7, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 15, 0, 15,
15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 11, 11, 11,
11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 4, 14, 0, 0, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3, 3, 3, 3, 3, 3, 5,
6, 3, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0,
0, 0, 0, 0, 3, 8, 8, 12, 12, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5,
6, 5, 6, 3, 3, 5, 6, 3, 3, 3, 3, 12, 12, 12, 3, 3, 3, 0, 3, 3, 3, 3,
8, 5, 6, 5, 6, 5, 6, 3, 3, 3, 7, 8, 7, 7, 7, 0, 3, 4, 3, 3, 0, 0, 0,
0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 17, 0, 3, 3, 3, 4,
3, 3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3,
7, 7, 7, 3, 11, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 5, 7, 6, 7, 5,
6, 3, 5, 6, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 85, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0,
0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15,
15, 15, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, 14, 7, 7, 7, 7, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 14, 14, 0, 0
#if TCL_UTF_MAX > 3
,15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118,
118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118,
118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118,
118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 18,
18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 18, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 118, 15, 15, 15, 15, 15, 15, 15, 15, 118, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 3, 15, 15, 15, 15, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 3, 118, 118, 118, 118, 118, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 168, 168, 168, 168, 168, 168, 168, 168, 168,
168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168,
168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168,
168, 168, 168, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169,
169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169,
169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169,
169, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 0, 0, 15, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 0, 3, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
18, 18, 18, 18, 18, 18, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 15,
15, 15, 86, 86, 86, 0, 86, 86, 0, 0, 0, 0, 0, 86, 86, 86, 86, 15, 15,
15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 0, 0, 86, 86, 86, 0, 0, 0, 0, 86, 18, 18, 18, 18, 18, 18, 18, 18,
0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 18, 18, 3, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 18, 18,
18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 116, 86, 116, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3,
3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, 116, 116, 86,
86, 86, 86, 116, 116, 86, 86, 3, 3, 17, 3, 3, 3, 3, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 86, 86,
86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 86, 86, 86,
0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, 15, 15,
15, 15, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86,
116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 116, 86, 0, 0, 0, 0, 0,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 118, 118, 118, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0,
15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 116, 116,
116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116,
116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116,
116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116,
116, 116, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86,
86, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 15, 15, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 116, 116, 86, 86, 86, 14, 14, 14, 116,
116, 116, 116, 116, 116, 17, 17, 17, 17, 17, 17, 17, 17, 86, 86, 86,
86, 86, 86, 86, 86, 14, 14, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86, 86, 86, 86, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 86, 86, 86,
14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21,
21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100, 0,
100, 100, 0, 0, 100, 0, 0, 100, 100, 0, 0, 100, 100, 100, 100, 0, 100,
100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 0, 21, 0, 21, 21,
21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 100, 100, 0, 100, 100, 100, 100, 0, 0,
100, 100, 100, 100, 100, 100, 100, 100, 0, 100, 100, 100, 100, 100,
100, 100, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100, 100, 0, 100, 100,
100, 100, 0, 100, 100, 100, 100, 100, 0, 100, 0, 0, 0, 100, 100, 100,
100, 100, 100, 100, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 21, 21, 0, 0, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 7, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7,
21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21,
21, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 7, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
100, 100, 100, 100, 100, 100, 100, 100, 7, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 7, 21, 21, 21, 21, 21, 21, 100, 21, 0, 0, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15,
15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15,
0, 15, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15,
15, 15, 15, 0, 15, 0, 15, 0, 0, 0, 0, 0, 0, 15, 0, 0, 0, 0, 15, 0,
15, 0, 15, 0, 15, 15, 15, 0, 15, 15, 0, 15, 0, 0, 15, 0, 15, 0, 15,
0, 15, 0, 15, 0, 15, 15, 0, 15, 0, 0, 15, 15, 15, 15, 0, 15, 15, 15,
15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15,
0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0,
0, 0, 0, 0, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 0,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 0, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14,
14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14,
14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0
#endif /* TCL_UTF_MAX > 3 */
};
/*
* Each group represents a unique set of character attributes. The attributes
* are encoded into a 32-bit value as follows:
*
* Bits 0-4 Character category: see the constants listed below.
*
* Bits 5-7 Case delta type: 000 = identity
* 010 = add delta for lower
* 011 = add delta for lower, add 1 for title
* 100 = subtract delta for title/upper
* 101 = sub delta for upper, sub 1 for title
* 110 = sub delta for upper, add delta for lower
*
* Bits 8-31 Case delta: delta for case conversions. This should be the
* highest field so we can easily sign extend.
*/
static CONST int groups[] = {
0, 15, 12, 25, 27, 21, 22, 26, 20, 9, 8257, 28, 19, 8322, 29,
5, 23, 16, 11, -190078, 24, 2, -30846, 321, 386, -50879, 59522,
-30911, 76930, -49790, 53825, 52801, 52545, 20289, 51777, 52033,
53057, -24702, 54081, 53569, -41598, 54593, -33150, 54849, 55873,
55617, 56129, -14206, 609, 451, 674, 20354, -24767, -14271, -33215,
2763585, -41663, 2762817, -2768510, -49855, 17729, 18241, -2760318,
-2759550, -2760062, 53890, 52866, 52610, 51842, 52098, 53122,
-10823550, -10830718, 53634, 54146, -2750078, -2751614, 54658,
54914, -2745982, 55938, 17794, 55682, 18306, 56194, 4, 6, -21370,
9793, 9537, 16449, 16193, 9858, 9602, 8066, 16514, 16258, 2113,
16002, 14722, 1, 12162, 13954, 2178, 22146, 20610, -1662, -15295,
24706, -1727, 20545, 7, 3905, 3970, 12353, 12418, 8, 1859649,
10, -9044862, -976254, 15234, -1949375, -1918, -1983, -18814,
-21886, -25470, -32638, -28542, -32126, -1981, -2174, -18879,
-2237, 1844610, -21951, -25535, -28607, -32703, -32191, 13, 14,
-1924287, -2145983, -2115007, 7233, 7298, 4170, 4234, 6749, 6813,
-2750143, -976319, -2746047, 2763650, 2762882, -2759615, -2751679,
-2760383, -2760127, -2768575, 1859714, -9044927, -10823615, -10830783,
18, 17, 10305, 10370
};
#if TCL_UTF_MAX > 3
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1fffff) >= 0x2fa20)
#else
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1f0000) != 0)
#endif
/*
* The following constants are used to determine the category of a
* Unicode character.
*/
enum {
UNASSIGNED,
UPPERCASE_LETTER,
LOWERCASE_LETTER,
TITLECASE_LETTER,
MODIFIER_LETTER,
OTHER_LETTER,
NON_SPACING_MARK,
ENCLOSING_MARK,
COMBINING_SPACING_MARK,
DECIMAL_DIGIT_NUMBER,
LETTER_NUMBER,
OTHER_NUMBER,
SPACE_SEPARATOR,
LINE_SEPARATOR,
PARAGRAPH_SEPARATOR,
CONTROL,
FORMAT,
PRIVATE_USE,
SURROGATE,
CONNECTOR_PUNCTUATION,
DASH_PUNCTUATION,
OPEN_PUNCTUATION,
CLOSE_PUNCTUATION,
INITIAL_QUOTE_PUNCTUATION,
FINAL_QUOTE_PUNCTUATION,
OTHER_PUNCTUATION,
MATH_SYMBOL,
CURRENCY_SYMBOL,
MODIFIER_SYMBOL,
OTHER_SYMBOL
};
/*
* The following macros extract the fields of the character info. The
* GetDelta() macro is complicated because we can't rely on the C compiler
* to do sign extension on right shifts.
*/
#define GetCaseType(info) (((info) & 0xe0) >> 5)
#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1f)
#define GetDelta(info) ((info) >> 8)
/*
* This macro extracts the information about a character from the
* Unicode character tables.
*/
#define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xffff) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]])
tcl8.4.20/generic/tclInitScript.h 0000644 0036047 0045461 00000006213 11737050674 015301 0 ustar dgp 771div /*
* tclInitScript.h --
*
* This file contains Unix & Windows common init script
* It is not used on the Mac. (the mac init script is in tclMacInit.c)
*
* Copyright (c) 1998 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
* All rights reserved.
*/
/*
* In order to find init.tcl during initialization, the following script
* is invoked by Tcl_Init(). It looks in several different directories:
*
* $tcl_library - can specify a primary location, if set
* no other locations will be checked
*
* $env(TCL_LIBRARY) - highest priority so user can always override
* the search path unless the application has
* specified an exact directory above
*
* $tclDefaultLibrary - this value is initialized by TclPlatformInit
* from a static C variable that was set at
* compile time
*
* $tcl_libPath - this value is initialized by a call to
* TclGetLibraryPath called from Tcl_Init.
*
* The first directory on this path that contains a valid init.tcl script
* will be set as the value of tcl_library.
*
* Note that this entire search mechanism can be bypassed by defining an
* alternate tclInit procedure before calling Tcl_Init().
*/
static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
proc tclInit {} {\n\
global tcl_libPath tcl_library errorInfo\n\
global env tclDefaultLibrary\n\
rename tclInit {}\n\
set errors {}\n\
set dirs {}\n\
if {[info exists tcl_library]} {\n\
lappend dirs $tcl_library\n\
} else {\n\
if {[info exists env(TCL_LIBRARY)]} {\n\
lappend dirs $env(TCL_LIBRARY)\n\
}\n\
catch {\n\
lappend dirs $tclDefaultLibrary\n\
unset tclDefaultLibrary\n\
}\n\
set dirs [concat $dirs $tcl_libPath]\n\
}\n\
foreach i $dirs {\n\
set tcl_library $i\n\
set tclfile [file join $i init.tcl]\n\
if {[file exists $tclfile]} {\n\
if {![catch {uplevel #0 [list source $tclfile]} msg]} {\n\
return\n\
} else {\n\
append errors \"$tclfile: $msg\n$errorInfo\n\"\n\
}\n\
}\n\
}\n\
set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
append msg \" $dirs\n\n\"\n\
append msg \"$errors\n\n\"\n\
append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
error $msg\n\
}\n\
}\n\
tclInit";
/*
* A pointer to a string that holds an initialization script that if non-NULL
* is evaluated in Tcl_Init() prior to the the built-in initialization script
* above. This variable can be modified by the procedure below.
*/
static char * tclPreInitScript = NULL;
/*
*----------------------------------------------------------------------
*
* TclSetPreInitScript --
*
* This routine is used to change the value of the internal
* variable, tclPreInitScript.
*
* Results:
* Returns the current value of tclPreInitScript.
*
* Side effects:
* Changes the way Tcl_Init() routine behaves.
*
*----------------------------------------------------------------------
*/
char *
TclSetPreInitScript (string)
char *string; /* Pointer to a script. */
{
char *prevString = tclPreInitScript;
tclPreInitScript = string;
return(prevString);
}
tcl8.4.20/generic/tclInterp.c 0000644 0036047 0045461 00000215025 11737050674 014450 0 ustar dgp 771div /*
* tclInterp.c --
*
* This file implements the "interp" command which allows creation
* and manipulation of Tcl interpreters from within Tcl scripts.
*
* Copyright (c) 1995-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.
*/
#include "tclInt.h"
#include "tclPort.h"
#include
/*
* Counter for how many aliases were created (global)
*/
static int aliasCounter = 0;
TCL_DECLARE_MUTEX(cntMutex)
/*
* struct Alias:
*
* Stores information about an alias. Is stored in the slave interpreter
* and used by the source command to find the target command in the master
* when the source command is invoked.
*/
typedef struct Alias {
Tcl_Obj *namePtr; /* Name of alias command in slave interp. */
Tcl_Interp *targetInterp; /* Interp in which target command will be
* invoked. */
Tcl_Command slaveCmd; /* Source command in slave interpreter,
* bound to command that invokes the target
* command in the target interpreter. */
Tcl_HashEntry *aliasEntryPtr;
/* Entry for the alias hash table in slave.
* This is used by alias deletion to remove
* the alias from the slave interpreter
* alias table. */
Tcl_HashEntry *targetEntryPtr;
/* Entry for target command in master.
* This is used in the master interpreter to
* map back from the target command to aliases
* redirecting to it. Random access to this
* hash table is never required - we are using
* a hash table only for convenience. */
int objc; /* Count of Tcl_Obj in the prefix of the
* target command to be invoked in the
* target interpreter. Additional arguments
* specified when calling the alias in the
* slave interp will be appended to the prefix
* before the command is invoked. */
Tcl_Obj *objPtr; /* The first actual prefix object - the target
* command name; this has to be at the end of the
* structure, which will be extended to accomodate
* the remaining objects in the prefix. */
} Alias;
/*
*
* struct Slave:
*
* Used by the "interp" command to record and find information about slave
* interpreters. Maps from a command name in the master to information about
* a slave interpreter, e.g. what aliases are defined in it.
*/
typedef struct Slave {
Tcl_Interp *masterInterp; /* Master interpreter for this slave. */
Tcl_HashEntry *slaveEntryPtr;
/* Hash entry in masters slave table for
* this slave interpreter. Used to find
* this record, and used when deleting the
* slave interpreter to delete it from the
* master's table. */
Tcl_Interp *slaveInterp; /* The slave interpreter. */
Tcl_Command interpCmd; /* Interpreter object command. */
Tcl_HashTable aliasTable; /* Table which maps from names of commands
* in slave interpreter to struct Alias
* defined below. */
} Slave;
/*
* struct Target:
*
* Maps from master interpreter commands back to the source commands in slave
* interpreters. This is needed because aliases can be created between sibling
* interpreters and must be deleted when the target interpreter is deleted. In
* case they would not be deleted the source interpreter would be left with a
* "dangling pointer". One such record is stored in the Master record of the
* master interpreter (in the targetTable hashtable, see below) with the
* master for each alias which directs to a command in the master. These
* records are used to remove the source command for an from a slave if/when
* the master is deleted.
*/
typedef struct Target {
Tcl_Command slaveCmd; /* Command for alias in slave interp. */
Tcl_Interp *slaveInterp; /* Slave Interpreter. */
} Target;
/*
* struct Master:
*
* This record is used for two purposes: First, slaveTable (a hashtable)
* maps from names of commands to slave interpreters. This hashtable is
* used to store information about slave interpreters of this interpreter,
* to map over all slaves, etc. The second purpose is to store information
* about all aliases in slaves (or siblings) which direct to target commands
* in this interpreter (using the targetTable hashtable).
*
* NB: the flags field in the interp structure, used with SAFE_INTERP
* mask denotes whether the interpreter is safe or not. Safe
* interpreters have restricted functionality, can only create safe slave
* interpreters and can only load safe extensions.
*/
typedef struct Master {
Tcl_HashTable slaveTable; /* Hash table for slave interpreters.
* Maps from command names to Slave records. */
Tcl_HashTable targetTable; /* Hash table for Target Records. Contains
* all Target records which denote aliases
* from slaves or sibling interpreters that
* direct to commands in this interpreter. This
* table is used to remove dangling pointers
* from the slave (or sibling) interpreters
* when this interpreter is deleted. */
} Master;
/*
* The following structure keeps track of all the Master and Slave information
* on a per-interp basis.
*/
typedef struct InterpInfo {
Master master; /* Keeps track of all interps for which this
* interp is the Master. */
Slave slave; /* Information necessary for this interp to
* function as a slave. */
} InterpInfo;
/*
* Prototypes for local static procedures:
*/
static int AliasCreate _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp,
Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc,
Tcl_Obj *CONST objv[]));
static int AliasDelete _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *slaveInterp, Tcl_Obj *namePtr));
static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *slaveInterp, Tcl_Obj *objPtr));
static int AliasList _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *slaveInterp));
static int AliasObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *currentInterp, int objc,
Tcl_Obj *CONST objv[]));
static void AliasObjCmdDeleteProc _ANSI_ARGS_((
ClientData clientData));
static Tcl_Interp * GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr));
static Tcl_Interp * GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static void InterpInfoDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, int safe));
static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *slaveInterp, int objc,
Tcl_Obj *CONST objv[]));
static int SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *slaveInterp, int objc,
Tcl_Obj *CONST objv[]));
static int SlaveHide _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *slaveInterp, int objc,
Tcl_Obj *CONST objv[]));
static int SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *slaveInterp));
static int SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *slaveInterp, int global, int objc,
Tcl_Obj *CONST objv[]));
static int SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *slaveInterp));
static int SlaveObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static void SlaveObjCmdDeleteProc _ANSI_ARGS_((
ClientData clientData));
static int SlaveRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *slaveInterp, int objc,
Tcl_Obj *CONST objv[]));
/*
*---------------------------------------------------------------------------
*
* TclInterpInit --
*
* Initializes the invoking interpreter for using the master, slave
* and safe interp facilities. This is called from inside
* Tcl_CreateInterp().
*
* Results:
* Always returns TCL_OK for backwards compatibility.
*
* Side effects:
* Adds the "interp" command to an interpreter and initializes the
* interpInfoPtr field of the invoking interpreter.
*
*---------------------------------------------------------------------------
*/
int
TclInterpInit(interp)
Tcl_Interp *interp; /* Interpreter to initialize. */
{
InterpInfo *interpInfoPtr;
Master *masterPtr;
Slave *slavePtr;
interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo));
((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr;
masterPtr = &interpInfoPtr->master;
Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
Tcl_InitHashTable(&masterPtr->targetTable, TCL_ONE_WORD_KEYS);
slavePtr = &interpInfoPtr->slave;
slavePtr->masterInterp = NULL;
slavePtr->slaveEntryPtr = NULL;
slavePtr->slaveInterp = interp;
slavePtr->interpCmd = NULL;
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL);
Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* InterpInfoDeleteProc --
*
* Invoked when an interpreter is being deleted. It releases all
* storage used by the master/slave/safe interpreter facilities.
*
* Results:
* None.
*
* Side effects:
* Cleans up storage. Sets the interpInfoPtr field of the interp
* to NULL.
*
*---------------------------------------------------------------------------
*/
static void
InterpInfoDeleteProc(clientData, interp)
ClientData clientData; /* Ignored. */
Tcl_Interp *interp; /* Interp being deleted. All commands for
* slave interps should already be deleted. */
{
InterpInfo *interpInfoPtr;
Slave *slavePtr;
Master *masterPtr;
Tcl_HashSearch hSearch;
Tcl_HashEntry *hPtr;
Target *targetPtr;
interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
/*
* There shouldn't be any commands left.
*/
masterPtr = &interpInfoPtr->master;
if (masterPtr->slaveTable.numEntries != 0) {
panic("InterpInfoDeleteProc: still exist commands");
}
Tcl_DeleteHashTable(&masterPtr->slaveTable);
/*
* Tell any interps that have aliases to this interp that they should
* delete those aliases. If the other interp was already dead, it
* would have removed the target record already.
*/
hPtr = Tcl_FirstHashEntry(&masterPtr->targetTable, &hSearch);
while (hPtr != NULL) {
targetPtr = (Target *) Tcl_GetHashValue(hPtr);
Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
targetPtr->slaveCmd);
hPtr = Tcl_NextHashEntry(&hSearch);
}
Tcl_DeleteHashTable(&masterPtr->targetTable);
slavePtr = &interpInfoPtr->slave;
if (slavePtr->interpCmd != NULL) {
/*
* Tcl_DeleteInterp() was called on this interpreter, rather
* "interp delete" or the equivalent deletion of the command in the
* master. First ensure that the cleanup callback doesn't try to
* delete the interp again.
*/
slavePtr->slaveInterp = NULL;
Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
slavePtr->interpCmd);
}
/*
* There shouldn't be any aliases left.
*/
if (slavePtr->aliasTable.numEntries != 0) {
panic("InterpInfoDeleteProc: still exist aliases");
}
Tcl_DeleteHashTable(&slavePtr->aliasTable);
ckfree((char *) interpInfoPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InterpObjCmd --
*
* This procedure is invoked to process the "interp" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_InterpObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Unused. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int index;
static CONST char *options[] = {
"alias", "aliases", "create", "delete",
"eval", "exists", "expose", "hide",
"hidden", "issafe", "invokehidden", "marktrusted",
"recursionlimit", "slaves", "share",
"target", "transfer",
NULL
};
enum option {
OPT_ALIAS, OPT_ALIASES, OPT_CREATE, OPT_DELETE,
OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_MARKTRUSTED,
OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE,
OPT_TARGET, OPT_TRANSFER
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum option) index) {
case OPT_ALIAS: {
Tcl_Interp *slaveInterp, *masterInterp;
if (objc < 4) {
aliasArgs:
Tcl_WrongNumArgs(interp, 2, objv,
"slavePath slaveCmd ?masterPath masterCmd? ?args ..?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
if (slaveInterp == (Tcl_Interp *) NULL) {
return TCL_ERROR;
}
if (objc == 4) {
return AliasDescribe(interp, slaveInterp, objv[3]);
}
if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) {
return AliasDelete(interp, slaveInterp, objv[3]);
}
if (objc > 5) {
masterInterp = GetInterp(interp, objv[4]);
if (masterInterp == (Tcl_Interp *) NULL) {
return TCL_ERROR;
}
if (Tcl_GetString(objv[5])[0] == '\0') {
if (objc == 6) {
return AliasDelete(interp, slaveInterp, objv[3]);
}
} else {
return AliasCreate(interp, slaveInterp, masterInterp,
objv[3], objv[5], objc - 6, objv + 6);
}
}
goto aliasArgs;
}
case OPT_ALIASES: {
Tcl_Interp *slaveInterp;
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
return AliasList(interp, slaveInterp);
}
case OPT_CREATE: {
int i, last, safe;
Tcl_Obj *slavePtr;
char buf[16 + TCL_INTEGER_SPACE];
static CONST char *options[] = {
"-safe", "--", NULL
};
enum option {
OPT_SAFE, OPT_LAST
};
safe = Tcl_IsSafe(interp);
/*
* Weird historical rules: "-safe" is accepted at the end, too.
*/
slavePtr = NULL;
last = 0;
for (i = 2; i < objc; i++) {
if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index == OPT_SAFE) {
safe = 1;
continue;
}
i++;
last = 1;
}
if (slavePtr != NULL) {
Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
return TCL_ERROR;
}
if (i < objc) {
slavePtr = objv[i];
}
}
buf[0] = '\0';
if (slavePtr == NULL) {
/*
* Create an anonymous interpreter -- we choose its name and
* the name of the command. We check that the command name
* that we use for the interpreter does not collide with an
* existing command in the master interpreter.
*/
for (i = 0; ; i++) {
Tcl_CmdInfo cmdInfo;
sprintf(buf, "interp%d", i);
if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
break;
}
}
slavePtr = Tcl_NewStringObj(buf, -1);
}
if (SlaveCreate(interp, slavePtr, safe) == NULL) {
if (buf[0] != '\0') {
Tcl_DecrRefCount(slavePtr);
}
return TCL_ERROR;
}
Tcl_SetObjResult(interp, slavePtr);
return TCL_OK;
}
case OPT_DELETE: {
int i;
InterpInfo *iiPtr;
Tcl_Interp *slaveInterp;
for (i = 2; i < objc; i++) {
slaveInterp = GetInterp(interp, objv[i]);
if (slaveInterp == NULL) {
return TCL_ERROR;
} else if (slaveInterp == interp) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot delete the current interpreter",
(char *) NULL);
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp,
iiPtr->slave.interpCmd);
}
return TCL_OK;
}
case OPT_EVAL: {
Tcl_Interp *slaveInterp;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
}
case OPT_EXISTS: {
int exists;
Tcl_Interp *slaveInterp;
exists = 1;
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
if (objc > 3) {
return TCL_ERROR;
}
Tcl_ResetResult(interp);
exists = 0;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), exists);
return TCL_OK;
}
case OPT_EXPOSE: {
Tcl_Interp *slaveInterp;
if ((objc < 4) || (objc > 5)) {
Tcl_WrongNumArgs(interp, 2, objv,
"path hiddenCmdName ?cmdName?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
}
case OPT_HIDE: {
Tcl_Interp *slaveInterp; /* A slave. */
if ((objc < 4) || (objc > 5)) {
Tcl_WrongNumArgs(interp, 2, objv,
"path cmdName ?hiddenCmdName?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
if (slaveInterp == (Tcl_Interp *) NULL) {
return TCL_ERROR;
}
return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
}
case OPT_HIDDEN: {
Tcl_Interp *slaveInterp; /* A slave. */
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
return SlaveHidden(interp, slaveInterp);
}
case OPT_ISSAFE: {
Tcl_Interp *slaveInterp;
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
return TCL_OK;
}
case OPT_INVOKEHID: {
int i, index, global;
Tcl_Interp *slaveInterp;
static CONST char *hiddenOptions[] = {
"-global", "--", NULL
};
enum hiddenOption {
OPT_GLOBAL, OPT_LAST
};
global = 0;
for (i = 3; i < objc; i++) {
if (Tcl_GetString(objv[i])[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
"option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index == OPT_GLOBAL) {
global = 1;
} else {
i++;
break;
}
}
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 2, objv,
"path ?-global? ?--? cmd ?arg ..?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
if (slaveInterp == (Tcl_Interp *) NULL) {
return TCL_ERROR;
}
return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
objv + i);
}
case OPT_MARKTRUSTED: {
Tcl_Interp *slaveInterp;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "path");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
return SlaveMarkTrusted(interp, slaveInterp);
}
case OPT_RECLIMIT: {
Tcl_Interp *slaveInterp;
if (objc != 3 && objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
}
case OPT_SLAVES: {
Tcl_Interp *slaveInterp;
InterpInfo *iiPtr;
Tcl_Obj *resultPtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hashSearch;
char *string;
slaveInterp = GetInterp2(interp, objc, objv);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
resultPtr = Tcl_GetObjResult(interp);
hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewStringObj(string, -1));
}
return TCL_OK;
}
case OPT_SHARE: {
Tcl_Interp *slaveInterp; /* A slave. */
Tcl_Interp *masterInterp; /* Its master. */
Tcl_Channel chan;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
return TCL_ERROR;
}
masterInterp = GetInterp(interp, objv[2]);
if (masterInterp == NULL) {
return TCL_ERROR;
}
chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]),
NULL);
if (chan == NULL) {
TclTransferResult(masterInterp, TCL_OK, interp);
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[4]);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(slaveInterp, chan);
return TCL_OK;
}
case OPT_TARGET: {
Tcl_Interp *slaveInterp;
InterpInfo *iiPtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
char *aliasName;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path alias");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
aliasName = Tcl_GetString(objv[3]);
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"alias \"", aliasName, "\" in path \"",
Tcl_GetString(objv[2]), "\" not found",
(char *) NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"target interpreter for alias \"", aliasName,
"\" in path \"", Tcl_GetString(objv[2]),
"\" is not my descendant", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
case OPT_TRANSFER: {
Tcl_Interp *slaveInterp; /* A slave. */
Tcl_Interp *masterInterp; /* Its master. */
Tcl_Channel chan;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"srcPath channelId destPath");
return TCL_ERROR;
}
masterInterp = GetInterp(interp, objv[2]);
if (masterInterp == NULL) {
return TCL_ERROR;
}
chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);
if (chan == NULL) {
TclTransferResult(masterInterp, TCL_OK, interp);
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[4]);
if (slaveInterp == NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(slaveInterp, chan);
if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
TclTransferResult(masterInterp, TCL_OK, interp);
return TCL_ERROR;
}
return TCL_OK;
}
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* GetInterp2 --
*
* Helper function for Tcl_InterpObjCmd() to convert the interp name
* potentially specified on the command line to an Tcl_Interp.
*
* Results:
* The return value is the interp specified on the command line,
* or the interp argument itself if no interp was specified on the
* command line. If the interp could not be found or the wrong
* number of arguments was specified on the command line, the return
* value is NULL and an error message is left in the interp's result.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static Tcl_Interp *
GetInterp2(interp, objc, objv)
Tcl_Interp *interp; /* Default interp if no interp was specified
* on the command line. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc == 2) {
return interp;
} else if (objc == 3) {
return GetInterp(interp, objv[2]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?path?");
return NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateAlias --
*
* Creates an alias between two interpreters.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates a new alias, manipulates the result field of slaveInterp.
*
*----------------------------------------------------------------------
*/
int
Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
Tcl_Interp *slaveInterp; /* Interpreter for source command. */
CONST char *slaveCmd; /* Command to install in slave. */
Tcl_Interp *targetInterp; /* Interpreter for target command. */
CONST char *targetCmd; /* Name of target command. */
int argc; /* How many additional arguments? */
CONST char * CONST *argv; /* These are the additional args. */
{
Tcl_Obj *slaveObjPtr, *targetObjPtr;
Tcl_Obj **objv;
int i;
int result;
objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
for (i = 0; i < argc; i++) {
objv[i] = Tcl_NewStringObj(argv[i], -1);
Tcl_IncrRefCount(objv[i]);
}
slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
Tcl_IncrRefCount(slaveObjPtr);
targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
Tcl_IncrRefCount(targetObjPtr);
result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
targetObjPtr, argc, objv);
for (i = 0; i < argc; i++) {
Tcl_DecrRefCount(objv[i]);
}
ckfree((char *) objv);
Tcl_DecrRefCount(targetObjPtr);
Tcl_DecrRefCount(slaveObjPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateAliasObj --
*
* Object version: Creates an alias between two interpreters.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates a new alias.
*
*----------------------------------------------------------------------
*/
int
Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
Tcl_Interp *slaveInterp; /* Interpreter for source command. */
CONST char *slaveCmd; /* Command to install in slave. */
Tcl_Interp *targetInterp; /* Interpreter for target command. */
CONST char *targetCmd; /* Name of target command. */
int objc; /* How many additional arguments? */
Tcl_Obj *CONST objv[]; /* Argument vector. */
{
Tcl_Obj *slaveObjPtr, *targetObjPtr;
int result;
slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
Tcl_IncrRefCount(slaveObjPtr);
targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
Tcl_IncrRefCount(targetObjPtr);
result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
targetObjPtr, objc, objv);
Tcl_DecrRefCount(slaveObjPtr);
Tcl_DecrRefCount(targetObjPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetAlias --
*
* Gets information about an alias.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
argvPtr)
Tcl_Interp *interp; /* Interp to start search from. */
CONST char *aliasName; /* Name of alias to find. */
Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
CONST char **targetNamePtr; /* (Return) name of target command. */
int *argcPtr; /* (Return) count of addnl args. */
CONST char ***argvPtr; /* (Return) additional arguments. */
{
InterpInfo *iiPtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int i, objc;
Tcl_Obj **objv;
iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"alias \"", aliasName, "\" not found", (char *) NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
if (targetInterpPtr != NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
}
if (targetNamePtr != NULL) {
*targetNamePtr = Tcl_GetString(objv[0]);
}
if (argcPtr != NULL) {
*argcPtr = objc - 1;
}
if (argvPtr != NULL) {
*argvPtr = (CONST char **)
ckalloc((unsigned) sizeof(CONST char *) * (objc - 1));
for (i = 1; i < objc; i++) {
(*argvPtr)[i - 1] = Tcl_GetString(objv[i]);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetAliasObj --
*
* Object version: Gets information about an alias.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
objvPtr)
Tcl_Interp *interp; /* Interp to start search from. */
CONST char *aliasName; /* Name of alias to find. */
Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
CONST char **targetNamePtr; /* (Return) name of target command. */
int *objcPtr; /* (Return) count of addnl args. */
Tcl_Obj ***objvPtr; /* (Return) additional args. */
{
InterpInfo *iiPtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int objc;
Tcl_Obj **objv;
iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == (Tcl_HashEntry *) NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"alias \"", aliasName, "\" not found", (char *) NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
if (targetInterpPtr != (Tcl_Interp **) NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
}
if (targetNamePtr != (CONST char **) NULL) {
*targetNamePtr = Tcl_GetString(objv[0]);
}
if (objcPtr != (int *) NULL) {
*objcPtr = objc - 1;
}
if (objvPtr != (Tcl_Obj ***) NULL) {
*objvPtr = objv + 1;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclPreventAliasLoop --
*
* When defining an alias or renaming a command, prevent an alias
* loop from being formed.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* If TCL_ERROR is returned, the function also stores an error message
* in the interpreter's result object.
*
* NOTE:
* This function is public internal (instead of being static to
* this file) because it is also used from TclRenameCommand.
*
*----------------------------------------------------------------------
*/
int
TclPreventAliasLoop(interp, cmdInterp, cmd)
Tcl_Interp *interp; /* Interp in which to report errors. */
Tcl_Interp *cmdInterp; /* Interp in which the command is
* being defined. */
Tcl_Command cmd; /* Tcl command we are attempting
* to define. */
{
Command *cmdPtr = (Command *) cmd;
Alias *aliasPtr, *nextAliasPtr;
Tcl_Command aliasCmd;
Command *aliasCmdPtr;
/*
* If we are not creating or renaming an alias, then it is
* always OK to create or rename the command.
*/
if (cmdPtr->objProc != AliasObjCmd) {
return TCL_OK;
}
/*
* OK, we are dealing with an alias, so traverse the chain of aliases.
* If we encounter the alias we are defining (or renaming to) any in
* the chain then we have a loop.
*/
aliasPtr = (Alias *) cmdPtr->objClientData;
nextAliasPtr = aliasPtr;
while (1) {
Tcl_Obj *cmdNamePtr;
/*
* If the target of the next alias in the chain is the same as
* the source alias, we have a loop.
*/
if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
/*
* The slave interpreter can be deleted while creating the alias.
* [Bug #641195]
*/
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot define or rename alias \"",
Tcl_GetString(aliasPtr->namePtr),
"\": interpreter deleted", (char *) NULL);
return TCL_ERROR;
}
cmdNamePtr = nextAliasPtr->objPtr;
aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
Tcl_GetString(cmdNamePtr),
Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
/*flags*/ 0);
if (aliasCmd == (Tcl_Command) NULL) {
return TCL_OK;
}
aliasCmdPtr = (Command *) aliasCmd;
if (aliasCmdPtr == cmdPtr) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot define or rename alias \"",
Tcl_GetString(aliasPtr->namePtr),
"\": would create a loop", (char *) NULL);
return TCL_ERROR;
}
/*
* Otherwise, follow the chain one step further. See if the target
* command is an alias - if so, follow the loop to its target
* command. Otherwise we do not have a loop.
*/
if (aliasCmdPtr->objProc != AliasObjCmd) {
return TCL_OK;
}
nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
}
/* NOTREACHED */
}
/*
*----------------------------------------------------------------------
*
* AliasCreate --
*
* Helper function to do the work to actually create an alias.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* An alias command is created and entered into the alias table
* for the slave interpreter.
*
*----------------------------------------------------------------------
*/
static int
AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
objc, objv)
Tcl_Interp *interp; /* Interp for error reporting. */
Tcl_Interp *slaveInterp; /* Interp where alias cmd will live or from
* which alias will be deleted. */
Tcl_Interp *masterInterp; /* Interp in which target command will be
* invoked. */
Tcl_Obj *namePtr; /* Name of alias cmd. */
Tcl_Obj *targetNamePtr; /* Name of target cmd. */
int objc; /* Additional arguments to store */
Tcl_Obj *CONST objv[]; /* with alias. */
{
Alias *aliasPtr;
Tcl_HashEntry *hPtr;
Target *targetPtr;
Slave *slavePtr;
Master *masterPtr;
Tcl_Obj **prefv;
int new, i;
aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias)
+ objc * sizeof(Tcl_Obj *)));
aliasPtr->namePtr = namePtr;
Tcl_IncrRefCount(aliasPtr->namePtr);
aliasPtr->targetInterp = masterInterp;
aliasPtr->objc = objc + 1;
prefv = &aliasPtr->objPtr;
*prefv = targetNamePtr;
Tcl_IncrRefCount(targetNamePtr);
for (i = 0; i < objc; i++) {
*(++prefv) = objv[i];
Tcl_IncrRefCount(objv[i]);
}
Tcl_Preserve(slaveInterp);
Tcl_Preserve(masterInterp);
aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
AliasObjCmdDeleteProc);
if (TclPreventAliasLoop(interp, slaveInterp,
aliasPtr->slaveCmd) != TCL_OK) {
/*
* Found an alias loop! The last call to Tcl_CreateObjCommand made
* the alias point to itself. Delete the command and its alias
* record. Be careful to wipe out its client data first, so the
* command doesn't try to delete itself.
*/
Command *cmdPtr;
Tcl_DecrRefCount(aliasPtr->namePtr);
Tcl_DecrRefCount(targetNamePtr);
for (i = 0; i < objc; i++) {
Tcl_DecrRefCount(objv[i]);
}
cmdPtr = (Command *) aliasPtr->slaveCmd;
cmdPtr->clientData = NULL;
cmdPtr->deleteProc = NULL;
cmdPtr->deleteData = NULL;
Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
ckfree((char *) aliasPtr);
/*
* The result was already set by TclPreventAliasLoop.
*/
Tcl_Release(slaveInterp);
Tcl_Release(masterInterp);
return TCL_ERROR;
}
/*
* Make an entry in the alias table. If it already exists delete
* the alias command. Then retry.
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
while (1) {
Alias *oldAliasPtr;
char *string;
string = Tcl_GetString(namePtr);
hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new);
if (new != 0) {
break;
}
oldAliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
Tcl_DeleteCommandFromToken(slaveInterp, oldAliasPtr->slaveCmd);
}
aliasPtr->aliasEntryPtr = hPtr;
Tcl_SetHashValue(hPtr, (ClientData) aliasPtr);
/*
* Create the new command. We must do it after deleting any old command,
* because the alias may be pointing at a renamed alias, as in:
*
* interp alias {} foo {} bar # Create an alias "foo"
* rename foo zop # Now rename the alias
* interp alias {} foo {} zop # Now recreate "foo"...
*/
targetPtr = (Target *) ckalloc((unsigned) sizeof(Target));
targetPtr->slaveCmd = aliasPtr->slaveCmd;
targetPtr->slaveInterp = slaveInterp;
Tcl_MutexLock(&cntMutex);
masterPtr = &((InterpInfo *) ((Interp *) masterInterp)->interpInfo)->master;
do {
hPtr = Tcl_CreateHashEntry(&masterPtr->targetTable,
(char *) aliasCounter, &new);
aliasCounter++;
} while (new == 0);
Tcl_MutexUnlock(&cntMutex);
Tcl_SetHashValue(hPtr, (ClientData) targetPtr);
aliasPtr->targetEntryPtr = hPtr;
Tcl_SetObjResult(interp, namePtr);
Tcl_Release(slaveInterp);
Tcl_Release(masterInterp);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AliasDelete --
*
* Deletes the given alias from the slave interpreter given.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Deletes the alias from the slave interpreter.
*
*----------------------------------------------------------------------
*/
static int
AliasDelete(interp, slaveInterp, namePtr)
Tcl_Interp *interp; /* Interpreter for result & errors. */
Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
Tcl_Obj *namePtr; /* Name of alias to delete. */
{
Slave *slavePtr;
Alias *aliasPtr;
Tcl_HashEntry *hPtr;
/*
* If the alias has been renamed in the slave, the master can still use
* the original name (with which it was created) to find the alias to
* delete it.
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "alias \"",
Tcl_GetString(namePtr), "\" not found", NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AliasDescribe --
*
* Sets the interpreter's result object to a Tcl list describing
* the given alias in the given interpreter: its target command
* and the additional arguments to prepend to any invocation
* of the alias.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
AliasDescribe(interp, slaveInterp, namePtr)
Tcl_Interp *interp; /* Interpreter for result & errors. */
Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
Tcl_Obj *namePtr; /* Name of alias to describe. */
{
Slave *slavePtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
Tcl_Obj *prefixPtr;
/*
* If the alias has been renamed in the slave, the master can still use
* the original name (with which it was created) to find the alias to
* describe it.
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
if (hPtr == NULL) {
return TCL_OK;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
Tcl_SetObjResult(interp, prefixPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AliasList --
*
* Computes a list of aliases defined in a slave interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
AliasList(interp, slaveInterp)
Tcl_Interp *interp; /* Interp for data return. */
Tcl_Interp *slaveInterp; /* Interp whose aliases to compute. */
{
Tcl_HashEntry *entryPtr;
Tcl_HashSearch hashSearch;
Tcl_Obj *resultPtr;
Alias *aliasPtr;
Slave *slavePtr;
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
resultPtr = Tcl_GetObjResult(interp);
entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr);
Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->namePtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AliasObjCmd --
*
* This is the procedure that services invocations of aliases in a
* slave interpreter. One such command exists for each alias. When
* invoked, this procedure redirects the invocation to the target
* command in the master interpreter as designated by the Alias
* record associated with this command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Causes forwarding of the invocation; all possible side effects
* may occur as a result of invoking the command to which the
* invocation is forwarded.
*
*----------------------------------------------------------------------
*/
static int
AliasObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Alias record. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
Tcl_Interp *targetInterp;
Alias *aliasPtr;
int result, prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
aliasPtr = (Alias *) clientData;
targetInterp = aliasPtr->targetInterp;
/*
* Append the arguments to the command prefix and invoke the command
* in the target interp's global namespace.
*/
prefc = aliasPtr->objc;
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
if (cmdc <= ALIAS_CMDV_PREALLOC) {
cmdv = cmdArr;
} else {
cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *)));
}
prefv = &aliasPtr->objPtr;
memcpy((VOID *) cmdv, (VOID *) prefv,
(size_t) (prefc * sizeof(Tcl_Obj *)));
memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1),
(size_t) ((objc-1) * sizeof(Tcl_Obj *)));
Tcl_ResetResult(targetInterp);
for (i=0; inamePtr);
objv = &aliasPtr->objPtr;
for (i = 0; i < aliasPtr->objc; i++) {
Tcl_DecrRefCount(objv[i]);
}
Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
ckfree((char *) targetPtr);
Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr);
ckfree((char *) aliasPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateSlave --
*
* Creates a slave interpreter. The slavePath argument denotes the
* name of the new slave relative to the current interpreter; the
* slave is a direct descendant of the one-before-last component of
* the path, e.g. it is a descendant of the current interpreter if
* the slavePath argument contains only one component. Optionally makes
* the slave interpreter safe.
*
* Results:
* Returns the interpreter structure created, or NULL if an error
* occurred.
*
* Side effects:
* Creates a new interpreter and a new interpreter object command in
* the interpreter indicated by the slavePath argument.
*
*----------------------------------------------------------------------
*/
Tcl_Interp *
Tcl_CreateSlave(interp, slavePath, isSafe)
Tcl_Interp *interp; /* Interpreter to start search at. */
CONST char *slavePath; /* Name of slave to create. */
int isSafe; /* Should new slave be "safe" ? */
{
Tcl_Obj *pathPtr;
Tcl_Interp *slaveInterp;
pathPtr = Tcl_NewStringObj(slavePath, -1);
slaveInterp = SlaveCreate(interp, pathPtr, isSafe);
Tcl_DecrRefCount(pathPtr);
return slaveInterp;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetSlave --
*
* Finds a slave interpreter by its path name.
*
* Results:
* Returns a Tcl_Interp * for the named interpreter or NULL if not
* found.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Interp *
Tcl_GetSlave(interp, slavePath)
Tcl_Interp *interp; /* Interpreter to start search from. */
CONST char *slavePath; /* Path of slave to find. */
{
Tcl_Obj *pathPtr;
Tcl_Interp *slaveInterp;
pathPtr = Tcl_NewStringObj(slavePath, -1);
slaveInterp = GetInterp(interp, pathPtr);
Tcl_DecrRefCount(pathPtr);
return slaveInterp;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetMaster --
*
* Finds the master interpreter of a slave interpreter.
*
* Results:
* Returns a Tcl_Interp * for the master interpreter or NULL if none.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Interp *
Tcl_GetMaster(interp)
Tcl_Interp *interp; /* Get the master of this interpreter. */
{
Slave *slavePtr; /* Slave record of this interpreter. */
if (interp == (Tcl_Interp *) NULL) {
return NULL;
}
slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
return slavePtr->masterInterp;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetInterpPath --
*
* Sets the result of the asking interpreter to a proper Tcl list
* containing the names of interpreters between the asking and
* target interpreters. The target interpreter must be either the
* same as the asking interpreter or one of its slaves (including
* recursively).
*
* Results:
* TCL_OK if the target interpreter is the same as, or a descendant
* of, the asking interpreter; TCL_ERROR else. This way one can
* distinguish between the case where the asking and target interps
* are the same (an empty list is the result, and TCL_OK is returned)
* and when the target is not a descendant of the asking interpreter
* (in which case the Tcl result is an error message and the function
* returns TCL_ERROR).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetInterpPath(askingInterp, targetInterp)
Tcl_Interp *askingInterp; /* Interpreter to start search from. */
Tcl_Interp *targetInterp; /* Interpreter to find. */
{
InterpInfo *iiPtr;
if (targetInterp == askingInterp) {
return TCL_OK;
}
if (targetInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) {
return TCL_ERROR;
}
Tcl_AppendElement(askingInterp,
Tcl_GetHashKey(&iiPtr->master.slaveTable,
iiPtr->slave.slaveEntryPtr));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetInterp --
*
* Helper function to find a slave interpreter given a pathname.
*
* Results:
* Returns the slave interpreter known by that name in the calling
* interpreter, or NULL if no interpreter known by that name exists.
*
* Side effects:
* Assigns to the pointer variable passed in, if not NULL.
*
*----------------------------------------------------------------------
*/
static Tcl_Interp *
GetInterp(interp, pathPtr)
Tcl_Interp *interp; /* Interp. to start search from. */
Tcl_Obj *pathPtr; /* List object containing name of interp. to
* be found. */
{
Tcl_HashEntry *hPtr; /* Search element. */
Slave *slavePtr; /* Interim slave record. */
Tcl_Obj **objv;
int objc, i;
Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
InterpInfo *masterInfoPtr;
if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
searchInterp = interp;
for (i = 0; i < objc; i++) {
masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
Tcl_GetString(objv[i]));
if (hPtr == NULL) {
searchInterp = NULL;
break;
}
slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
searchInterp = slavePtr->slaveInterp;
if (searchInterp == NULL) {
break;
}
}
if (searchInterp == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not find interpreter \"",
Tcl_GetString(pathPtr), "\"", (char *) NULL);
}
return searchInterp;
}
/*
*----------------------------------------------------------------------
*
* SlaveCreate --
*
* Helper function to do the actual work of creating a slave interp
* and new object command. Also optionally makes the new slave
* interpreter "safe".
*
* Results:
* Returns the new Tcl_Interp * if successful or NULL if not. If failed,
* the result of the invoking interpreter contains an error message.
*
* Side effects:
* Creates a new slave interpreter and a new object command.
*
*----------------------------------------------------------------------
*/
static Tcl_Interp *
SlaveCreate(interp, pathPtr, safe)
Tcl_Interp *interp; /* Interp. to start search from. */
Tcl_Obj *pathPtr; /* Path (name) of slave to create. */
int safe; /* Should we make it "safe"? */
{
Tcl_Interp *masterInterp, *slaveInterp;
Slave *slavePtr;
InterpInfo *masterInfoPtr;
Tcl_HashEntry *hPtr;
char *path;
int new, objc;
Tcl_Obj **objv;
if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
if (objc < 2) {
masterInterp = interp;
path = Tcl_GetString(pathPtr);
} else {
Tcl_Obj *objPtr;
objPtr = Tcl_NewListObj(objc - 1, objv);
masterInterp = GetInterp(interp, objPtr);
Tcl_DecrRefCount(objPtr);
if (masterInterp == NULL) {
return NULL;
}
path = Tcl_GetString(objv[objc - 1]);
}
if (safe == 0) {
safe = Tcl_IsSafe(masterInterp);
}
masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new);
if (new == 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"interpreter named \"", path,
"\" already exists, cannot create", (char *) NULL);
return NULL;
}
slaveInterp = Tcl_CreateInterp();
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
slavePtr->masterInterp = masterInterp;
slavePtr->slaveEntryPtr = hPtr;
slavePtr->slaveInterp = slaveInterp;
slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc);
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
/*
* Inherit the recursion limit.
*/
((Interp *) slaveInterp)->maxNestingDepth =
((Interp *) masterInterp)->maxNestingDepth ;
if (safe) {
if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
goto error;
}
} else {
if (Tcl_Init(slaveInterp) == TCL_ERROR) {
goto error;
}
/*
* This will create the "memory" command in slave interpreters
* if we compiled with TCL_MEM_DEBUG, otherwise it does nothing.
*/
Tcl_InitMemory(slaveInterp);
}
return slaveInterp;
error:
TclTransferResult(slaveInterp, TCL_ERROR, interp);
Tcl_DeleteInterp(slaveInterp);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* SlaveObjCmd --
*
* Command to manipulate an interpreter, e.g. to send commands to it
* to be evaluated. One such command exists for each slave interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See user documentation for details.
*
*----------------------------------------------------------------------
*/
static int
SlaveObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Slave interpreter. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Interp *slaveInterp;
int index;
static CONST char *options[] = {
"alias", "aliases", "eval", "expose",
"hide", "hidden", "issafe", "invokehidden",
"marktrusted", "recursionlimit", NULL
};
enum options {
OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE,
OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN,
OPT_MARKTRUSTED, OPT_RECLIMIT
};
slaveInterp = (Tcl_Interp *) clientData;
if (slaveInterp == NULL) {
panic("SlaveObjCmd: interpreter has been deleted");
}
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case OPT_ALIAS: {
if (objc > 2) {
if (objc == 3) {
return AliasDescribe(interp, slaveInterp, objv[2]);
}
if (Tcl_GetString(objv[3])[0] == '\0') {
if (objc == 4) {
return AliasDelete(interp, slaveInterp, objv[2]);
}
} else {
return AliasCreate(interp, slaveInterp, interp, objv[2],
objv[3], objc - 4, objv + 4);
}
}
Tcl_WrongNumArgs(interp, 2, objv,
"aliasName ?targetName? ?args..?");
return TCL_ERROR;
}
case OPT_ALIASES: {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
return TCL_ERROR;
}
return AliasList(interp, slaveInterp);
}
case OPT_EVAL: {
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
return TCL_ERROR;
}
return SlaveEval(interp, slaveInterp, objc - 2, objv + 2);
}
case OPT_EXPOSE: {
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
return TCL_ERROR;
}
return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2);
}
case OPT_HIDE: {
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
return TCL_ERROR;
}
return SlaveHide(interp, slaveInterp, objc - 2, objv + 2);
}
case OPT_HIDDEN: {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return SlaveHidden(interp, slaveInterp);
}
case OPT_ISSAFE: {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
return TCL_OK;
}
case OPT_INVOKEHIDDEN: {
int global, i, index;
static CONST char *hiddenOptions[] = {
"-global", "--", NULL
};
enum hiddenOption {
OPT_GLOBAL, OPT_LAST
};
global = 0;
for (i = 2; i < objc; i++) {
if (Tcl_GetString(objv[i])[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
"option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index == OPT_GLOBAL) {
global = 1;
} else {
i++;
break;
}
}
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-global? ?--? cmd ?arg ..?");
return TCL_ERROR;
}
return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
objv + i);
}
case OPT_MARKTRUSTED: {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return SlaveMarkTrusted(interp, slaveInterp);
}
case OPT_RECLIMIT: {
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?");
return TCL_ERROR;
}
return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2);
}
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* SlaveObjCmdDeleteProc --
*
* Invoked when an object command for a slave interpreter is deleted;
* cleans up all state associated with the slave interpreter and destroys
* the slave interpreter.
*
* Results:
* None.
*
* Side effects:
* Cleans up all state associated with the slave interpreter and
* destroys the slave interpreter.
*
*----------------------------------------------------------------------
*/
static void
SlaveObjCmdDeleteProc(clientData)
ClientData clientData; /* The SlaveRecord for the command. */
{
Slave *slavePtr; /* Interim storage for Slave record. */
Tcl_Interp *slaveInterp; /* And for a slave interp. */
slaveInterp = (Tcl_Interp *) clientData;
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
/*
* Unlink the slave from its master interpreter.
*/
Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr);
/*
* Set to NULL so that when the InterpInfo is cleaned up in the slave
* it does not try to delete the command causing all sorts of grief.
* See SlaveRecordDeleteProc().
*/
slavePtr->interpCmd = NULL;
if (slavePtr->slaveInterp != NULL) {
Tcl_DeleteInterp(slavePtr->slaveInterp);
}
}
/*
*----------------------------------------------------------------------
*
* SlaveEval --
*
* Helper function to evaluate a command in a slave interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the command does.
*
*----------------------------------------------------------------------
*/
static int
SlaveEval(interp, slaveInterp, objc, objv)
Tcl_Interp *interp; /* Interp for error return. */
Tcl_Interp *slaveInterp; /* The slave interpreter in which command
* will be evaluated. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result;
Tcl_Obj *objPtr;
Tcl_Preserve((ClientData) slaveInterp);
Tcl_AllowExceptions(slaveInterp);
if (objc == 1) {
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
#else
/* TIP #280 : Make actual argument location available to eval'd script */
Interp* iPtr = (Interp*) interp;
CmdFrame* invoker = iPtr->cmdFramePtr;
int word = 0;
TclArgumentGet (interp, objv[0], &invoker, &word);
result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word);
#endif
} else {
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
Tcl_DecrRefCount(objPtr);
}
TclTransferResult(slaveInterp, result, interp);
Tcl_Release((ClientData) slaveInterp);
return result;
}
/*
*----------------------------------------------------------------------
*
* SlaveExpose --
*
* Helper function to expose a command in a slave interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* After this call scripts in the slave will be able to invoke
* the newly exposed command.
*
*----------------------------------------------------------------------
*/
static int
SlaveExpose(interp, slaveInterp, objc, objv)
Tcl_Interp *interp; /* Interp for error return. */
Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument strings. */
{
char *name;
if (Tcl_IsSafe(interp)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"permission denied: safe interpreter cannot expose commands",
(char *) NULL);
return TCL_ERROR;
}
name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
if (Tcl_ExposeCommand(slaveInterp, Tcl_GetString(objv[0]),
name) != TCL_OK) {
TclTransferResult(slaveInterp, TCL_ERROR, interp);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SlaveRecursionLimit --
*
* Helper function to set/query the Recursion limit of an interp
*
* Results:
* A standard Tcl result.
*
* Side effects:
* When (objc == 1), slaveInterp will be set to a new recursion
* limit of objv[0].
*
*----------------------------------------------------------------------
*/
static int
SlaveRecursionLimit(interp, slaveInterp, objc, objv)
Tcl_Interp *interp; /* Interp for error return. */
Tcl_Interp *slaveInterp; /* Interp in which limit is set/queried. */
int objc; /* Set or Query. */
Tcl_Obj *CONST objv[]; /* Argument strings. */
{
Interp *iPtr;
int limit;
if (objc) {
if (Tcl_IsSafe(interp)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"permission denied: ",
"safe interpreters cannot change recursion limit",
(char *) NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
return TCL_ERROR;
}
if (limit <= 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"recursion limit must be > 0", -1));
return TCL_ERROR;
}
Tcl_SetRecursionLimit(slaveInterp, limit);
iPtr = (Interp *) slaveInterp;
if (interp == slaveInterp && iPtr->numLevels > limit) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"falling back due to new recursion limit", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[0]);
return TCL_OK;
} else {
limit = Tcl_SetRecursionLimit(slaveInterp, 0);
Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
* SlaveHide --
*
* Helper function to hide a command in a slave interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* After this call scripts in the slave will no longer be able
* to invoke the named command.
*
*----------------------------------------------------------------------
*/
static int
SlaveHide(interp, slaveInterp, objc, objv)
Tcl_Interp *interp; /* Interp for error return. */
Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument strings. */
{
char *name;
if (Tcl_IsSafe(interp)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"permission denied: safe interpreter cannot hide commands",
(char *) NULL);
return TCL_ERROR;
}
name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]),
name) != TCL_OK) {
TclTransferResult(slaveInterp, TCL_ERROR, interp);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SlaveHidden --
*
* Helper function to compute list of hidden commands in a slave
* interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
SlaveHidden(interp, slaveInterp)
Tcl_Interp *interp; /* Interp for data return. */
Tcl_Interp *slaveInterp; /* Interp whose hidden commands to query. */
{
Tcl_Obj *listObjPtr; /* Local object pointer. */
Tcl_HashTable *hTblPtr; /* For local searches. */
Tcl_HashEntry *hPtr; /* For local searches. */
Tcl_HashSearch hSearch; /* For local searches. */
listObjPtr = Tcl_GetObjResult(interp);
hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr;
if (hTblPtr != (Tcl_HashTable *) NULL) {
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != (Tcl_HashEntry *) NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
Tcl_ListObjAppendElement(NULL, listObjPtr,
Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SlaveInvokeHidden --
*
* Helper function to invoke a hidden command in a slave interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the hidden command does.
*
*----------------------------------------------------------------------
*/
static int
SlaveInvokeHidden(interp, slaveInterp, global, objc, objv)
Tcl_Interp *interp; /* Interp for error return. */
Tcl_Interp *slaveInterp; /* The slave interpreter in which command
* will be invoked. */
int global; /* Non-zero to invoke in global namespace. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result;
if (Tcl_IsSafe(interp)) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"not allowed to invoke hidden commands from safe interpreter",
-1);
return TCL_ERROR;
}
Tcl_Preserve((ClientData) slaveInterp);
Tcl_AllowExceptions(slaveInterp);
if (global) {
result = TclObjInvokeGlobal(slaveInterp, objc, objv,
TCL_INVOKE_HIDDEN);
} else {
result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
}
TclTransferResult(slaveInterp, result, interp);
Tcl_Release((ClientData) slaveInterp);
return result;
}
/*
*----------------------------------------------------------------------
*
* SlaveMarkTrusted --
*
* Helper function to mark a slave interpreter as trusted (unsafe).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* After this call the hard-wired security checks in the core no
* longer prevent the slave from performing certain operations.
*
*----------------------------------------------------------------------
*/
static int
SlaveMarkTrusted(interp, slaveInterp)
Tcl_Interp *interp; /* Interp for error return. */
Tcl_Interp *slaveInterp; /* The slave interpreter which will be
* marked trusted. */
{
if (Tcl_IsSafe(interp)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"permission denied: safe interpreter cannot mark trusted",
(char *) NULL);
return TCL_ERROR;
}
((Interp *) slaveInterp)->flags &= ~SAFE_INTERP;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_IsSafe --
*
* Determines whether an interpreter is safe
*
* Results:
* 1 if it is safe, 0 if it is not.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_IsSafe(interp)
Tcl_Interp *interp; /* Is this interpreter "safe" ? */
{
Interp *iPtr;
if (interp == (Tcl_Interp *) NULL) {
return 0;
}
iPtr = (Interp *) interp;
return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
}
/*
*----------------------------------------------------------------------
*
* Tcl_MakeSafe --
*
* Makes its argument interpreter contain only functionality that is
* defined to be part of Safe Tcl. Unsafe commands are hidden, the
* env array is unset, and the standard channels are removed.
*
* Results:
* None.
*
* Side effects:
* Hides commands in its argument interpreter, and removes settings
* and channels.
*
*----------------------------------------------------------------------
*/
int
Tcl_MakeSafe(interp)
Tcl_Interp *interp; /* Interpreter to be made safe. */
{
Tcl_Channel chan; /* Channel to remove from
* safe interpreter. */
Interp *iPtr = (Interp *) interp;
TclHideUnsafeCommands(interp);
iPtr->flags |= SAFE_INTERP;
/*
* Unsetting variables : (which should not have been set
* in the first place, but...)
*/
/*
* No env array in a safe slave.
*/
Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
/*
* Remove unsafe parts of tcl_platform
*/
Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);
/*
* Unset path informations variables
* (the only one remaining is [info nameofexecutable])
*/
Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
/*
* Remove the standard channels from the interpreter; safe interpreters
* do not ordinarily have access to stdin, stdout and stderr.
*
* NOTE: These channels are not added to the interpreter by the
* Tcl_CreateInterp call, but may be added later, by another I/O
* operation. We want to ensure that the interpreter does not have
* these channels even if it is being made safe after being used for
* some time..
*/
chan = Tcl_GetStdChannel(TCL_STDIN);
if (chan != (Tcl_Channel) NULL) {
Tcl_UnregisterChannel(interp, chan);
}
chan = Tcl_GetStdChannel(TCL_STDOUT);
if (chan != (Tcl_Channel) NULL) {
Tcl_UnregisterChannel(interp, chan);
}
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan != (Tcl_Channel) NULL) {
Tcl_UnregisterChannel(interp, chan);
}
return TCL_OK;
}
tcl8.4.20/generic/tclGet.c 0000644 0036047 0045461 00000022222 12052456743 013717 0 ustar dgp 771div /*
* tclGet.c --
*
* This file contains procedures to convert strings into
* other forms, like integers or floating-point numbers or
* booleans, doing syntax checking along the way.
*
* Copyright (c) 1990-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.
*/
#include "tclInt.h"
#include "tclPort.h"
#include
/*
*----------------------------------------------------------------------
*
* Tcl_GetInt --
*
* Given a string, produce the corresponding integer value.
*
* Results:
* The return value is normally TCL_OK; in this case *intPtr
* will be set to the integer value equivalent to string. If
* string is improperly formed then TCL_ERROR is returned and
* an error message will be left in the interp's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetInt(interp, string, intPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting. */
CONST char *string; /* String containing a (possibly signed)
* integer in a form acceptable to strtol. */
int *intPtr; /* Place to store converted result. */
{
char *end;
CONST char *p = string;
long i;
/*
* Note: use strtoul instead of strtol for integer conversions
* to allow full-size unsigned numbers, but don't depend on strtoul
* to handle sign characters; it won't in some implementations.
*/
errno = 0;
#ifdef TCL_STRTOUL_SIGN_CHECK
/*
* This special sign check actually causes bad numbers to be allowed
* when strtoul. I can't find a strtoul that doesn't validly handle
* signed characters, and the C standard implies that this is all
* unnecessary. [Bug #634856]
*/
for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
/* Empty loop body. */
}
if (*p == '-') {
p++;
i = -((long)strtoul(p, &end, 0)); /* INTL: Tcl source. */
} else if (*p == '+') {
p++;
i = strtoul(p, &end, 0); /* INTL: Tcl source. */
} else
#else
i = strtoul(p, &end, 0); /* INTL: Tcl source. */
#endif
if (end == p) {
badInteger:
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "expected integer but got \"", string,
"\"", (char *) NULL);
TclCheckBadOctal(interp, string);
}
return TCL_ERROR;
}
/*
* The second test below is needed on platforms where "long" is
* larger than "int" to detect values that fit in a long but not in
* an int.
*/
if ((errno == ERANGE)
#if (LONG_MAX > INT_MAX)
|| (i > UINT_MAX) || (i < -(long)UINT_MAX)
#endif
) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_SetResult(interp, "integer value too large to represent",
TCL_STATIC);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
Tcl_GetStringResult(interp), (char *) NULL);
}
return TCL_ERROR;
}
while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (*end != 0) {
goto badInteger;
}
*intPtr = (int) i;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclGetLong --
*
* Given a string, produce the corresponding long integer value.
* This routine is a version of Tcl_GetInt but returns a "long"
* instead of an "int".
*
* Results:
* The return value is normally TCL_OK; in this case *longPtr
* will be set to the long integer value equivalent to string. If
* string is improperly formed then TCL_ERROR is returned and
* an error message will be left in the interp's result if interp
* is non-NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclGetLong(interp, string, longPtr)
Tcl_Interp *interp; /* Interpreter used for error reporting
* if not NULL. */
CONST char *string; /* String containing a (possibly signed)
* long integer in a form acceptable to
* strtoul. */
long *longPtr; /* Place to store converted long result. */
{
char *end;
CONST char *p = string;
long i;
/*
* Note: don't depend on strtoul to handle sign characters; it won't
* in some implementations.
*/
errno = 0;
#ifdef TCL_STRTOUL_SIGN_CHECK
for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
/* Empty loop body. */
}
if (*p == '-') {
p++;
i = -(int)strtoul(p, &end, 0); /* INTL: Tcl source. */
} else if (*p == '+') {
p++;
i = strtoul(p, &end, 0); /* INTL: Tcl source. */
} else
#else
i = strtoul(p, &end, 0); /* INTL: Tcl source. */
#endif
if (end == p) {
badInteger:
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "expected integer but got \"", string,
"\"", (char *) NULL);
TclCheckBadOctal(interp, string);
}
return TCL_ERROR;
}
if (errno == ERANGE) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_SetResult(interp, "integer value too large to represent",
TCL_STATIC);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
Tcl_GetStringResult(interp), (char *) NULL);
}
return TCL_ERROR;
}
while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (*end != 0) {
goto badInteger;
}
*longPtr = i;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetDouble --
*
* Given a string, produce the corresponding double-precision
* floating-point value.
*
* Results:
* The return value is normally TCL_OK; in this case *doublePtr
* will be set to the double-precision value equivalent to string.
* If string is improperly formed then TCL_ERROR is returned and
* an error message will be left in the interp's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetDouble(interp, string, doublePtr)
Tcl_Interp *interp; /* Interpreter used for error reporting. */
CONST char *string; /* String containing a floating-point number
* in a form acceptable to strtod. */
double *doublePtr; /* Place to store converted result. */
{
char *end;
double d;
errno = 0;
d = strtod(string, &end); /* INTL: Tcl source. */
if (end == string) {
badDouble:
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp,
"expected floating-point number but got \"",
string, "\"", (char *) NULL);
}
return TCL_ERROR;
}
if (errno != 0 && (d == HUGE_VAL || d == -HUGE_VAL || d == 0)) {
if (interp != (Tcl_Interp *) NULL) {
TclExprFloatError(interp, d);
}
return TCL_ERROR;
}
while ((*end != 0) && isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (*end != 0) {
goto badDouble;
}
*doublePtr = d;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetBoolean --
*
* Given a string, return a 0/1 boolean value corresponding
* to the string.
*
* Results:
* The return value is normally TCL_OK; in this case *boolPtr
* will be set to the 0/1 value equivalent to string. If
* string is improperly formed then TCL_ERROR is returned and
* an error message will be left in the interp's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetBoolean(interp, string, boolPtr)
Tcl_Interp *interp; /* Interpreter used for error reporting. */
CONST char *string; /* String containing a boolean number
* specified either as 1/0 or true/false or
* yes/no. */
int *boolPtr; /* Place to store converted result, which
* will be 0 or 1. */
{
int i;
char lowerCase[10], c;
size_t length;
/*
* Convert the input string to all lower-case.
* INTL: This code will work on UTF strings.
*/
for (i = 0; i < 9; i++) {
c = string[i];
if (c == 0) {
break;
}
if ((c >= 'A') && (c <= 'Z')) {
c += (char) ('a' - 'A');
}
lowerCase[i] = c;
}
lowerCase[i] = 0;
length = strlen(lowerCase);
c = lowerCase[0];
if ((c == '0') && (lowerCase[1] == '\0')) {
*boolPtr = 0;
} else if ((c == '1') && (lowerCase[1] == '\0')) {
*boolPtr = 1;
} else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) {
*boolPtr = 1;
} else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) {
*boolPtr = 0;
} else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) {
*boolPtr = 1;
} else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) {
*boolPtr = 0;
} else if ((c == 'o') && (length >= 2)) {
if (strncmp(lowerCase, "on", length) == 0) {
*boolPtr = 1;
} else if (strncmp(lowerCase, "off", length) == 0) {
*boolPtr = 0;
} else {
goto badBoolean;
}
} else {
badBoolean:
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "expected boolean value but got \"",
string, "\"", (char *) NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
tcl8.4.20/generic/tclTest.c 0000644 0036047 0045461 00000577750 12052456744 014145 0 ustar dgp 771div /*
* tclTest.c --
*
* This file contains C command procedures for a bunch of additional
* Tcl commands that are used for testing out Tcl's C interfaces.
* These commands are not normally included in Tcl applications;
* they're only used for testing.
*
* Copyright (c) 1993-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 Ajuba Solutions.
* Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _WIN64
/* See [Bug 3354324]: file mtime sets wrong time */
# define _USE_32BIT_TIME_T
#endif
#define TCL_TEST
#include
#include "tclInt.h"
#include "tclPort.h"
/*
* Required for Testregexp*Cmd
*/
#include "tclRegexp.h"
/*
* Required for TestlocaleCmd
*/
#include
/*
* Required for the TestChannelCmd and TestChannelEventCmd
*/
#include "tclIO.h"
/*
* Declare external functions used in Windows tests.
*/
/*
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used
* to collect the results of the various deletion callbacks.
*/
static Tcl_DString delString;
static Tcl_Interp *delInterp;
/*
* One of the following structures exists for each asynchronous
* handler created by the "testasync" command".
*/
typedef struct TestAsyncHandler {
int id; /* Identifier for this handler. */
Tcl_AsyncHandler handler; /* Tcl's token for the handler. */
char *command; /* Command to invoke when the
* handler is invoked. */
struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */
} TestAsyncHandler;
TCL_DECLARE_MUTEX(asyncTestMutex);
static TestAsyncHandler *firstHandler = NULL;
/*
* The dynamic string below is used by the "testdstring" command
* to test the dynamic string facilities.
*/
static Tcl_DString dstring;
/*
* The command trace below is used by the "testcmdtraceCmd" command
* to test the command tracing facilities.
*/
static Tcl_Trace cmdTrace;
/*
* One of the following structures exists for each command created
* by TestdelCmd:
*/
typedef struct DelCmd {
Tcl_Interp *interp; /* Interpreter in which command exists. */
char *deleteCmd; /* Script to execute when command is
* deleted. Malloc'ed. */
} DelCmd;
/*
* The following is used to keep track of an encoding that invokes a Tcl
* command.
*/
typedef struct TclEncoding {
Tcl_Interp *interp;
char *toUtfCmd;
char *fromUtfCmd;
} TclEncoding;
/*
* The counter below is used to determine if the TestsaveresultFree
* routine was called for a result.
*/
static int freeCount;
/*
* Boolean flag used by the "testsetmainloop" and "testexitmainloop"
* commands.
*/
static int exitMainLoop = 0;
/*
* Event structure used in testing the event queue management procedures.
*/
typedef struct TestEvent {
Tcl_Event header; /* Header common to all events */
Tcl_Interp* interp; /* Interpreter that will handle the event */
Tcl_Obj* command; /* Command to evaluate when the event occurs */
Tcl_Obj* tag; /* Tag for this event used to delete it */
} TestEvent;
/*
* Forward declarations for procedures defined later in this file:
*/
int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int code));
static void CleanupTestSetassocdataTests _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
static int CmdProc1 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static int CmdProc2 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static void CmdTraceDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *cmdProc,
ClientData cmdClientData, int argc,
char **argv));
static void CmdTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, char *command,
Tcl_CmdProc *cmdProc, ClientData cmdClientData,
int argc, char **argv));
static int CreatedCommandProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int argc, CONST char **argv));
static int CreatedCommandProc2 _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int argc, CONST char **argv));
static void DelCallbackProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp));
static int DelCmdProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static void DelDeleteProc _ANSI_ARGS_((ClientData clientData));
static void EncodingFreeProc _ANSI_ARGS_((ClientData clientData));
static int EncodingToUtfProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static int EncodingFromUtfProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static void ExitProcEven _ANSI_ARGS_((ClientData clientData));
static void ExitProcOdd _ANSI_ARGS_((ClientData clientData));
static int GetTimesCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static void MainLoop _ANSI_ARGS_((void));
static int NoopCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static int NoopObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int ObjTraceProc _ANSI_ARGS_(( ClientData clientData,
Tcl_Interp* interp,
int level,
CONST char* command,
Tcl_Command commandToken,
int objc,
Tcl_Obj *CONST objv[] ));
static void ObjTraceDeleteProc _ANSI_ARGS_(( ClientData ));
static void PrintParse _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr));
static void SpecialFree _ANSI_ARGS_((char *blockPtr));
static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int PretendTclpAccess _ANSI_ARGS_((CONST char *path,
int mode));
static int TestAccessProc1 _ANSI_ARGS_((CONST char *path,
int mode));
static int TestAccessProc2 _ANSI_ARGS_((CONST char *path,
int mode));
static int TestAccessProc3 _ANSI_ARGS_((CONST char *path,
int mode));
static int TestasyncCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdcallCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdelCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdstringCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestencodingObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestevalexObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TesteventObjCmd _ANSI_ARGS_((ClientData unused,
Tcl_Interp* interp,
int argc,
Tcl_Obj *CONST objv[]));
static int TesteventProc _ANSI_ARGS_((Tcl_Event* event,
int flags));
static int TesteventDeleteProc _ANSI_ARGS_((
Tcl_Event* event,
ClientData clientData));
static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestexprlongobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestfileCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int TestfilelinkCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int TestfeventCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetvarfullnameCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestlinkCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestlocaleCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestMathFunc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args,
Tcl_Value *resultPtr));
static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args,
Tcl_Value *resultPtr));
static int TestmainthreadCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static Tcl_Channel PretendTclpOpenFileChannel _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *fileName,
CONST char *modeString, int permissions));
static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *fileName,
CONST char *modeString, int permissions));
static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *fileName,
CONST char *modeString, int permissions));
static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *fileName,
CONST char *modeString, int permissions));
static int TestpanicCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestparsevarObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static void TestregexpXflags _ANSI_ARGS_((char *string,
int length, int *cflagsPtr, int *eflagsPtr));
static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr));
static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestsetCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestseterrorcodeCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestsetobjerrorcodeCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int TestopenfilechannelprocCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp, int argc,
CONST char **argv));
static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int PretendTclpStat _ANSI_ARGS_((CONST char *path,
Tcl_StatBuf *buf));
static int TestStatProc1 _ANSI_ARGS_((CONST char *path,
Tcl_StatBuf *buf));
static int TestStatProc2 _ANSI_ARGS_((CONST char *path,
Tcl_StatBuf *buf));
static int TestStatProc3 _ANSI_ARGS_((CONST char *path,
Tcl_StatBuf *buf));
static int TeststatprocCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestupvarCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestWrongNumArgsObjCmd _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int TestGetIndexFromObjStructObjCmd _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int TestChannelCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
/* Filesystem testing */
static int TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestSimpleFilesystemObjCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static void TestReport _ANSI_ARGS_ ((CONST char* cmd, Tcl_Obj* arg1,
Tcl_Obj* arg2));
static Tcl_Obj* TestReportGetNativePath _ANSI_ARGS_ ((
Tcl_Obj* pathObjPtr));
static int TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path,
Tcl_StatBuf *buf));
static int TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path,
int mode));
static Tcl_Channel TestReportOpenFileChannel _ANSI_ARGS_ ((
Tcl_Interp *interp, Tcl_Obj *fileName,
int mode, int permissions));
static int TestReportMatchInDirectory _ANSI_ARGS_ ((
Tcl_Interp *interp, Tcl_Obj *resultPtr,
Tcl_Obj *dirPtr, CONST char *pattern,
Tcl_GlobTypeData *types));
static int TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName));
static int TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path,
Tcl_StatBuf *buf));
static int TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src,
Tcl_Obj *dst));
static int TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path));
static int TestReportRenameFile _ANSI_ARGS_ ((Tcl_Obj *src,
Tcl_Obj *dst));
static int TestReportCreateDirectory _ANSI_ARGS_ ((Tcl_Obj *path));
static int TestReportCopyDirectory _ANSI_ARGS_ ((Tcl_Obj *src,
Tcl_Obj *dst, Tcl_Obj **errorPtr));
static int TestReportRemoveDirectory _ANSI_ARGS_ ((Tcl_Obj *path,
int recursive, Tcl_Obj **errorPtr));
static int TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp,
Tcl_Obj *fileName,
Tcl_LoadHandle *handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr));
static Tcl_Obj * TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path,
Tcl_Obj *to, int linkType));
static CONST char** TestReportFileAttrStrings _ANSI_ARGS_ ((
Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
static int TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp,
int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
static int TestReportFileAttrsSet _ANSI_ARGS_ ((Tcl_Interp *interp,
int index, Tcl_Obj *fileName, Tcl_Obj *objPtr));
static int TestReportUtime _ANSI_ARGS_ ((Tcl_Obj *fileName,
struct utimbuf *tval));
static int TestReportNormalizePath _ANSI_ARGS_ ((
Tcl_Interp *interp, Tcl_Obj *pathPtr,
int nextCheckpoint));
static int TestReportInFilesystem _ANSI_ARGS_ ((Tcl_Obj *pathPtr, ClientData *clientDataPtr));
static void TestReportFreeInternalRep _ANSI_ARGS_ ((ClientData clientData));
static ClientData TestReportDupInternalRep _ANSI_ARGS_ ((ClientData clientData));
static int SimpleStat _ANSI_ARGS_ ((Tcl_Obj *path,
Tcl_StatBuf *buf));
static int SimpleAccess _ANSI_ARGS_ ((Tcl_Obj *path,
int mode));
static Tcl_Channel SimpleOpenFileChannel _ANSI_ARGS_ ((
Tcl_Interp *interp, Tcl_Obj *fileName,
int mode, int permissions));
static Tcl_Obj* SimpleListVolumes _ANSI_ARGS_ ((void));
static int SimplePathInFilesystem _ANSI_ARGS_ ((
Tcl_Obj *pathPtr, ClientData *clientDataPtr));
static Tcl_Obj* SimpleCopy _ANSI_ARGS_ ((Tcl_Obj *pathPtr));
static int TestNumUtfCharsCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
#if defined(HAVE_CPUID) || defined(__WIN32__)
static int TestcpuidCmd _ANSI_ARGS_(( ClientData dummy,
Tcl_Interp* interp,
int objc,
Tcl_Obj *CONST objv[] ));
#endif
static Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
&TestReportInFilesystem, /* path in */
&TestReportDupInternalRep,
&TestReportFreeInternalRep,
NULL, /* native to norm */
NULL, /* convert to native */
&TestReportNormalizePath,
NULL, /* path type */
NULL, /* separator */
&TestReportStat,
&TestReportAccess,
&TestReportOpenFileChannel,
&TestReportMatchInDirectory,
&TestReportUtime,
&TestReportLink,
NULL /* list volumes */,
&TestReportFileAttrStrings,
&TestReportFileAttrsGet,
&TestReportFileAttrsSet,
&TestReportCreateDirectory,
&TestReportRemoveDirectory,
&TestReportDeleteFile,
&TestReportCopyFile,
&TestReportRenameFile,
&TestReportCopyDirectory,
&TestReportLstat,
(Tcl_FSLoadFileProc *) &TestReportLoadFile,
NULL /* cwd */,
&TestReportChdir
};
static Tcl_Filesystem simpleFilesystem = {
"simple",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
&SimplePathInFilesystem,
NULL,
NULL,
/* No internal to normalized, since we don't create any
* pure 'internal' Tcl_Obj path representations */
NULL,
/* No create native rep function, since we don't use it
* or 'Tcl_FSNewNativePath' */
NULL,
/* Normalize path isn't needed - we assume paths only have
* one representation */
NULL,
NULL,
NULL,
&SimpleStat,
&SimpleAccess,
&SimpleOpenFileChannel,
NULL,
NULL,
/* We choose not to support symbolic links inside our vfs's */
NULL,
&SimpleListVolumes,
NULL,
NULL,
NULL,
NULL,
NULL,
NULL,
/* No copy file - fallback will occur at Tcl level */
NULL,
/* No rename file - fallback will occur at Tcl level */
NULL,
/* No copy directory - fallback will occur at Tcl level */
NULL,
/* Use stat for lstat */
NULL,
/* No load - fallback on core implementation */
NULL,
/* We don't need a getcwd or chdir - fallback on Tcl's versions */
NULL,
NULL
};
/*
* External (platform specific) initialization routine, these declarations
* explicitly don't use EXTERN since this code does not get compiled
* into the library:
*/
extern int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
/*
*----------------------------------------------------------------------
*
* Tcltest_Init --
*
* This procedure performs application-specific initialization.
* Most applications, especially those that incorporate additional
* packages, will have their own version of this procedure.
*
* Results:
* Returns a standard Tcl completion code, and leaves an error
* message in the interp's result if an error occurs.
*
* Side effects:
* Depends on the startup script.
*
*----------------------------------------------------------------------
*/
int
Tcltest_Init(interp)
Tcl_Interp *interp; /* Interpreter for application. */
{
Tcl_ValueType t3ArgTypes[2];
Tcl_Obj *listPtr;
Tcl_Obj **objv;
int objc, index;
static CONST char *specialOptions[] = {
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL
};
#ifndef TCL_TIP268
if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) {
#else
/* TIP #268: Full patchlevel instead of just major.minor */
if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) {
#endif
return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
TestGetIndexFromObjStructObjCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_DStringInit(&dstring);
Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
TestgetvarfullnameCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testopenfilechannelproc",
TestopenfilechannelprocCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
(ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
TestsetobjerrorcodeCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc,
(ClientData) 123);
Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc,
(ClientData) 345);
Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
#if defined(HAVE_CPUID) || defined(__WIN32__)
Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
(ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
#endif
t3ArgTypes[0] = TCL_EITHER;
t3ArgTypes[1] = TCL_EITHER;
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
(ClientData) 0);
#ifdef TCL_THREADS
if (TclThread_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
#endif
/*
* Check for special options used in ../tests/main.test
*/
listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY);
if (listPtr != NULL) {
if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL,
TCL_EXACT, &index) == TCL_OK)) {
switch (index) {
case 0: {
return TCL_ERROR;
}
case 1: {
Tcl_DeleteInterp(interp);
return TCL_ERROR;
}
case 2: {
int mode;
Tcl_UnregisterChannel(interp,
Tcl_GetChannel(interp, "stderr", &mode));
return TCL_ERROR;
}
case 3: {
if (objc-1) {
Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL,
objv[1], TCL_GLOBAL_ONLY);
}
return TCL_ERROR;
}
}
}
}
/*
* And finally add any platform specific test commands.
*/
return TclplatformtestInit(interp);
}
/*
*----------------------------------------------------------------------
*
* TestasyncCmd --
*
* This procedure implements the "testasync" command. It is used
* to test the asynchronous handler facilities of Tcl.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates, deletes, and invokes handlers.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestasyncCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
char buf[TCL_INTEGER_SPACE];
if (argc < 2) {
wrongNumArgs:
Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
if (argc != 3) {
goto wrongNumArgs;
}
asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler));
asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1));
strcpy(asyncPtr->command, argv[2]);
Tcl_MutexLock(&asyncTestMutex);
asyncPtr->id = nextId;
nextId++;
asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
(ClientData) asyncPtr->id);
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
TclFormatInt(buf, asyncPtr->id);
Tcl_MutexUnlock(&asyncTestMutex);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(argv[1], "delete") == 0) {
if (argc == 2) {
Tcl_MutexLock(&asyncTestMutex);
while (firstHandler != NULL) {
asyncPtr = firstHandler;
firstHandler = asyncPtr->nextPtr;
Tcl_AsyncDelete(asyncPtr->handler);
ckfree(asyncPtr->command);
ckfree((char *) asyncPtr);
}
Tcl_MutexUnlock(&asyncTestMutex);
return TCL_OK;
}
if (argc != 3) {
goto wrongNumArgs;
}
if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
Tcl_MutexLock(&asyncTestMutex);
for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL;
prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id != id) {
continue;
}
if (prevPtr == NULL) {
firstHandler = asyncPtr->nextPtr;
} else {
prevPtr->nextPtr = asyncPtr->nextPtr;
}
Tcl_AsyncDelete(asyncPtr->handler);
ckfree(asyncPtr->command);
ckfree((char *) asyncPtr);
break;
}
Tcl_MutexUnlock(&asyncTestMutex);
} else if (strcmp(argv[1], "mark") == 0) {
if (argc != 5) {
goto wrongNumArgs;
}
if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK)
|| (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_AsyncMark(asyncPtr->handler);
break;
}
}
Tcl_MutexUnlock(&asyncTestMutex);
Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE);
return code;
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, int, or mark",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
AsyncHandlerProc(clientData, interp, code)
ClientData clientData; /* Id of TestAsyncHandler structure.
* in global list. */
Tcl_Interp *interp; /* Interpreter in which command was
* executed, or NULL. */
int code; /* Current return code from command. */
{
TestAsyncHandler *asyncPtr;
int id = (int)clientData;
CONST char *listArgv[4], *cmd;
char string[TCL_INTEGER_SPACE];
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) break;
}
Tcl_MutexUnlock(&asyncTestMutex);
if (!asyncPtr) {
/* Woops - this one was deleted between the AsyncMark and now */
return TCL_OK;
}
TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp));
listArgv[2] = string;
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
if (interp != NULL) {
code = Tcl_Eval(interp, cmd);
} else {
/*
* this should not happen, but by definition of how async
* handlers are invoked, it's possible. Better error
* checking is needed here.
*/
}
ckfree((char *)cmd);
return code;
}
/*
*----------------------------------------------------------------------
*
* TestcmdinfoCmd --
*
* This procedure implements the "testcmdinfo" command. It is used
* to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation
* and deletion.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes various commands and modifies their data.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestcmdinfoCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_CmdInfo info;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option cmdName\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
CmdDelProc1);
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DStringInit(&delString);
Tcl_DeleteCommand(interp, argv[2]);
Tcl_DStringResult(interp, &delString);
} else if (strcmp(argv[1], "get") == 0) {
if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) {
Tcl_SetResult(interp, "??", TCL_STATIC);
return TCL_OK;
}
if (info.proc == CmdProc1) {
Tcl_AppendResult(interp, "CmdProc1", " ",
(char *) info.clientData, (char *) NULL);
} else if (info.proc == CmdProc2) {
Tcl_AppendResult(interp, "CmdProc2", " ",
(char *) info.clientData, (char *) NULL);
} else {
Tcl_AppendResult(interp, "unknown", (char *) NULL);
}
if (info.deleteProc == CmdDelProc1) {
Tcl_AppendResult(interp, " CmdDelProc1", " ",
(char *) info.deleteData, (char *) NULL);
} else if (info.deleteProc == CmdDelProc2) {
Tcl_AppendResult(interp, " CmdDelProc2", " ",
(char *) info.deleteData, (char *) NULL);
} else {
Tcl_AppendResult(interp, " unknown", (char *) NULL);
}
Tcl_AppendResult(interp, " ", info.namespacePtr->fullName,
(char *) NULL);
if (info.isNativeObjectProc) {
Tcl_AppendResult(interp, " nativeObjectProc", (char *) NULL);
} else {
Tcl_AppendResult(interp, " stringProc", (char *) NULL);
}
} else if (strcmp(argv[1], "modify") == 0) {
info.proc = CmdProc2;
info.clientData = (ClientData) "new_command_data";
info.objProc = NULL;
info.objClientData = (ClientData) NULL;
info.deleteProc = CmdDelProc2;
info.deleteData = (ClientData) "new_delete_data";
if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
Tcl_SetResult(interp, "0", TCL_STATIC);
} else {
Tcl_SetResult(interp, "1", TCL_STATIC);
}
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, get, or modify",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*ARGSUSED*/
static int
CmdProc1(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
(char *) NULL);
return TCL_OK;
}
/*ARGSUSED*/
static int
CmdProc2(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
(char *) NULL);
return TCL_OK;
}
static void
CmdDelProc1(clientData)
ClientData clientData; /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
Tcl_DStringAppend(&delString, (char *) clientData, -1);
}
static void
CmdDelProc2(clientData)
ClientData clientData; /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
Tcl_DStringAppend(&delString, (char *) clientData, -1);
}
/*
*----------------------------------------------------------------------
*
* TestcmdtokenCmd --
*
* This procedure implements the "testcmdtoken" command. It is used
* to test Tcl_Command tokens and procedures such as
* Tcl_GetCommandFullName.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes various commands and modifies their data.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestcmdtokenCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_Command token;
int *l;
char buf[30];
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option arg\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
(ClientData) "original", (Tcl_CmdDeleteProc *) NULL);
sprintf(buf, "%p", (VOID *)token);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(argv[1], "name") == 0) {
Tcl_Obj *objPtr;
if (sscanf(argv[2], "%p", &l) != 1) {
Tcl_AppendResult(interp, "bad command token \"", argv[2],
"\"", (char *) NULL);
return TCL_ERROR;
}
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr);
Tcl_AppendElement(interp,
Tcl_GetCommandName(interp, (Tcl_Command) l));
Tcl_AppendElement(interp, Tcl_GetString(objPtr));
Tcl_DecrRefCount(objPtr);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create or name", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestcmdtraceCmd --
*
* This procedure implements the "testcmdtrace" command. It is used
* to test Tcl_CreateTrace and Tcl_DeleteTrace.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes a command trace, and tests the invocation of
* a procedure by the command trace.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestcmdtraceCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_DString buffer;
int result;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option script\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "tracetest") == 0) {
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, 50000,
(Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
result = Tcl_Eval(interp, argv[2]);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
}
Tcl_DeleteTrace(interp, cmdTrace);
Tcl_DStringFree(&buffer);
} else if (strcmp(argv[1], "deletetest") == 0) {
/*
* Create a command trace then eval a script to check whether it is
* called. Note that this trace procedure removes itself as a
* further check of the robustness of the trace proc calling code in
* TclExecuteByteCode.
*/
cmdTrace = Tcl_CreateTrace(interp, 50000,
(Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
Tcl_Eval(interp, argv[2]);
} else if (strcmp(argv[1], "leveltest") == 0) {
Interp *iPtr = (Interp *) interp;
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4,
(Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
result = Tcl_Eval(interp, argv[2]);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
}
Tcl_DeleteTrace(interp, cmdTrace);
Tcl_DStringFree(&buffer);
} else if ( strcmp(argv[1], "resulttest" ) == 0 ) {
/* Create an object-based trace, then eval a script. This is used
* to test return codes other than TCL_OK from the trace engine.
*/
static int deleteCalled;
deleteCalled = 0;
cmdTrace = Tcl_CreateObjTrace( interp, 50000,
TCL_ALLOW_INLINE_COMPILATION,
ObjTraceProc,
(ClientData) &deleteCalled,
ObjTraceDeleteProc );
result = Tcl_Eval( interp, argv[ 2 ] );
Tcl_DeleteTrace( interp, cmdTrace );
if ( !deleteCalled ) {
Tcl_SetResult( interp, "Delete wasn't called", TCL_STATIC );
return TCL_ERROR;
} else {
return result;
}
} else if ( strcmp(argv[1], "doubletest" ) == 0 ) {
Tcl_Trace t1, t2;
Tcl_DStringInit(&buffer);
t1 = Tcl_CreateTrace(interp, 1,
(Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
t2 = Tcl_CreateTrace(interp, 50000,
(Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
result = Tcl_Eval(interp, argv[2]);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
}
Tcl_DeleteTrace(interp, t2);
Tcl_DeleteTrace(interp, t1);
Tcl_DStringFree(&buffer);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be tracetest, deletetest, doubletest or resulttest",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static void
CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData,
argc, argv)
ClientData clientData; /* Pointer to buffer in which the
* command and arguments are appended.
* Accumulates test result. */
Tcl_Interp *interp; /* Current interpreter. */
int level; /* Current trace level. */
char *command; /* The command being traced (after
* substitutions). */
Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */
ClientData cmdClientData; /* Client data associated with command
* procedure. */
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
Tcl_DString *bufPtr = (Tcl_DString *) clientData;
int i;
Tcl_DStringAppendElement(bufPtr, command);
Tcl_DStringStartSublist(bufPtr);
for (i = 0; i < argc; i++) {
Tcl_DStringAppendElement(bufPtr, argv[i]);
}
Tcl_DStringEndSublist(bufPtr);
}
static void
CmdTraceDeleteProc(clientData, interp, level, command, cmdProc,
cmdClientData, argc, argv)
ClientData clientData; /* Unused. */
Tcl_Interp *interp; /* Current interpreter. */
int level; /* Current trace level. */
char *command; /* The command being traced (after
* substitutions). */
Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */
ClientData cmdClientData; /* Client data associated with command
* procedure. */
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
/*
* Remove ourselves to test whether calling Tcl_DeleteTrace within
* a trace callback causes the for loop in TclExecuteByteCode that
* calls traces to reference freed memory.
*/
Tcl_DeleteTrace(interp, cmdTrace);
}
static int
ObjTraceProc( clientData, interp, level, command, token, objc, objv )
ClientData clientData; /* unused */
Tcl_Interp* interp; /* Tcl interpreter */
int level; /* Execution level */
CONST char* command; /* Command being executed */
Tcl_Command token; /* Command information */
int objc; /* Parameter count */
Tcl_Obj *CONST objv[]; /* Parameter list */
{
CONST char* word = Tcl_GetString( objv[ 0 ] );
if ( !strcmp( word, "Error" ) ) {
Tcl_SetObjResult( interp, Tcl_NewStringObj( command, -1 ) );
return TCL_ERROR;
} else if ( !strcmp( word, "Break" ) ) {
return TCL_BREAK;
} else if ( !strcmp( word, "Continue" ) ) {
return TCL_CONTINUE;
} else if ( !strcmp( word, "Return" ) ) {
return TCL_RETURN;
} else if ( !strcmp( word, "OtherStatus" ) ) {
return 6;
} else {
return TCL_OK;
}
}
static void
ObjTraceDeleteProc( clientData )
ClientData clientData;
{
int * intPtr = (int *) clientData;
*intPtr = 1; /* Record that the trace was deleted */
}
/*
*----------------------------------------------------------------------
*
* TestcreatecommandCmd --
*
* This procedure implements the "testcreatecommand" command. It is
* used to test that the Tcl_CreateCommand creates a new command in
* the namespace specified as part of its name, if any. It also
* checks that the namespace code ignore single ":"s in the middle
* or end of a command name.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes two commands ("test_ns_basic::createdcommand"
* and "value:at:").
*
*----------------------------------------------------------------------
*/
static int
TestcreatecommandCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
Tcl_CreateCommand(interp, "test_ns_basic::createdcommand",
CreatedCommandProc, (ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DeleteCommand(interp, "test_ns_basic::createdcommand");
} else if (strcmp(argv[1], "create2") == 0) {
Tcl_CreateCommand(interp, "value:at:",
CreatedCommandProc2, (ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
} else if (strcmp(argv[1], "delete2") == 0) {
Tcl_DeleteCommand(interp, "value:at:");
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, create2, or delete2",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
CreatedCommandProc(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_CmdInfo info;
int found;
found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand",
&info);
if (!found) {
Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand",
(char *) NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, "CreatedCommandProc in ",
info.namespacePtr->fullName, (char *) NULL);
return TCL_OK;
}
static int
CreatedCommandProc2(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_CmdInfo info;
int found;
found = Tcl_GetCommandInfo(interp, "value:at:", &info);
if (!found) {
Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand",
(char *) NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, "CreatedCommandProc2 in ",
info.namespacePtr->fullName, (char *) NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestdcallCmd --
*
* This procedure implements the "testdcall" command. It is used
* to test Tcl_CallWhenDeleted.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes interpreters.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestdcallCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int i, id;
delInterp = Tcl_CreateInterp();
Tcl_DStringInit(&delString);
for (i = 1; i < argc; i++) {
if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) {
return TCL_ERROR;
}
if (id < 0) {
Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
(ClientData) (-id));
} else {
Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
(ClientData) id);
}
}
Tcl_DeleteInterp(delInterp);
Tcl_DStringResult(interp, &delString);
return TCL_OK;
}
/*
* The deletion callback used by TestdcallCmd:
*/
static void
DelCallbackProc(clientData, interp)
ClientData clientData; /* Numerical value to append to
* delString. */
Tcl_Interp *interp; /* Interpreter being deleted. */
{
int id = (int) clientData;
char buffer[TCL_INTEGER_SPACE];
TclFormatInt(buffer, id);
Tcl_DStringAppendElement(&delString, buffer);
if (interp != delInterp) {
Tcl_DStringAppendElement(&delString, "bogus interpreter argument!");
}
}
/*
*----------------------------------------------------------------------
*
* TestdelCmd --
*
* This procedure implements the "testdcall" command. It is used
* to test Tcl_CallWhenDeleted.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes interpreters.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestdelCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
DelCmd *dPtr;
Tcl_Interp *slave;
if (argc != 4) {
Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
return TCL_ERROR;
}
slave = Tcl_GetSlave(interp, argv[1]);
if (slave == NULL) {
return TCL_ERROR;
}
dPtr = (DelCmd *) ckalloc(sizeof(DelCmd));
dPtr->interp = interp;
dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1));
strcpy(dPtr->deleteCmd, argv[3]);
Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr,
DelDeleteProc);
return TCL_OK;
}
static int
DelCmdProc(clientData, interp, argc, argv)
ClientData clientData; /* String result to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
DelCmd *dPtr = (DelCmd *) clientData;
Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL);
ckfree(dPtr->deleteCmd);
ckfree((char *) dPtr);
return TCL_OK;
}
static void
DelDeleteProc(clientData)
ClientData clientData; /* String command to evaluate. */
{
DelCmd *dPtr = (DelCmd *) clientData;
Tcl_Eval(dPtr->interp, dPtr->deleteCmd);
Tcl_ResetResult(dPtr->interp);
ckfree(dPtr->deleteCmd);
ckfree((char *) dPtr);
}
/*
*----------------------------------------------------------------------
*
* TestdelassocdataCmd --
*
* This procedure implements the "testdelassocdata" command. It is used
* to test Tcl_DeleteAssocData.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Deletes an association between a key and associated data from an
* interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestdelassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_DeleteAssocData(interp, argv[1]);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestdstringCmd --
*
* This procedure implements the "testdstring" command. It is used
* to test the dynamic string facilities of Tcl.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates, deletes, and invokes handlers.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestdstringCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int count;
if (argc < 2) {
wrongNumArgs:
Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
return TCL_ERROR;
}
if (strcmp(argv[1], "append") == 0) {
if (argc != 4) {
goto wrongNumArgs;
}
if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) {
return TCL_ERROR;
}
Tcl_DStringAppend(&dstring, argv[2], count);
} else if (strcmp(argv[1], "element") == 0) {
if (argc != 3) {
goto wrongNumArgs;
}
Tcl_DStringAppendElement(&dstring, argv[2]);
} else if (strcmp(argv[1], "end") == 0) {
if (argc != 2) {
goto wrongNumArgs;
}
Tcl_DStringEndSublist(&dstring);
} else if (strcmp(argv[1], "free") == 0) {
if (argc != 2) {
goto wrongNumArgs;
}
Tcl_DStringFree(&dstring);
} else if (strcmp(argv[1], "get") == 0) {
if (argc != 2) {
goto wrongNumArgs;
}
Tcl_SetResult(interp, Tcl_DStringValue(&dstring), TCL_VOLATILE);
} else if (strcmp(argv[1], "gresult") == 0) {
if (argc != 3) {
goto wrongNumArgs;
}
if (strcmp(argv[2], "staticsmall") == 0) {
Tcl_SetResult(interp, "short", TCL_STATIC);
} else if (strcmp(argv[2], "staticlarge") == 0) {
Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC);
} else if (strcmp(argv[2], "free") == 0) {
Tcl_SetResult(interp, (char *) ckalloc(100), TCL_DYNAMIC);
strcpy(interp->result, "This is a malloc-ed string");
} else if (strcmp(argv[2], "special") == 0) {
interp->result = (char *) ckalloc(100);
interp->result += 4;
interp->freeProc = SpecialFree;
strcpy(interp->result, "This is a specially-allocated string");
} else {
Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
"\": must be staticsmall, staticlarge, free, or special",
(char *) NULL);
return TCL_ERROR;
}
Tcl_DStringGetResult(interp, &dstring);
} else if (strcmp(argv[1], "length") == 0) {
char buf[TCL_INTEGER_SPACE];
if (argc != 2) {
goto wrongNumArgs;
}
TclFormatInt(buf, Tcl_DStringLength(&dstring));
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(argv[1], "result") == 0) {
if (argc != 2) {
goto wrongNumArgs;
}
Tcl_DStringResult(interp, &dstring);
} else if (strcmp(argv[1], "trunc") == 0) {
if (argc != 3) {
goto wrongNumArgs;
}
if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
return TCL_ERROR;
}
Tcl_DStringTrunc(&dstring, count);
} else if (strcmp(argv[1], "start") == 0) {
if (argc != 2) {
goto wrongNumArgs;
}
Tcl_DStringStartSublist(&dstring);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be append, element, end, free, get, length, ",
"result, trunc, or start", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
* The procedure below is used as a special freeProc to test how well
* Tcl_DStringGetResult handles freeProc's other than free.
*/
static void SpecialFree(blockPtr)
char *blockPtr; /* Block to free. */
{
ckfree(blockPtr - 4);
}
/*
*----------------------------------------------------------------------
*
* TestencodingCmd --
*
* This procedure implements the "testencoding" command. It is used
* to test the encoding package.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Load encodings.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestencodingObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Encoding encoding;
int index, length;
char *string;
TclEncoding *encodingPtr;
static CONST char *optionStrings[] = {
"create", "delete", "path",
NULL
};
enum options {
ENC_CREATE, ENC_DELETE, ENC_PATH
};
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case ENC_CREATE: {
Tcl_EncodingType type;
if (objc != 5) {
return TCL_ERROR;
}
encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding));
encodingPtr->interp = interp;
string = Tcl_GetStringFromObj(objv[3], &length);
encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1));
memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1);
string = Tcl_GetStringFromObj(objv[4], &length);
encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1));
memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1));
string = Tcl_GetStringFromObj(objv[2], &length);
type.encodingName = string;
type.toUtfProc = EncodingToUtfProc;
type.fromUtfProc = EncodingFromUtfProc;
type.freeProc = EncodingFreeProc;
type.clientData = (ClientData) encodingPtr;
type.nullSize = 1;
Tcl_CreateEncoding(&type);
break;
}
case ENC_DELETE: {
if (objc != 3) {
return TCL_ERROR;
}
encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));
Tcl_FreeEncoding(encoding);
Tcl_FreeEncoding(encoding);
break;
}
case ENC_PATH: {
if (objc == 2) {
Tcl_SetObjResult(interp, TclGetLibraryPath());
} else {
TclSetLibraryPath(objv[2]);
}
break;
}
}
return TCL_OK;
}
static int
EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* TclEncoding structure. */
CONST char *src; /* Source string in specified encoding. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Current state. */
char *dst; /* Output buffer. */
int dstLen; /* The maximum length of output buffer. */
int *srcReadPtr; /* Filled with number of bytes read. */
int *dstWrotePtr; /* Filled with number of bytes stored. */
int *dstCharsPtr; /* Filled with number of chars stored. */
{
int len;
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
len = dstLen;
}
memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
Tcl_ResetResult(encodingPtr->interp);
*srcReadPtr = srcLen;
*dstWrotePtr = len;
*dstCharsPtr = len;
return TCL_OK;
}
static int
EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* TclEncoding structure. */
CONST char *src; /* Source string in specified encoding. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Current state. */
char *dst; /* Output buffer. */
int dstLen; /* The maximum length of output buffer. */
int *srcReadPtr; /* Filled with number of bytes read. */
int *dstWrotePtr; /* Filled with number of bytes stored. */
int *dstCharsPtr; /* Filled with number of chars stored. */
{
int len;
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
len = dstLen;
}
memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
Tcl_ResetResult(encodingPtr->interp);
*srcReadPtr = srcLen;
*dstWrotePtr = len;
*dstCharsPtr = len;
return TCL_OK;
}
static void
EncodingFreeProc(clientData)
ClientData clientData; /* ClientData associated with type. */
{
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
ckfree((char *) encodingPtr->toUtfCmd);
ckfree((char *) encodingPtr->fromUtfCmd);
ckfree((char *) encodingPtr);
}
/*
*----------------------------------------------------------------------
*
* TestevalexObjCmd --
*
* This procedure implements the "testevalex" command. It is
* used to test Tcl_EvalEx.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalexObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
int code, oldFlags, length, flags;
char *string;
if (objc == 1) {
/*
* The command was invoked with no arguments, so just toggle
* the flag that determines whether we use Tcl_EvalEx.
*/
if (iPtr->flags & USE_EVAL_DIRECT) {
iPtr->flags &= ~USE_EVAL_DIRECT;
Tcl_SetResult(interp, "disabling direct evaluation", TCL_STATIC);
} else {
iPtr->flags |= USE_EVAL_DIRECT;
Tcl_SetResult(interp, "enabling direct evaluation", TCL_STATIC);
}
return TCL_OK;
}
flags = 0;
if (objc == 3) {
string = Tcl_GetStringFromObj(objv[2], &length);
if (strcmp(string, "global") != 0) {
Tcl_AppendResult(interp, "bad value \"", string,
"\": must be global", (char *) NULL);
return TCL_ERROR;
}
flags = TCL_EVAL_GLOBAL;
} else if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "script ?global?");
return TCL_ERROR;
}
Tcl_SetResult(interp, "xxx", TCL_STATIC);
/*
* Note, we have to set the USE_EVAL_DIRECT flag in the interpreter
* in addition to calling Tcl_EvalEx. This is needed so that even nested
* commands are evaluated directly.
*/
oldFlags = iPtr->flags;
iPtr->flags |= USE_EVAL_DIRECT;
string = Tcl_GetStringFromObj(objv[1], &length);
code = Tcl_EvalEx(interp, string, length, flags);
iPtr->flags = (iPtr->flags & ~USE_EVAL_DIRECT)
| (oldFlags & USE_EVAL_DIRECT);
return code;
}
/*
*----------------------------------------------------------------------
*
* TestevalobjvObjCmd --
*
* This procedure implements the "testevalobjv" command. It is
* used to test Tcl_EvalObjv.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalobjvObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int evalGlobal;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_EvalObjv(interp, objc-2, objv+2,
(evalGlobal) ? TCL_EVAL_GLOBAL : 0);
}
/*
*----------------------------------------------------------------------
*
* TesteventObjCmd --
*
* This procedure implements a 'testevent' command. The command
* is used to test event queue management.
*
* The command takes two forms:
* - testevent queue name position script
* Queues an event at the given position in the queue, and
* associates a given name with it (the same name may be
* associated with multiple events). When the event comes
* to the head of the queue, executes the given script at
* global level in the current interp. The position may be
* one of 'head', 'tail' or 'mark'.
* - testevent delete name
* Deletes any events associated with the given name from
* the queue.
*
* Return value:
* Returns a standard Tcl result.
*
* Side effects:
* Manipulates the event queue as directed.
*
*----------------------------------------------------------------------
*/
static int
TesteventObjCmd( ClientData unused, /* Not used */
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *CONST objv[] ) /* Parameter vector */
{
static CONST char* subcommands[] = { /* Possible subcommands */
"queue",
"delete",
NULL
};
int subCmdIndex; /* Index of the chosen subcommand */
static CONST char* positions[] = { /* Possible queue positions */
"head",
"tail",
"mark",
NULL
};
int posIndex; /* Index of the chosen position */
static CONST Tcl_QueuePosition posNum[] = {
/* Interpretation of the chosen position */
TCL_QUEUE_HEAD,
TCL_QUEUE_TAIL,
TCL_QUEUE_MARK
};
TestEvent* ev; /* Event to be queued */
if ( objc < 2 ) {
Tcl_WrongNumArgs( interp, 1, objv, "subcommand ?args?" );
return TCL_ERROR;
}
if ( Tcl_GetIndexFromObj( interp, objv[1], subcommands, "subcommand",
TCL_EXACT, &subCmdIndex ) != TCL_OK ) {
return TCL_ERROR;
}
switch ( subCmdIndex ) {
case 0: /* queue */
if ( objc != 5 ) {
Tcl_WrongNumArgs( interp, 2, objv, "name position script" );
return TCL_ERROR;
}
if ( Tcl_GetIndexFromObj( interp, objv[3], positions,
"position specifier", TCL_EXACT,
&posIndex ) != TCL_OK ) {
return TCL_ERROR;
}
ev = (TestEvent*) ckalloc( sizeof( TestEvent ) );
ev->header.proc = TesteventProc;
ev->header.nextPtr = NULL;
ev->interp = interp;
ev->command = objv[ 4 ];
Tcl_IncrRefCount( ev->command );
ev->tag = objv[ 2 ];
Tcl_IncrRefCount( ev->tag );
Tcl_QueueEvent( (Tcl_Event*) ev, posNum[ posIndex ] );
break;
case 1: /* delete */
if ( objc != 3 ) {
Tcl_WrongNumArgs( interp, 2, objv, "name" );
return TCL_ERROR;
}
Tcl_DeleteEvents( TesteventDeleteProc, objv[ 2 ] );
break;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TesteventProc --
*
* Delivers a test event to the Tcl interpreter as part of event
* queue testing.
*
* Results:
* Returns 1 if the event has been serviced, 0 otherwise.
*
* Side effects:
* Evaluates the event's callback script, so has whatever
* side effects the callback has. The return value of the
* callback script becomes the return value of this function.
* If the callback script reports an error, it is reported as
* a background error.
*
*----------------------------------------------------------------------
*/
static int
TesteventProc( Tcl_Event* event, /* Event to deliver */
int flags ) /* Current flags for Tcl_ServiceEvent */
{
TestEvent * ev = (TestEvent *) event;
Tcl_Interp* interp = ev->interp;
Tcl_Obj* command = ev->command;
int result = Tcl_EvalObjEx( interp, command,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT );
int retval;
if ( result != TCL_OK ) {
Tcl_AddErrorInfo( interp,
" (command bound to \"testevent\" callback)" );
Tcl_BackgroundError( interp );
return 1; /* Avoid looping on errors */
}
if ( Tcl_GetBooleanFromObj( interp,
Tcl_GetObjResult( interp ),
&retval ) != TCL_OK ) {
Tcl_AddErrorInfo( interp,
" (return value from \"testevent\" callback)" );
Tcl_BackgroundError( interp );
return 1;
}
if ( retval ) {
Tcl_DecrRefCount( ev->tag );
Tcl_DecrRefCount( ev->command );
}
return retval;
}
/*
*----------------------------------------------------------------------
*
* TesteventDeleteProc --
*
* Removes some set of events from the queue.
*
* This procedure is used as part of testing event queue management.
*
* Results:
* Returns 1 if a given event should be deleted, 0 otherwise.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TesteventDeleteProc( Tcl_Event* event, /* Event to examine */
ClientData clientData ) /* Tcl_Obj containing the name
* of the event(s) to remove */
{
TestEvent* ev; /* Event to examine */
char* evNameStr;
Tcl_Obj* targetName; /* Name of the event(s) to delete */
char* targetNameStr;
if ( event->proc != TesteventProc ) {
return 0;
}
targetName = (Tcl_Obj*) clientData;
targetNameStr = (char*) Tcl_GetStringFromObj( targetName, NULL );
ev = (TestEvent*) event;
evNameStr = Tcl_GetStringFromObj( ev->tag, NULL );
if ( strcmp( evNameStr, targetNameStr ) == 0 ) {
Tcl_DecrRefCount( ev->tag );
Tcl_DecrRefCount( ev->command );
return 1;
} else {
return 0;
}
}
/*
*----------------------------------------------------------------------
*
* TestexithandlerCmd --
*
* This procedure implements the "testexithandler" command. It is
* used to test Tcl_CreateExitHandler and Tcl_DeleteExitHandler.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexithandlerCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int value;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" create|delete value\"", (char *) NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
(ClientData) value);
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
(ClientData) value);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create or delete", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static void
ExitProcOdd(clientData)
ClientData clientData; /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
sprintf(buf, "odd %d\n", (int) clientData);
write(1, buf, strlen(buf));
}
static void
ExitProcEven(clientData)
ClientData clientData; /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
sprintf(buf, "even %d\n", (int) clientData);
write(1, buf, strlen(buf));
}
/*
*----------------------------------------------------------------------
*
* TestexprlongCmd --
*
* This procedure verifies that Tcl_ExprLong does not modify the
* interpreter result if there is no error.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprlongCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
int result;
Tcl_SetResult(interp, "This is a result", TCL_STATIC);
result = Tcl_ExprLong(interp, "4+1", &exprResult);
if (result != TCL_OK) {
return result;
}
sprintf(buf, ": %ld", exprResult);
Tcl_AppendResult(interp, buf, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexprlongobjCmd --
*
* This procedure verifies that Tcl_ExprLongObj does not modify the
* interpreter result if there is no error.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprlongobjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST *objv; /* Argument objects. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
int result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
Tcl_SetResult(interp, "This is a result", TCL_STATIC);
result = Tcl_ExprLongObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
return result;
}
sprintf(buf, ": %ld", exprResult);
Tcl_AppendResult(interp, buf, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexprstringCmd --
*
* This procedure tests the basic operation of Tcl_ExprString.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprstringCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" expression\"", (char *) NULL);
return TCL_ERROR;
}
return Tcl_ExprString(interp, argv[1]);
}
/*
*----------------------------------------------------------------------
*
* TestfilelinkCmd --
*
* This procedure implements the "testfilelink" command. It is used
* to test the effects of creating and manipulating filesystem links
* in Tcl.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May create a link on disk.
*
*----------------------------------------------------------------------
*/
static int
TestfilelinkCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
Tcl_Obj *contents;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "source ?target?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 3) {
/* Create link from source to target */
contents = Tcl_FSLink(objv[1], objv[2],
TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not create link from \"",
Tcl_GetString(objv[1]), "\" to \"",
Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
} else {
/* Read link */
contents = Tcl_FSLink(objv[1], NULL, 0);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not read link \"",
Tcl_GetString(objv[1]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, contents);
if (objc == 2) {
/*
* If we are creating a link, this will actually just
* be objv[3], and we don't own it
*/
Tcl_DecrRefCount(contents);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestgetassocdataCmd --
*
* This procedure implements the "testgetassocdata" command. It is
* used to test Tcl_GetAssocData.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
char *res;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key\"", (char *) NULL);
return TCL_ERROR;
}
res = (char *) Tcl_GetAssocData(interp, argv[1], NULL);
if (res != NULL) {
Tcl_AppendResult(interp, res, NULL);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestgetplatformCmd --
*
* This procedure implements the "testgetplatform" command. It is
* used to retrievel the value of the tclPlatform global variable.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetplatformCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
static CONST char *platformStrings[] = { "unix", "mac", "windows" };
TclPlatformType *platform;
#if defined(__WIN32__) || defined(__CYGWIN__)
platform = TclWinGetPlatform();
#else
platform = &tclPlatform;
#endif
if (argc != 1) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
(char *) NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, platformStrings[*platform], NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestinterpdeleteCmd --
*
* This procedure tests the code in tclInterp.c that deals with
* interpreter deletion. It deletes a user-specified interpreter
* from the hierarchy, and subsequent code checks integrity.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Deletes one or more interpreters.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestinterpdeleteCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_Interp *slaveToDelete;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" path\"", (char *) NULL);
return TCL_ERROR;
}
slaveToDelete = Tcl_GetSlave(interp, argv[1]);
if (slaveToDelete == (Tcl_Interp *) NULL) {
return TCL_ERROR;
}
Tcl_DeleteInterp(slaveToDelete);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestlinkCmd --
*
* This procedure implements the "testlink" command. It is used
* to test Tcl_LinkVar and related library procedures.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes various variable links, plus returns
* values of the linked variables.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestlinkCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
static int intVar = 43;
static int boolVar = 4;
static double realVar = 1.23;
static Tcl_WideInt wideVar = Tcl_LongAsWide(79);
static char *stringVar = NULL;
static int created = 0;
char buffer[2*TCL_DOUBLE_SPACE];
int writable, flag;
Tcl_Obj *tmp;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option ?arg arg arg arg arg?\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
if (argc != 7) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1],
" intRO realRO boolRO stringRO wideRO\"", (char *) NULL);
return TCL_ERROR;
}
if (created) {
Tcl_UnlinkVar(interp, "int");
Tcl_UnlinkVar(interp, "real");
Tcl_UnlinkVar(interp, "bool");
Tcl_UnlinkVar(interp, "string");
Tcl_UnlinkVar(interp, "wide");
}
created = 1;
if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "int", (char *) &intVar,
TCL_LINK_INT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "real", (char *) &realVar,
TCL_LINK_DOUBLE | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "bool", (char *) &boolVar,
TCL_LINK_BOOLEAN | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "string", (char *) &stringVar,
TCL_LINK_STRING | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "wide", (char *) &wideVar,
TCL_LINK_WIDE_INT | flag) != TCL_OK) {
return TCL_ERROR;
}
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_UnlinkVar(interp, "int");
Tcl_UnlinkVar(interp, "real");
Tcl_UnlinkVar(interp, "bool");
Tcl_UnlinkVar(interp, "string");
Tcl_UnlinkVar(interp, "wide");
created = 0;
} else if (strcmp(argv[1], "get") == 0) {
TclFormatInt(buffer, intVar);
Tcl_AppendElement(interp, buffer);
Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer);
Tcl_AppendElement(interp, buffer);
TclFormatInt(buffer, boolVar);
Tcl_AppendElement(interp, buffer);
Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
/*
* Wide ints only have an object-based interface.
*/
tmp = Tcl_NewWideIntObj(wideVar);
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
} else if (strcmp(argv[1], "set") == 0) {
if (argc != 7) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1],
" intValue realValue boolValue stringValue wideValue\"",
(char *) NULL);
return TCL_ERROR;
}
if (argv[2][0] != 0) {
if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (argv[3][0] != 0) {
if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (argv[4][0] != 0) {
if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (argv[5][0] != 0) {
if (stringVar != NULL) {
ckfree(stringVar);
}
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
strcpy(stringVar, argv[5]);
}
}
if (argv[6][0] != 0) {
tmp = Tcl_NewStringObj(argv[6], -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
}
Tcl_DecrRefCount(tmp);
}
} else if (strcmp(argv[1], "update") == 0) {
if (argc != 7) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1],
"intValue realValue boolValue stringValue wideValue\"",
(char *) NULL);
return TCL_ERROR;
}
if (argv[2][0] != 0) {
if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_UpdateLinkedVar(interp, "int");
}
if (argv[3][0] != 0) {
if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_UpdateLinkedVar(interp, "real");
}
if (argv[4][0] != 0) {
if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_UpdateLinkedVar(interp, "bool");
}
if (argv[5][0] != 0) {
if (stringVar != NULL) {
ckfree(stringVar);
}
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
strcpy(stringVar, argv[5]);
}
Tcl_UpdateLinkedVar(interp, "string");
}
if (argv[6][0] != 0) {
tmp = Tcl_NewStringObj(argv[6], -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
}
Tcl_DecrRefCount(tmp);
Tcl_UpdateLinkedVar(interp, "wide");
}
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": should be create, delete, get, set, or update",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestlocaleCmd --
*
* This procedure implements the "testlocale" command. It is used
* to test the effects of setting different locales in Tcl.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Modifies the current C locale.
*
*----------------------------------------------------------------------
*/
static int
TestlocaleCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
int index;
char *locale;
static CONST char *optionStrings[] = {
"ctype", "numeric", "time", "collate", "monetary",
"all", NULL
};
static CONST int lcTypes[] = {
LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
LC_ALL
};
/*
* LC_CTYPE, etc. correspond to the indices for the strings.
*/
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 3) {
locale = Tcl_GetString(objv[2]);
} else {
locale = NULL;
}
locale = setlocale(lcTypes[index], locale);
if (locale) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestMathFunc --
*
* This is a user-defined math procedure to test out math procedures
* with no arguments.
*
* Results:
* A normal Tcl completion code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestMathFunc(clientData, interp, args, resultPtr)
ClientData clientData; /* Integer value to return. */
Tcl_Interp *interp; /* Not used. */
Tcl_Value *args; /* Not used. */
Tcl_Value *resultPtr; /* Where to store result. */
{
resultPtr->type = TCL_INT;
resultPtr->intValue = (int) clientData;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestMathFunc2 --
*
* This is a user-defined math procedure to test out math procedures
* that do have arguments, in this case 2.
*
* Results:
* A normal Tcl completion code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestMathFunc2(clientData, interp, args, resultPtr)
ClientData clientData; /* Integer value to return. */
Tcl_Interp *interp; /* Used to report errors. */
Tcl_Value *args; /* Points to an array of two
* Tcl_Value structs for the
* two arguments. */
Tcl_Value *resultPtr; /* Where to store the result. */
{
int result = TCL_OK;
/*
* Return the maximum of the two arguments with the correct type.
*/
if (args[0].type == TCL_INT) {
int i0 = args[0].intValue;
if (args[1].type == TCL_INT) {
int i1 = args[1].intValue;
resultPtr->type = TCL_INT;
resultPtr->intValue = ((i0 > i1)? i0 : i1);
} else if (args[1].type == TCL_DOUBLE) {
double d0 = i0;
double d1 = args[1].doubleValue;
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
} else if (args[1].type == TCL_WIDE_INT) {
Tcl_WideInt w0 = Tcl_LongAsWide(i0);
Tcl_WideInt w1 = args[1].wideValue;
resultPtr->type = TCL_WIDE_INT;
resultPtr->wideValue = ((w0 > w1)? w0 : w1);
} else {
Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
result = TCL_ERROR;
}
} else if (args[0].type == TCL_DOUBLE) {
double d0 = args[0].doubleValue;
if (args[1].type == TCL_INT) {
double d1 = args[1].intValue;
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
} else if (args[1].type == TCL_DOUBLE) {
double d1 = args[1].doubleValue;
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
} else if (args[1].type == TCL_WIDE_INT) {
double d1 = Tcl_WideAsDouble(args[1].wideValue);
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
} else {
Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
result = TCL_ERROR;
}
} else if (args[0].type == TCL_WIDE_INT) {
Tcl_WideInt w0 = args[0].wideValue;
if (args[1].type == TCL_INT) {
Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue);
resultPtr->type = TCL_WIDE_INT;
resultPtr->wideValue = ((w0 > w1)? w0 : w1);
} else if (args[1].type == TCL_DOUBLE) {
double d0 = Tcl_WideAsDouble(w0);
double d1 = args[1].doubleValue;
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
} else if (args[1].type == TCL_WIDE_INT) {
Tcl_WideInt w1 = args[1].wideValue;
resultPtr->type = TCL_WIDE_INT;
resultPtr->wideValue = ((w0 > w1)? w0 : w1);
} else {
Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
result = TCL_ERROR;
}
} else {
Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC);
result = TCL_ERROR;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* CleanupTestSetassocdataTests --
*
* This function is called when an interpreter is deleted to clean
* up any data left over from running the testsetassocdata command.
*
* Results:
* None.
*
* Side effects:
* Releases storage.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static void
CleanupTestSetassocdataTests(clientData, interp)
ClientData clientData; /* Data to be released. */
Tcl_Interp *interp; /* Interpreter being deleted. */
{
ckfree((char *) clientData);
}
/*
*----------------------------------------------------------------------
*
* TestparserObjCmd --
*
* This procedure implements the "testparser" command. It is
* used for testing the new Tcl script parser in Tcl 8.1.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparserObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
char *script;
int length, dummy;
Tcl_Parse parse;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "script length");
return TCL_ERROR;
}
script = Tcl_GetStringFromObj(objv[1], &dummy);
if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
return TCL_ERROR;
}
if (length == 0) {
length = dummy;
}
if (Tcl_ParseCommand(interp, script, length, 0, &parse) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (remainder of script: \"");
Tcl_AddErrorInfo(interp, parse.term);
Tcl_AddErrorInfo(interp, "\")");
return TCL_ERROR;
}
/*
* The parse completed successfully. Just print out the contents
* of the parse structure into the interpreter's result.
*/
PrintParse(interp, &parse);
Tcl_FreeParse(&parse);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexprparserObjCmd --
*
* This procedure implements the "testexprparser" command. It is
* used for testing the new Tcl expression parser in Tcl 8.1.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprparserObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
char *script;
int length, dummy;
Tcl_Parse parse;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "expr length");
return TCL_ERROR;
}
script = Tcl_GetStringFromObj(objv[1], &dummy);
if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
return TCL_ERROR;
}
if (length == 0) {
length = dummy;
}
if (Tcl_ParseExpr(interp, script, length, &parse) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (remainder of expr: \"");
Tcl_AddErrorInfo(interp, parse.term);
Tcl_AddErrorInfo(interp, "\")");
return TCL_ERROR;
}
/*
* The parse completed successfully. Just print out the contents
* of the parse structure into the interpreter's result.
*/
PrintParse(interp, &parse);
Tcl_FreeParse(&parse);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* PrintParse --
*
* This procedure prints out the contents of a Tcl_Parse structure
* in the result of an interpreter.
*
* Results:
* Interp's result is set to a prettily formatted version of the
* contents of parsePtr.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
PrintParse(interp, parsePtr)
Tcl_Interp *interp; /* Interpreter whose result is to be set to
* the contents of a parse structure. */
Tcl_Parse *parsePtr; /* Parse structure to print out. */
{
Tcl_Obj *objPtr;
char *typeString;
Tcl_Token *tokenPtr;
int i;
objPtr = Tcl_GetObjResult(interp);
if (parsePtr->commentSize > 0) {
Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
Tcl_NewStringObj(parsePtr->commentStart,
parsePtr->commentSize));
} else {
Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
Tcl_NewStringObj("-", 1));
}
Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize));
Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
Tcl_NewIntObj(parsePtr->numWords));
for (i = 0; i < parsePtr->numTokens; i++) {
tokenPtr = &parsePtr->tokenPtr[i];
switch (tokenPtr->type) {
case TCL_TOKEN_WORD:
typeString = "word";
break;
case TCL_TOKEN_SIMPLE_WORD:
typeString = "simple";
break;
case TCL_TOKEN_TEXT:
typeString = "text";
break;
case TCL_TOKEN_BS:
typeString = "backslash";
break;
case TCL_TOKEN_COMMAND:
typeString = "command";
break;
case TCL_TOKEN_VARIABLE:
typeString = "variable";
break;
case TCL_TOKEN_SUB_EXPR:
typeString = "subexpr";
break;
case TCL_TOKEN_OPERATOR:
typeString = "operator";
break;
default:
typeString = "??";
break;
}
Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
Tcl_NewStringObj(typeString, -1));
Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
Tcl_NewIntObj(tokenPtr->numComponents));
}
Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
-1));
}
/*
*----------------------------------------------------------------------
*
* TestparsevarObjCmd --
*
* This procedure implements the "testparsevar" command. It is
* used for testing Tcl_ParseVar.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
CONST char *value;
CONST char *name, *termPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName");
return TCL_ERROR;
}
name = Tcl_GetString(objv[1]);
value = Tcl_ParseVar(interp, name, &termPtr);
if (value == NULL) {
return TCL_ERROR;
}
Tcl_AppendElement(interp, value);
Tcl_AppendElement(interp, termPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestparsevarnameObjCmd --
*
* This procedure implements the "testparsevarname" command. It is
* used for testing the new Tcl script parser in Tcl 8.1.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarnameObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
char *script;
int append, length, dummy;
Tcl_Parse parse;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "script length append");
return TCL_ERROR;
}
script = Tcl_GetStringFromObj(objv[1], &dummy);
if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
return TCL_ERROR;
}
if (length == 0) {
length = dummy;
}
if (Tcl_GetIntFromObj(interp, objv[3], &append)) {
return TCL_ERROR;
}
if (Tcl_ParseVarName(interp, script, length, &parse, append) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (remainder of script: \"");
Tcl_AddErrorInfo(interp, parse.term);
Tcl_AddErrorInfo(interp, "\")");
return TCL_ERROR;
}
/*
* The parse completed successfully. Just print out the contents
* of the parse structure into the interpreter's result.
*/
parse.commentSize = 0;
parse.commandStart = script + parse.tokenPtr->size;
parse.commandSize = 0;
PrintParse(interp, &parse);
Tcl_FreeParse(&parse);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestregexpObjCmd --
*
* This procedure implements the "testregexp" command. It is
* used to give a direct interface for regexp flags. It's identical
* to Tcl_RegexpObjCmd except for the -xflags option, and the
* consequences thereof (including the REG_EXPECT kludge).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestregexpObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, ii, indices, stringLength, match, about;
int hasxflags, cflags, eflags;
Tcl_RegExp regExpr;
char *string;
Tcl_Obj *objPtr;
Tcl_RegExpInfo info;
static CONST char *options[] = {
"-indices", "-nocase", "-about", "-expanded",
"-line", "-linestop", "-lineanchor",
"-xflags",
"--", (char *) NULL
};
enum options {
REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED,
REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL,
REGEXP_XFLAGS,
REGEXP_LAST
};
indices = 0;
about = 0;
cflags = REG_ADVANCED;
eflags = 0;
hasxflags = 0;
for (i = 1; i < objc; i++) {
char *name;
int index;
name = Tcl_GetString(objv[i]);
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case REGEXP_INDICES: {
indices = 1;
break;
}
case REGEXP_NOCASE: {
cflags |= REG_ICASE;
break;
}
case REGEXP_ABOUT: {
about = 1;
break;
}
case REGEXP_EXPANDED: {
cflags |= REG_EXPANDED;
break;
}
case REGEXP_MULTI: {
cflags |= REG_NEWLINE;
break;
}
case REGEXP_NOCROSS: {
cflags |= REG_NLSTOP;
break;
}
case REGEXP_NEWL: {
cflags |= REG_NLANCH;
break;
}
case REGEXP_XFLAGS: {
hasxflags = 1;
break;
}
case REGEXP_LAST: {
i++;
goto endOfForLoop;
}
}
}
endOfForLoop:
if (objc - i < hasxflags + 2 - about) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
return TCL_ERROR;
}
objc -= i;
objv += i;
if (hasxflags) {
string = Tcl_GetStringFromObj(objv[0], &stringLength);
TestregexpXflags(string, stringLength, &cflags, &eflags);
objc--;
objv++;
}
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
objPtr = objv[1];
if (about) {
if (TclRegAbout(interp, regExpr) < 0) {
return TCL_ERROR;
}
return TCL_OK;
}
match = Tcl_RegExpExecObj(interp, regExpr, objPtr, 0 /* offset */,
objc-2 /* nmatches */, eflags);
if (match < 0) {
return TCL_ERROR;
}
if (match == 0) {
/*
* Set the interpreter's object result to an integer object w/
* value 0.
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags®_EXPECT) && indices) {
char *varName;
CONST char *value;
int start, end;
char resinfo[TCL_INTEGER_SPACE * 2];
varName = Tcl_GetString(objv[2]);
TclRegExpRangeUniChar(regExpr, -1, &start, &end);
sprintf(resinfo, "%d %d", start, end-1);
value = Tcl_SetVar(interp, varName, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", (char *) NULL);
return TCL_ERROR;
}
} else if (cflags & TCL_REG_CANMATCH) {
char *varName;
CONST char *value;
char resinfo[TCL_INTEGER_SPACE * 2];
Tcl_RegExpGetInfo(regExpr, &info);
varName = Tcl_GetString(objv[2]);
sprintf(resinfo, "%ld", info.extendStart);
value = Tcl_SetVar(interp, varName, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", (char *) NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
* If additional variable names have been specified, return
* index information in those variables.
*/
objc -= 2;
objv += 2;
Tcl_RegExpGetInfo(regExpr, &info);
for (i = 0; i < objc; i++) {
int start, end;
Tcl_Obj *newPtr, *varPtr, *valuePtr;
varPtr = objv[i];
ii = ((cflags®_EXPECT) && i == objc-1) ? -1 : i;
if (indices) {
Tcl_Obj *objs[2];
if (ii == -1) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
} else if (ii > info.nsubs) {
start = -1;
end = -1;
} else {
start = info.matches[ii].start;
end = info.matches[ii].end;
}
/*
* Adjust index so it refers to the last character in the
* match instead of the first character after the match.
*/
if (end >= 0) {
end--;
}
objs[0] = Tcl_NewLongObj(start);
objs[1] = Tcl_NewLongObj(end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if (ii == -1) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
newPtr = Tcl_GetRange(objPtr, start, end);
} else if (ii > info.nsubs) {
newPtr = Tcl_NewObj();
} else {
newPtr = Tcl_GetRange(objPtr, info.matches[ii].start,
info.matches[ii].end - 1);
}
}
Tcl_IncrRefCount(newPtr);
valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0);
Tcl_DecrRefCount(newPtr);
if (valuePtr == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
Tcl_GetString(varPtr), "\"", (char *) NULL);
return TCL_ERROR;
}
}
/*
* Set the interpreter's object result to an integer object w/ value 1.
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* TestregexpXflags --
*
* Parse a string of extended regexp flag letters, for testing.
*
* Results:
* No return value (you're on your own for errors here).
*
* Side effects:
* Modifies *cflagsPtr, a regcomp flags word, and *eflagsPtr, a
* regexec flags word, as appropriate.
*
*----------------------------------------------------------------------
*/
static void
TestregexpXflags(string, length, cflagsPtr, eflagsPtr)
char *string; /* The string of flags. */
int length; /* The length of the string in bytes. */
int *cflagsPtr; /* compile flags word */
int *eflagsPtr; /* exec flags word */
{
int i;
int cflags;
int eflags;
cflags = *cflagsPtr;
eflags = *eflagsPtr;
for (i = 0; i < length; i++) {
switch (string[i]) {
case 'a': {
cflags |= REG_ADVF;
break;
}
case 'b': {
cflags &= ~REG_ADVANCED;
break;
}
case 'c': {
cflags |= TCL_REG_CANMATCH;
break;
}
case 'e': {
cflags &= ~REG_ADVANCED;
cflags |= REG_EXTENDED;
break;
}
case 'q': {
cflags &= ~REG_ADVANCED;
cflags |= REG_QUOTE;
break;
}
case 'o': { /* o for opaque */
cflags |= REG_NOSUB;
break;
}
case 's': { /* s for start */
cflags |= REG_BOSONLY;
break;
}
case '+': {
cflags |= REG_FAKE;
break;
}
case ',': {
cflags |= REG_PROGRESS;
break;
}
case '.': {
cflags |= REG_DUMP;
break;
}
case ':': {
eflags |= REG_MTRACE;
break;
}
case ';': {
eflags |= REG_FTRACE;
break;
}
case '^': {
eflags |= REG_NOTBOL;
break;
}
case '$': {
eflags |= REG_NOTEOL;
break;
}
case 't': {
cflags |= REG_EXPECT;
break;
}
case '%': {
eflags |= REG_SMALL;
break;
}
}
}
*cflagsPtr = cflags;
*eflagsPtr = eflags;
}
/*
*----------------------------------------------------------------------
*
* TestsetassocdataCmd --
*
* This procedure implements the "testsetassocdata" command. It is used
* to test Tcl_SetAssocData.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Modifies or creates an association between a key and associated
* data for this interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestsetassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
char *buf;
char *oldData;
Tcl_InterpDeleteProc *procPtr;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key data_item\"", (char *) NULL);
return TCL_ERROR;
}
buf = ckalloc((unsigned) strlen(argv[2]) + 1);
strcpy(buf, argv[2]);
/*
* If we previously associated a malloced value with the variable,
* free it before associating a new value.
*/
oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr);
if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) {
ckfree(oldData);
}
Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests,
(ClientData) buf);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetplatformCmd --
*
* This procedure implements the "testsetplatform" command. It is
* used to change the tclPlatform global variable so all file
* name conversions can be tested on a single platform.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the tclPlatform global variable.
*
*----------------------------------------------------------------------
*/
static int
TestsetplatformCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
size_t length;
TclPlatformType *platform;
#if defined(__WIN32__) || defined(__CYGWIN__)
platform = TclWinGetPlatform();
#else
platform = &tclPlatform;
#endif
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" platform\"", (char *) NULL);
return TCL_ERROR;
}
length = strlen(argv[1]);
if (strncmp(argv[1], "unix", length) == 0) {
*platform = TCL_PLATFORM_UNIX;
} else if (strncmp(argv[1], "windows", length) == 0) {
*platform = TCL_PLATFORM_WINDOWS;
} else {
Tcl_AppendResult(interp, "unsupported platform: should be one of ",
"unix, mac, or windows", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TeststaticpkgCmd --
*
* This procedure implements the "teststaticpkg" command.
* It is used to test the procedure Tcl_StaticPackage.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* When the packge given by argv[1] is loaded into an interpeter,
* variable "x" in that interpreter is set to "loaded".
*
*----------------------------------------------------------------------
*/
static int
TeststaticpkgCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int safe, loaded;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
argv[0], " pkgName safe loaded\"", (char *) NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {
return TCL_ERROR;
}
Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc,
(safe) ? StaticInitProc : NULL);
return TCL_OK;
}
static int
StaticInitProc(interp)
Tcl_Interp *interp; /* Interpreter in which package
* is supposedly being loaded. */
{
Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TesttranslatefilenameCmd --
*
* This procedure implements the "testtranslatefilename" command.
* It is used to test the Tcl_TranslateFileName command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TesttranslatefilenameCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_DString buffer;
CONST char *result;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
argv[0], " path\"", (char *) NULL);
return TCL_ERROR;
}
result = Tcl_TranslateFileName(interp, argv[1], &buffer);
if (result == NULL) {
return TCL_ERROR;
}
Tcl_AppendResult(interp, result, NULL);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestupvarCmd --
*
* This procedure implements the "testupvar2" command. It is used
* to test Tcl_UpVar and Tcl_UpVar2.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates or modifies an "upvar" reference.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestupvarCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int flags = 0;
if ((argc != 5) && (argc != 6)) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
argv[0], " level name ?name2? dest global\"", (char *) NULL);
return TCL_ERROR;
}
if (argc == 5) {
if (strcmp(argv[4], "global") == 0) {
flags = TCL_GLOBAL_ONLY;
} else if (strcmp(argv[4], "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags);
} else {
if (strcmp(argv[5], "global") == 0) {
flags = TCL_GLOBAL_ONLY;
} else if (strcmp(argv[5], "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
return Tcl_UpVar2(interp, argv[1], argv[2],
(argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4],
flags);
}
}
/*
*----------------------------------------------------------------------
*
* TestseterrorcodeCmd --
*
* This procedure implements the "testseterrorcodeCmd".
* This tests up to five elements passed to the
* Tcl_SetErrorCode command.
*
* Results:
* A standard Tcl result. Always returns TCL_ERROR so that
* the error code can be tested.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestseterrorcodeCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc > 6) {
Tcl_SetResult(interp, "too many args", TCL_STATIC);
return TCL_ERROR;
}
Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
argv[5], NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestsetobjerrorcodeCmd --
*
* This procedure implements the "testsetobjerrorcodeCmd".
* This tests the Tcl_SetObjErrorCode function.
*
* Results:
* A standard Tcl result. Always returns TCL_ERROR so that
* the error code can be tested.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestsetobjerrorcodeCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
Tcl_Obj *listObjPtr;
if (objc > 1) {
listObjPtr = Tcl_ConcatObj(objc - 1, objv + 1);
} else {
listObjPtr = Tcl_NewObj();
}
Tcl_IncrRefCount(listObjPtr);
Tcl_SetObjErrorCode(interp, listObjPtr);
Tcl_DecrRefCount(listObjPtr);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestfeventCmd --
*
* This procedure implements the "testfevent" command. It is
* used for testing the "fileevent" command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes interpreters.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestfeventCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
static Tcl_Interp *interp2 = NULL;
int code;
Tcl_Channel chan;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option ?arg arg ...?", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "cmd") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" cmd script", (char *) NULL);
return TCL_ERROR;
}
if (interp2 != (Tcl_Interp *) NULL) {
code = Tcl_GlobalEval(interp2, argv[2]);
Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
return code;
} else {
Tcl_AppendResult(interp,
"called \"testfevent code\" before \"testfevent create\"",
(char *) NULL);
return TCL_ERROR;
}
} else if (strcmp(argv[1], "create") == 0) {
if (interp2 != NULL) {
Tcl_DeleteInterp(interp2);
}
interp2 = Tcl_CreateInterp();
return Tcl_Init(interp2);
} else if (strcmp(argv[1], "delete") == 0) {
if (interp2 != NULL) {
Tcl_DeleteInterp(interp2);
}
interp2 = NULL;
} else if (strcmp(argv[1], "share") == 0) {
if (interp2 != NULL) {
chan = Tcl_GetChannel(interp, argv[2], NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(interp2, chan);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestpanicCmd --
*
* Calls the panic routine.
*
* Results:
* Always returns TCL_OK.
*
* Side effects:
* May exit application.
*
*----------------------------------------------------------------------
*/
static int
TestpanicCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
CONST char *argString;
/*
* Put the arguments into a var args structure
* Append all of the arguments together separated by spaces
*/
argString = Tcl_Merge(argc-1, argv+1);
panic(argString);
ckfree((char *)argString);
return TCL_OK;
}
static int
TestfileCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
Tcl_Obj *CONST argv[]; /* The argument objects. */
{
int force, i, j, result;
Tcl_Obj *error = NULL;
char *subcmd;
if (argc < 3) {
return TCL_ERROR;
}
force = 0;
i = 2;
if (strcmp(Tcl_GetString(argv[2]), "-force") == 0) {
force = 1;
i = 3;
}
if (argc - i > 2) {
return TCL_ERROR;
}
for (j = i; j < argc; j++) {
if (Tcl_FSGetNormalizedPath(interp, argv[j]) == NULL) {
return TCL_ERROR;
}
}
subcmd = Tcl_GetString(argv[1]);
if (strcmp(subcmd, "mv") == 0) {
result = TclpObjRenameFile(argv[i], argv[i + 1]);
} else if (strcmp(subcmd, "cp") == 0) {
result = TclpObjCopyFile(argv[i], argv[i + 1]);
} else if (strcmp(subcmd, "rm") == 0) {
result = TclpObjDeleteFile(argv[i]);
} else if (strcmp(subcmd, "mkdir") == 0) {
result = TclpObjCreateDirectory(argv[i]);
} else if (strcmp(subcmd, "cpdir") == 0) {
result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error);
} else if (strcmp(subcmd, "rmdir") == 0) {
result = TclpObjRemoveDirectory(argv[i], force, &error);
} else {
result = TCL_ERROR;
goto end;
}
if (result != TCL_OK) {
if (error != NULL) {
if (Tcl_GetString(error)[0] != '\0') {
Tcl_AppendResult(interp, Tcl_GetString(error), " ", NULL);
}
Tcl_DecrRefCount(error);
}
Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL);
}
end:
return result;
}
/*
*----------------------------------------------------------------------
*
* TestgetvarfullnameCmd --
*
* Implements the "testgetvarfullname" cmd that is used when testing
* the Tcl_GetVariableFullName procedure.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetvarfullnameCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
char *name, *arg;
int flags = 0;
Tcl_Namespace *namespacePtr;
Tcl_CallFrame frame;
Tcl_Var variable;
int result;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name scope");
return TCL_ERROR;
}
name = Tcl_GetString(objv[1]);
arg = Tcl_GetString(objv[2]);
if (strcmp(arg, "global") == 0) {
flags = TCL_GLOBAL_ONLY;
} else if (strcmp(arg, "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
/*
* This command, like any other created with Tcl_Create[Obj]Command,
* runs in the global namespace. As a "namespace-aware" command that
* needs to run in a particular namespace, it must activate that
* namespace itself.
*/
if (flags == TCL_NAMESPACE_ONLY) {
namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var",
(Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG);
if (namespacePtr == NULL) {
return TCL_ERROR;
}
result = Tcl_PushCallFrame(interp, &frame, namespacePtr,
/*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return result;
}
}
variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL,
(flags | TCL_LEAVE_ERR_MSG));
if (flags == TCL_NAMESPACE_ONLY) {
Tcl_PopCallFrame(interp);
}
if (variable == (Tcl_Var) NULL) {
return TCL_ERROR;
}
Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetTimesCmd --
*
* This procedure implements the "gettimes" command. It is
* used for computing the time needed for various basic operations
* such as reading variables, allocating memory, sprintf, converting
* variables, etc.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Allocates and frees memory, sets a variable "a" in the interpreter.
*
*----------------------------------------------------------------------
*/
static int
GetTimesCmd(unused, interp, argc, argv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int argc; /* The number of arguments. */
CONST char **argv; /* The argument strings. */
{
Interp *iPtr = (Interp *) interp;
int i, n;
double timePer;
Tcl_Time start, stop;
Tcl_Obj *objPtr;
Tcl_Obj **objv;
CONST char *s;
char newString[TCL_INTEGER_SPACE];
/* alloc & free 100000 times */
fprintf(stderr, "alloc & free 100000 6 word items\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
ckfree((char *) objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000);
/* alloc 5000 times */
fprintf(stderr, "alloc 5000 6 word items\n");
objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *));
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per alloc\n", timePer/5000);
/* free 5000 times */
fprintf(stderr, "free 5000 6 word items\n");
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
ckfree((char *) objv[i]);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per free\n", timePer/5000);
/* Tcl_NewObj 5000 times */
fprintf(stderr, "Tcl_NewObj 5000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objv[i] = Tcl_NewObj();
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_NewObj\n", timePer/5000);
/* Tcl_DecrRefCount 5000 times */
fprintf(stderr, "Tcl_DecrRefCount 5000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objPtr = objv[i];
Tcl_DecrRefCount(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
ckfree((char *) objv);
/* TclGetString 100000 times */
fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
objPtr = Tcl_NewStringObj("12345", -1);
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) TclGetString(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n",
timePer/100000);
/* Tcl_GetIntFromObj 100000 times */
fprintf(stderr, "Tcl_GetIntFromObj of \"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
if (Tcl_GetIntFromObj(interp, objPtr, &n) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_GetIntFromObj of \"12345\"\n",
timePer/100000);
Tcl_DecrRefCount(objPtr);
/* Tcl_GetInt 100000 times */
fprintf(stderr, "Tcl_GetInt of \"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
if (Tcl_GetInt(interp, "12345", &n) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_GetInt of \"12345\"\n",
timePer/100000);
/* sprintf 100000 times */
fprintf(stderr, "sprintf of 12345 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
sprintf(newString, "%d", 12345);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per sprintf of 12345\n",
timePer/100000);
/* hashtable lookup 100000 times */
fprintf(stderr, "hashtable lookup of \"gettimes\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "gettimes");
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per hashtable lookup of \"gettimes\"\n",
timePer/100000);
/* Tcl_SetVar 100000 times */
fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_SetVar of a to \"12345\"\n",
timePer/100000);
/* Tcl_GetVar 100000 times */
fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_GetVar of a==\"12345\"\n",
timePer/100000);
Tcl_ResetResult(interp);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NoopCmd --
*
* This procedure is just used to time the overhead involved in
* parsing and invoking a command.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopCmd(unused, interp, argc, argv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int argc; /* The number of arguments. */
CONST char **argv; /* The argument strings. */
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NoopObjCmd --
*
* This object-based procedure is just used to time the overhead
* involved in parsing and invoking a command.
*
* Results:
* Returns the TCL_OK result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopObjCmd(unused, interp, objc, objv)
ClientData unused; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetCmd --
*
* Implements the "testset{err,noerr}" cmds that are used when testing
* Tcl_Set/GetVar C Api with/without TCL_LEAVE_ERR_MSG flag
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Variables may be set.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestsetCmd(data, interp, argc, argv)
ClientData data; /* Additional flags for Get/SetVar2. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int flags = (int) data;
CONST char *value;
if (argc == 2) {
Tcl_SetResult(interp, "before get", TCL_STATIC);
value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags);
if (value == NULL) {
return TCL_ERROR;
}
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (argc == 3) {
Tcl_SetResult(interp, "before set", TCL_STATIC);
value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
}
Tcl_AppendElement(interp, value);
return TCL_OK;
} else {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " varName ?newValue?\"", (char *) NULL);
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
* TestsaveresultCmd --
*
* Implements the "testsaveresult" cmd that is used when testing
* the Tcl_SaveResult, Tcl_RestoreResult, and
* Tcl_DiscardResult interfaces.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestsaveresultCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
int discard, result, index;
Tcl_SavedResult state;
Tcl_Obj *objPtr;
static CONST char *optionStrings[] = {
"append", "dynamic", "free", "object", "small", NULL
};
enum options {
RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL
};
/*
* Parse arguments
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "type script discard");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) {
return TCL_ERROR;
}
objPtr = NULL; /* Lint. */
switch ((enum options) index) {
case RESULT_SMALL:
Tcl_SetResult(interp, "small result", TCL_VOLATILE);
break;
case RESULT_APPEND:
Tcl_AppendResult(interp, "append result", NULL);
break;
case RESULT_FREE: {
char *buf = ckalloc(200);
strcpy(buf, "free result");
Tcl_SetResult(interp, buf, TCL_DYNAMIC);
break;
}
case RESULT_DYNAMIC:
Tcl_SetResult(interp, "dynamic result", TestsaveresultFree);
break;
case RESULT_OBJECT:
objPtr = Tcl_NewStringObj("object result", -1);
Tcl_SetObjResult(interp, objPtr);
break;
}
freeCount = 0;
Tcl_SaveResult(interp, &state);
if (((enum options) index) == RESULT_OBJECT) {
result = Tcl_EvalObjEx(interp, objv[2], 0);
} else {
result = Tcl_Eval(interp, Tcl_GetString(objv[2]));
}
if (discard) {
Tcl_DiscardResult(&state);
} else {
Tcl_RestoreResult(interp, &state);
result = TCL_OK;
}
switch ((enum options) index) {
case RESULT_DYNAMIC: {
int present = interp->freeProc == TestsaveresultFree;
int called = freeCount;
Tcl_AppendElement(interp, called ? "called" : "notCalled");
Tcl_AppendElement(interp, present ? "present" : "missing");
break;
}
case RESULT_OBJECT:
Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr
? "same" : "different");
break;
default:
break;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TestsaveresultFree --
*
* Special purpose freeProc used by TestsaveresultCmd.
*
* Results:
* None.
*
* Side effects:
* Increments the freeCount.
*
*----------------------------------------------------------------------
*/
static void
TestsaveresultFree(blockPtr)
char *blockPtr;
{
freeCount++;
}
/*
*----------------------------------------------------------------------
*
* TeststatprocCmd --
*
* Implements the "testTclStatProc" cmd that is used to test the
* 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TeststatprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
TclStatProc_ *proc;
int retVal;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " option arg\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[2], "TclpStat") == 0) {
proc = PretendTclpStat;
} else if (strcmp(argv[2], "TestStatProc1") == 0) {
proc = TestStatProc1;
} else if (strcmp(argv[2], "TestStatProc2") == 0) {
proc = TestStatProc2;
} else if (strcmp(argv[2], "TestStatProc3") == 0) {
proc = TestStatProc3;
} else {
Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
"must be TclpStat, ",
"TestStatProc1, TestStatProc2, or TestStatProc3",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "insert") == 0) {
if (proc == PretendTclpStat) {
Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
"must be ",
"TestStatProc1, TestStatProc2, or TestStatProc3",
(char *) NULL);
return TCL_ERROR;
}
retVal = TclStatInsertProc(proc);
} else if (strcmp(argv[1], "delete") == 0) {
retVal = TclStatDeleteProc(proc);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ",
"must be insert or delete", (char *) NULL);
return TCL_ERROR;
}
if (retVal == TCL_ERROR) {
Tcl_AppendResult(interp, "\"", argv[2], "\": ",
"could not be ", argv[1], "ed", (char *) NULL);
}
return retVal;
}
static int PretendTclpStat(path, buf)
CONST char *path;
Tcl_StatBuf *buf;
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
#ifdef TCL_WIDE_INT_IS_LONG
Tcl_IncrRefCount(pathPtr);
ret = TclpObjStat(pathPtr, buf);
Tcl_DecrRefCount(pathPtr);
return ret;
#else /* TCL_WIDE_INT_IS_LONG */
Tcl_StatBuf realBuf;
Tcl_IncrRefCount(pathPtr);
ret = TclpObjStat(pathPtr, &realBuf);
Tcl_DecrRefCount(pathPtr);
if (ret != -1) {
# define OUT_OF_RANGE(x) \
(((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
#if defined(__GNUC__) && __GNUC__ >= 2
/*
* Workaround gcc warning of "comparison is always false due to limited range of
* data type" in this macro by checking max type size, and when necessary ANDing
* with the complement of ULONG_MAX instead of the comparison:
*/
# define OUT_OF_URANGE(x) \
((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \
(((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX))
#else
# define OUT_OF_URANGE(x) \
(((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
#endif
/*
* Perform the result-buffer overflow check manually.
*
* Note that ino_t/ino64_t is unsigned...
*/
if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size)
# ifdef HAVE_ST_BLOCKS
|| OUT_OF_RANGE(realBuf.st_blocks)
# endif
) {
# ifdef EOVERFLOW
errno = EOVERFLOW;
# else
# ifdef EFBIG
errno = EFBIG;
# else
# error "what error should be returned for a value out of range?"
# endif
# endif
return -1;
}
# undef OUT_OF_RANGE
# undef OUT_OF_URANGE
/*
* Copy across all supported fields, with possible type
* coercions on those fields that change between the normal
* and lf64 versions of the stat structure (on Solaris at
* least.) This is slow when the structure sizes coincide,
* but that's what you get for mixing interfaces...
*/
buf->st_mode = realBuf.st_mode;
buf->st_ino = (ino_t) realBuf.st_ino;
buf->st_dev = realBuf.st_dev;
buf->st_rdev = realBuf.st_rdev;
buf->st_nlink = realBuf.st_nlink;
buf->st_uid = realBuf.st_uid;
buf->st_gid = realBuf.st_gid;
buf->st_size = (off_t) realBuf.st_size;
buf->st_atime = realBuf.st_atime;
buf->st_mtime = realBuf.st_mtime;
buf->st_ctime = realBuf.st_ctime;
# ifdef HAVE_ST_BLOCKS
buf->st_blksize = realBuf.st_blksize;
buf->st_blocks = (blkcnt_t) realBuf.st_blocks;
# endif
}
return ret;
#endif /* TCL_WIDE_INT_IS_LONG */
}
static int
TestStatProc1(path, buf)
CONST char *path;
Tcl_StatBuf *buf;
{
memset(buf, 0, sizeof(Tcl_StatBuf));
buf->st_size = 1234;
return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0);
}
static int
TestStatProc2(path, buf)
CONST char *path;
Tcl_StatBuf *buf;
{
memset(buf, 0, sizeof(Tcl_StatBuf));
buf->st_size = 2345;
return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0);
}
static int
TestStatProc3(path, buf)
CONST char *path;
Tcl_StatBuf *buf;
{
memset(buf, 0, sizeof(Tcl_StatBuf));
buf->st_size = 3456;
return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0);
}
/*
*----------------------------------------------------------------------
*
* TestmainthreadCmd --
*
* Implements the "testmainthread" cmd that is used to test the
* 'Tcl_GetCurrentThread' API.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestmainthreadCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc == 1) {
Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
* MainLoop --
*
* A main loop set by TestsetmainloopCmd below.
*
* Results:
* None.
*
* Side effects:
* Event handlers could do anything.
*
*----------------------------------------------------------------------
*/
static void
MainLoop(void)
{
while (!exitMainLoop) {
Tcl_DoOneEvent(0);
}
fprintf(stdout,"Exit MainLoop\n");
fflush(stdout);
}
/*
*----------------------------------------------------------------------
*
* TestsetmainloopCmd --
*
* Implements the "testsetmainloop" cmd that is used to test the
* 'Tcl_SetMainLoop' API.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetmainloopCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
exitMainLoop = 0;
Tcl_SetMainLoop(MainLoop);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexitmainloopCmd --
*
* Implements the "testexitmainloop" cmd that is used to test the
* 'Tcl_SetMainLoop' API.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexitmainloopCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
exitMainLoop = 1;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestaccessprocCmd --
*
* Implements the "testTclAccessProc" cmd that is used to test the
* 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestaccessprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
TclAccessProc_ *proc;
int retVal;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " option arg\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[2], "TclpAccess") == 0) {
proc = PretendTclpAccess;
} else if (strcmp(argv[2], "TestAccessProc1") == 0) {
proc = TestAccessProc1;
} else if (strcmp(argv[2], "TestAccessProc2") == 0) {
proc = TestAccessProc2;
} else if (strcmp(argv[2], "TestAccessProc3") == 0) {
proc = TestAccessProc3;
} else {
Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
"must be TclpAccess, ",
"TestAccessProc1, TestAccessProc2, or TestAccessProc3",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "insert") == 0) {
if (proc == PretendTclpAccess) {
Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
"must be ",
"TestAccessProc1, TestAccessProc2, or TestAccessProc3",
(char *) NULL);
return TCL_ERROR;
}
retVal = TclAccessInsertProc(proc);
} else if (strcmp(argv[1], "delete") == 0) {
retVal = TclAccessDeleteProc(proc);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ",
"must be insert or delete", (char *) NULL);
return TCL_ERROR;
}
if (retVal == TCL_ERROR) {
Tcl_AppendResult(interp, "\"", argv[2], "\": ",
"could not be ", argv[1], "ed", (char *) NULL);
}
return retVal;
}
static int PretendTclpAccess(path, mode)
CONST char *path;
int mode;
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(pathPtr);
ret = TclpObjAccess(pathPtr, mode);
Tcl_DecrRefCount(pathPtr);
return ret;
}
static int
TestAccessProc1(path, mode)
CONST char *path;
int mode;
{
return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0);
}
static int
TestAccessProc2(path, mode)
CONST char *path;
int mode;
{
return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0);
}
static int
TestAccessProc3(path, mode)
CONST char *path;
int mode;
{
return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0);
}
/*
*----------------------------------------------------------------------
*
* TestopenfilechannelprocCmd --
*
* Implements the "testTclOpenFileChannelProc" cmd that is used to test the
* 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C Apis.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestopenfilechannelprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
TclOpenFileChannelProc_ *proc;
int retVal;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " option arg\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[2], "TclpOpenFileChannel") == 0) {
proc = PretendTclpOpenFileChannel;
} else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) {
proc = TestOpenFileChannelProc1;
} else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) {
proc = TestOpenFileChannelProc2;
} else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) {
proc = TestOpenFileChannelProc3;
} else {
Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
"must be TclpOpenFileChannel, ",
"TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ",
"TestOpenFileChannelProc3",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "insert") == 0) {
if (proc == PretendTclpOpenFileChannel) {
Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
"must be ",
"TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ",
"TestOpenFileChannelProc3",
(char *) NULL);
return TCL_ERROR;
}
retVal = TclOpenFileChannelInsertProc(proc);
} else if (strcmp(argv[1], "delete") == 0) {
retVal = TclOpenFileChannelDeleteProc(proc);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ",
"must be insert or delete", (char *) NULL);
return TCL_ERROR;
}
if (retVal == TCL_ERROR) {
Tcl_AppendResult(interp, "\"", argv[2], "\": ",
"could not be ", argv[1], "ed", (char *) NULL);
}
return retVal;
}
static Tcl_Channel
PretendTclpOpenFileChannel(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
CONST char *fileName; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Channel ret;
int mode, seekFlag;
Tcl_Obj *pathPtr;
mode = TclGetOpenMode(interp, modeString, &seekFlag);
if (mode == -1) {
return NULL;
}
pathPtr = Tcl_NewStringObj(fileName, -1);
Tcl_IncrRefCount(pathPtr);
ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions);
Tcl_DecrRefCount(pathPtr);
if (ret != NULL) {
if (seekFlag) {
if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp,
"could not seek to end of file while opening \"",
fileName, "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
Tcl_Close(NULL, ret);
return NULL;
}
}
}
return ret;
}
static Tcl_Channel
TestOpenFileChannelProc1(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
CONST char *fileName; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
CONST char *expectname="testOpenFileChannel1%.fil";
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_JoinPath(1, &expectname, &ds);
if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
Tcl_DStringFree(&ds);
return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil",
modeString, permissions));
} else {
Tcl_DStringFree(&ds);
return (NULL);
}
}
static Tcl_Channel
TestOpenFileChannelProc2(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
CONST char *fileName; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
CONST char *expectname="testOpenFileChannel2%.fil";
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_JoinPath(1, &expectname, &ds);
if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
Tcl_DStringFree(&ds);
return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil",
modeString, permissions));
} else {
Tcl_DStringFree(&ds);
return (NULL);
}
}
static Tcl_Channel
TestOpenFileChannelProc3(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
CONST char *fileName; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
CONST char *expectname="testOpenFileChannel3%.fil";
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_JoinPath(1, &expectname, &ds);
if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
Tcl_DStringFree(&ds);
return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil",
modeString, permissions));
} else {
Tcl_DStringFree(&ds);
return (NULL);
}
}
/*
*----------------------------------------------------------------------
*
* TestChannelCmd --
*
* Implements the Tcl "testchannel" debugging command and its
* subcommands. This is part of the testing environment.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestChannelCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter for result. */
int argc; /* Count of additional args. */
CONST char **argv; /* Additional arg strings. */
{
CONST char *cmdName; /* Sub command. */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Channel *chanPtr; /* The actual channel. */
ChannelState *statePtr; /* state info for channel */
Tcl_Channel chan; /* The opaque type. */
size_t len; /* Length of subcommand string. */
int IOQueued; /* How much IO is queued inside channel? */
ChannelBuffer *bufPtr; /* For iterating over queued IO. */
char buf[TCL_INTEGER_SPACE];/* For sprintf. */
int mode; /* rw mode of the channel */
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" subcommand ?additional args..?\"", (char *) NULL);
return TCL_ERROR;
}
cmdName = argv[1];
len = strlen(cmdName);
chanPtr = (Channel *) NULL;
if (argc > 2) {
chan = Tcl_GetChannel(interp, argv[2], &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
chan = (Tcl_Channel) chanPtr;
} else {
/* lint */
statePtr = NULL;
chan = NULL;
}
if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" cut channelName\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_CutChannel(chan);
return TCL_OK;
}
if ((cmdName[0] == 'c') &&
(strncmp(cmdName, "clearchannelhandlers", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" clearchannelhandlers channelName\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_ClearChannelHandlers(chan);
return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" info channelName\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_AppendElement(interp, argv[2]);
Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr));
if (statePtr->flags & TCL_READABLE) {
Tcl_AppendElement(interp, "read");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & TCL_WRITABLE) {
Tcl_AppendElement(interp, "write");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & CHANNEL_NONBLOCKING) {
Tcl_AppendElement(interp, "nonblocking");
} else {
Tcl_AppendElement(interp, "blocking");
}
if (statePtr->flags & CHANNEL_LINEBUFFERED) {
Tcl_AppendElement(interp, "line");
} else if (statePtr->flags & CHANNEL_UNBUFFERED) {
Tcl_AppendElement(interp, "none");
} else {
Tcl_AppendElement(interp, "full");
}
if (statePtr->flags & BG_FLUSH_SCHEDULED) {
Tcl_AppendElement(interp, "async_flush");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & CHANNEL_EOF) {
Tcl_AppendElement(interp, "eof");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & CHANNEL_BLOCKED) {
Tcl_AppendElement(interp, "blocked");
} else {
Tcl_AppendElement(interp, "unblocked");
}
if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) {
Tcl_AppendElement(interp, "auto");
if (statePtr->flags & INPUT_SAW_CR) {
Tcl_AppendElement(interp, "saw_cr");
} else {
Tcl_AppendElement(interp, "");
}
} else if (statePtr->inputTranslation == TCL_TRANSLATE_LF) {
Tcl_AppendElement(interp, "lf");
Tcl_AppendElement(interp, "");
} else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {
Tcl_AppendElement(interp, "cr");
Tcl_AppendElement(interp, "");
} else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) {
Tcl_AppendElement(interp, "crlf");
if (statePtr->flags & INPUT_SAW_CR) {
Tcl_AppendElement(interp, "queued_cr");
} else {
Tcl_AppendElement(interp, "");
}
}
if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) {
Tcl_AppendElement(interp, "auto");
} else if (statePtr->outputTranslation == TCL_TRANSLATE_LF) {
Tcl_AppendElement(interp, "lf");
} else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) {
Tcl_AppendElement(interp, "cr");
} else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) {
Tcl_AppendElement(interp, "crlf");
}
for (IOQueued = 0, bufPtr = statePtr->inQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
}
TclFormatInt(buf, IOQueued);
Tcl_AppendElement(interp, buf);
IOQueued = 0;
if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
IOQueued = statePtr->curOutPtr->nextAdded -
statePtr->curOutPtr->nextRemoved;
}
for (bufPtr = statePtr->outQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);
}
TclFormatInt(buf, IOQueued);
Tcl_AppendElement(interp, buf);
TclFormatInt(buf, (int)Tcl_Tell((Tcl_Channel) chanPtr));
Tcl_AppendElement(interp, buf);
TclFormatInt(buf, statePtr->refCount);
Tcl_AppendElement(interp, buf);
return TCL_OK;
}
if ((cmdName[0] == 'i') &&
(strncmp(cmdName, "inputbuffered", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
for (IOQueued = 0, bufPtr = statePtr->inQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
}
TclFormatInt(buf, IOQueued);
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *) NULL);
return TCL_ERROR;
}
TclFormatInt(buf, Tcl_IsChannelShared(chan));
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *) NULL);
return TCL_ERROR;
}
TclFormatInt(buf, Tcl_IsStandardChannel(chan));
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
if (statePtr->flags & TCL_READABLE) {
Tcl_AppendElement(interp, "read");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & TCL_WRITABLE) {
Tcl_AppendElement(interp, "write");
} else {
Tcl_AppendElement(interp, "");
}
return TCL_OK;
}
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
TclFormatInt(buf, (long) Tcl_GetChannelThread(chan));
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, statePtr->channelName, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) {
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != (Tcl_HashEntry *) NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
}
return TCL_OK;
}
if ((cmdName[0] == 'o') &&
(strncmp(cmdName, "outputbuffered", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
IOQueued = 0;
if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
IOQueued = statePtr->curOutPtr->nextAdded -
statePtr->curOutPtr->nextRemoved;
}
for (bufPtr = statePtr->outQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);
}
TclFormatInt(buf, IOQueued);
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'q') &&
(strncmp(cmdName, "queuedcr", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp,
(statePtr->flags & INPUT_SAW_CR) ? "1" : "0",
(char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) {
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != (Tcl_HashEntry *) NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
if (statePtr->flags & TCL_READABLE) {
Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
}
}
return TCL_OK;
}
if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
TclFormatInt(buf, statePtr->refCount);
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *) NULL);
return TCL_ERROR;
}
Tcl_SpliceChannel(chan);
return TCL_OK;
}
if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr),
(char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) {
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != (Tcl_HashEntry *) NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
if (statePtr->flags & TCL_WRITABLE) {
Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
}
}
return TCL_OK;
}
if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) {
/*
* Syntax: transform channel -command command
*/
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" transform channelId -command cmd\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[3], "-command") != 0) {
Tcl_AppendResult(interp, "bad argument \"", argv[3],
"\": should be \"-command\"", (char *) NULL);
return TCL_ERROR;
}
return TclChannelTransform(interp, chan,
Tcl_NewStringObj(argv[4], -1));
}
if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {
/*
* Syntax: unstack channel
*/
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" unstack channel\"", (char *) NULL);
return TCL_ERROR;
}
return Tcl_UnstackChannel(interp, chan);
}
Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ",
"cut, clearchannelhandlers, info, isshared, mode, open, "
"readable, splice, writable, transform, unstack",
(char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestChannelEventCmd --
*
* This procedure implements the "testchannelevent" command. It is
* used to test the Tcl channel event mechanism.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates, deletes and returns channel event handlers.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestChannelEventCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_Obj *resultListPtr;
Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr;
CONST char *cmd;
int index, i, mask, len;
if ((argc < 3) || (argc > 5)) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName cmd ?arg1? ?arg2?\"", (char *) NULL);
return TCL_ERROR;
}
chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL);
if (chanPtr == (Channel *) NULL) {
return TCL_ERROR;
}
statePtr = chanPtr->state;
cmd = argv[2];
len = strlen(cmd);
if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName add eventSpec script\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[3], "readable") == 0) {
mask = TCL_READABLE;
} else if (strcmp(argv[3], "writable") == 0) {
mask = TCL_WRITABLE;
} else if (strcmp(argv[3], "none") == 0) {
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name \"", argv[3],
"\": must be readable, writable, or none", (char *) NULL);
return TCL_ERROR;
}
esPtr = (EventScriptRecord *) ckalloc((unsigned)
sizeof(EventScriptRecord));
esPtr->nextPtr = statePtr->scriptRecordPtr;
statePtr->scriptRecordPtr = esPtr;
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
Tcl_IncrRefCount(esPtr->scriptPtr);
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
TclChannelEventScriptInvoker, (ClientData) esPtr);
return TCL_OK;
}
if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) {
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName delete index\"", (char *) NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
return TCL_ERROR;
}
if (index < 0) {
Tcl_AppendResult(interp, "bad event index: ", argv[3],
": must be nonnegative", (char *) NULL);
return TCL_ERROR;
}
for (i = 0, esPtr = statePtr->scriptRecordPtr;
(i < index) && (esPtr != (EventScriptRecord *) NULL);
i++, esPtr = esPtr->nextPtr) {
/* Empty loop body. */
}
if (esPtr == (EventScriptRecord *) NULL) {
Tcl_AppendResult(interp, "bad event index ", argv[3],
": out of range", (char *) NULL);
return TCL_ERROR;
}
if (esPtr == statePtr->scriptRecordPtr) {
statePtr->scriptRecordPtr = esPtr->nextPtr;
} else {
for (prevEsPtr = statePtr->scriptRecordPtr;
(prevEsPtr != (EventScriptRecord *) NULL) &&
(prevEsPtr->nextPtr != esPtr);
prevEsPtr = prevEsPtr->nextPtr) {
/* Empty loop body. */
}
if (prevEsPtr == (EventScriptRecord *) NULL) {
panic("TestChannelEventCmd: damaged event script list");
}
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, (ClientData) esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree((char *) esPtr);
return TCL_OK;
}
if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName list\"", (char *) NULL);
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
for (esPtr = statePtr->scriptRecordPtr;
esPtr != (EventScriptRecord *) NULL;
esPtr = esPtr->nextPtr) {
if (esPtr->mask) {
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));
} else {
Tcl_ListObjAppendElement(interp, resultListPtr,
Tcl_NewStringObj("none", -1));
}
Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
return TCL_OK;
}
if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName removeall\"", (char *) NULL);
return TCL_ERROR;
}
for (esPtr = statePtr->scriptRecordPtr;
esPtr != (EventScriptRecord *) NULL;
esPtr = nextEsPtr) {
nextEsPtr = esPtr->nextPtr;
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, (ClientData) esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree((char *) esPtr);
}
statePtr->scriptRecordPtr = (EventScriptRecord *) NULL;
return TCL_OK;
}
if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName delete index event\"", (char *) NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
return TCL_ERROR;
}
if (index < 0) {
Tcl_AppendResult(interp, "bad event index: ", argv[3],
": must be nonnegative", (char *) NULL);
return TCL_ERROR;
}
for (i = 0, esPtr = statePtr->scriptRecordPtr;
(i < index) && (esPtr != (EventScriptRecord *) NULL);
i++, esPtr = esPtr->nextPtr) {
/* Empty loop body. */
}
if (esPtr == (EventScriptRecord *) NULL) {
Tcl_AppendResult(interp, "bad event index ", argv[3],
": out of range", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[4], "readable") == 0) {
mask = TCL_READABLE;
} else if (strcmp(argv[4], "writable") == 0) {
mask = TCL_WRITABLE;
} else if (strcmp(argv[4], "none") == 0) {
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name \"", argv[4],
"\": must be readable, writable, or none", (char *) NULL);
return TCL_ERROR;
}
esPtr->mask = mask;
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
TclChannelEventScriptInvoker, (ClientData) esPtr);
return TCL_OK;
}
Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ",
"add, delete, list, set, or removeall", (char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestWrongNumArgsObjCmd --
*
* Test the Tcl_WrongNumArgs function.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestWrongNumArgsObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, length;
char *msg;
if (objc < 3) {
/*
* Don't use Tcl_WrongNumArgs here, as that is the function
* we want to test!
*/
Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) {
return TCL_ERROR;
}
msg = Tcl_GetStringFromObj(objv[2], &length);
if (length == 0) {
msg = NULL;
}
if (i > objc - 3) {
/*
* Asked for more arguments than were given.
*/
Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
return TCL_ERROR;
}
Tcl_WrongNumArgs(interp, i, &(objv[3]), msg);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestGetIndexFromObjStructObjCmd --
*
* Test the Tcl_GetIndexFromObjStruct function.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *ary[] = {
"a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL
};
int idx,target;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *),
"dummy", 0, &idx) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) {
return TCL_ERROR;
}
if (idx != target) {
char buffer[64];
sprintf(buffer, "%d", idx);
Tcl_AppendResult(interp, "index value comparison failed: got ",
buffer, NULL);
sprintf(buffer, "%d", target);
Tcl_AppendResult(interp, " when ", buffer, " expected", NULL);
return TCL_ERROR;
}
Tcl_WrongNumArgs(interp, 3, objv, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestFilesystemObjCmd --
*
* This procedure implements the "testfilesystem" command. It is
* used to test Tcl_FSRegister, Tcl_FSUnregister, and can be used
* to test that the pluggable filesystem works.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Inserts or removes a filesystem from Tcl's stack.
*
*----------------------------------------------------------------------
*/
static int
TestFilesystemObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
int res, boolVal;
char *msg;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "boolean");
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
return TCL_ERROR;
}
if (boolVal) {
res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&testReportingFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
Tcl_SetResult(interp, msg, TCL_VOLATILE);
return res;
}
static int
TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr)
{
static Tcl_Obj* lastPathPtr = NULL;
if (pathPtr == lastPathPtr) {
/* Reject all files second time around */
return -1;
} else {
Tcl_Obj * newPathPtr;
/* Try to claim all files first time around */
newPathPtr = Tcl_DuplicateObj(pathPtr);
lastPathPtr = newPathPtr;
Tcl_IncrRefCount(newPathPtr);
if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) {
/* Nothing claimed it. Therefore we don't either */
Tcl_DecrRefCount(newPathPtr);
lastPathPtr = NULL;
return -1;
} else {
lastPathPtr = NULL;
*clientDataPtr = (ClientData) newPathPtr;
return TCL_OK;
}
}
}
/*
* Simple helper function to extract the native vfs representation of a
* path object, or NULL if no such representation exists.
*/
static Tcl_Obj*
TestReportGetNativePath(Tcl_Obj* pathObjPtr) {
return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem);
}
static void
TestReportFreeInternalRep(ClientData clientData) {
Tcl_Obj *nativeRep = (Tcl_Obj*)clientData;
if (nativeRep != NULL) {
/* Free the path */
Tcl_DecrRefCount(nativeRep);
}
}
static ClientData
TestReportDupInternalRep(ClientData clientData) {
Tcl_Obj *original = (Tcl_Obj*)clientData;
Tcl_IncrRefCount(original);
return clientData;
}
static void
TestReport(cmd, path, arg2)
CONST char* cmd;
Tcl_Obj* path;
Tcl_Obj* arg2;
{
Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem);
if (interp == NULL) {
/* This is bad, but not much we can do about it */
} else {
/*
* No idea why I decided to program this up using the
* old string-based API, but there you go. We should
* convert it to objects.
*/
Tcl_SavedResult savedResult;
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, "lappend filesystemReport ",-1);
Tcl_DStringStartSublist(&ds);
Tcl_DStringAppendElement(&ds, cmd);
if (path != NULL) {
Tcl_DStringAppendElement(&ds, Tcl_GetString(path));
}
if (arg2 != NULL) {
Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));
}
Tcl_DStringEndSublist(&ds);
Tcl_SaveResult(interp, &savedResult);
Tcl_Eval(interp, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
Tcl_RestoreResult(interp, &savedResult);
}
}
static int
TestReportStat(path, buf)
Tcl_Obj *path; /* Path of file to stat (in current CP). */
Tcl_StatBuf *buf; /* Filled with results of stat call. */
{
TestReport("stat",path, NULL);
return Tcl_FSStat(TestReportGetNativePath(path),buf);
}
static int
TestReportLstat(path, buf)
Tcl_Obj *path; /* Path of file to stat (in current CP). */
Tcl_StatBuf *buf; /* Filled with results of stat call. */
{
TestReport("lstat",path, NULL);
return Tcl_FSLstat(TestReportGetNativePath(path),buf);
}
static int
TestReportAccess(path, mode)
Tcl_Obj *path; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
TestReport("access",path,NULL);
return Tcl_FSAccess(TestReportGetNativePath(path),mode);
}
static Tcl_Channel
TestReportOpenFileChannel(interp, fileName, mode, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
Tcl_Obj *fileName; /* Name of file to open. */
int mode; /* POSIX open mode. */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
TestReport("open",fileName, NULL);
return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName),
mode, permissions);
}
static int
TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
Tcl_Interp *interp; /* Interpreter to receive results. */
Tcl_Obj *resultPtr; /* Object to lappend results. */
Tcl_Obj *dirPtr; /* Contains path to directory to search. */
CONST char *pattern; /* Pattern to match against. */
Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
* May be NULL. */
{
if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
TestReport("matchmounts",dirPtr, NULL);
return TCL_OK;
} else {
TestReport("matchindirectory",dirPtr, NULL);
return Tcl_FSMatchInDirectory(interp, resultPtr,
TestReportGetNativePath(dirPtr), pattern,
types);
}
}
static int
TestReportChdir(dirName)
Tcl_Obj *dirName;
{
TestReport("chdir",dirName,NULL);
return Tcl_FSChdir(TestReportGetNativePath(dirName));
}
static int
TestReportLoadFile(interp, fileName,
handlePtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *fileName; /* Name of the file containing the desired
* code. */
Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr;
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for
* this file. */
{
TestReport("loadfile",fileName,NULL);
return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL,
NULL, NULL, handlePtr, unloadProcPtr);
}
static Tcl_Obj *
TestReportLink(path, to, linkType)
Tcl_Obj *path; /* Path of file to readlink or link */
Tcl_Obj *to; /* Path of file to link to, or NULL */
int linkType;
{
TestReport("link",path,to);
return Tcl_FSLink(TestReportGetNativePath(path), to, linkType);
}
static int
TestReportRenameFile(src, dst)
Tcl_Obj *src; /* Pathname of file or dir to be renamed
* (UTF-8). */
Tcl_Obj *dst; /* New pathname of file or directory
* (UTF-8). */
{
TestReport("renamefile",src,dst);
return Tcl_FSRenameFile(TestReportGetNativePath(src),
TestReportGetNativePath(dst));
}
static int
TestReportCopyFile(src, dst)
Tcl_Obj *src; /* Pathname of file to be copied (UTF-8). */
Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */
{
TestReport("copyfile",src,dst);
return Tcl_FSCopyFile(TestReportGetNativePath(src),
TestReportGetNativePath(dst));
}
static int
TestReportDeleteFile(path)
Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */
{
TestReport("deletefile",path,NULL);
return Tcl_FSDeleteFile(TestReportGetNativePath(path));
}
static int
TestReportCreateDirectory(path)
Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */
{
TestReport("createdirectory",path,NULL);
return Tcl_FSCreateDirectory(TestReportGetNativePath(path));
}
static int
TestReportCopyDirectory(src, dst, errorPtr)
Tcl_Obj *src; /* Pathname of directory to be copied
* (UTF-8). */
Tcl_Obj *dst; /* Pathname of target directory (UTF-8). */
Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name
* of file causing error. */
{
TestReport("copydirectory",src,dst);
return Tcl_FSCopyDirectory(TestReportGetNativePath(src),
TestReportGetNativePath(dst), errorPtr);
}
static int
TestReportRemoveDirectory(path, recursive, errorPtr)
Tcl_Obj *path; /* Pathname of directory to be removed
* (UTF-8). */
int recursive; /* If non-zero, removes directories that
* are nonempty. Otherwise, will only remove
* empty directories. */
Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name
* of file causing error. */
{
TestReport("removedirectory",path,NULL);
return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive,
errorPtr);
}
static CONST char**
TestReportFileAttrStrings(fileName, objPtrRef)
Tcl_Obj* fileName;
Tcl_Obj** objPtrRef;
{
TestReport("fileattributestrings",fileName,NULL);
return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef);
}
static int
TestReportFileAttrsGet(interp, index, fileName, objPtrRef)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *fileName; /* filename we are operating on. */
Tcl_Obj **objPtrRef; /* for output. */
{
TestReport("fileattributesget",fileName,NULL);
return Tcl_FSFileAttrsGet(interp, index,
TestReportGetNativePath(fileName), objPtrRef);
}
static int
TestReportFileAttrsSet(interp, index, fileName, objPtr)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *fileName; /* filename we are operating on. */
Tcl_Obj *objPtr; /* for input. */
{
TestReport("fileattributesset",fileName,objPtr);
return Tcl_FSFileAttrsSet(interp, index,
TestReportGetNativePath(fileName), objPtr);
}
static int
TestReportUtime (fileName, tval)
Tcl_Obj* fileName;
struct utimbuf *tval;
{
TestReport("utime",fileName,NULL);
return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);
}
static int
TestReportNormalizePath(interp, pathPtr, nextCheckpoint)
Tcl_Interp *interp;
Tcl_Obj *pathPtr;
int nextCheckpoint;
{
TestReport("normalizepath",pathPtr,NULL);
return nextCheckpoint;
}
static int
SimplePathInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) {
CONST char *str = Tcl_GetString(pathPtr);
if (strncmp(str,"simplefs:/",10)) {
return -1;
}
return TCL_OK;
}
/*
* Since TclCopyChannel insists on an interpreter, we use this
* to simplify our test scripts. Would be better if it could
* copy without an interp
*/
static Tcl_Interp *simpleInterpPtr = NULL;
/* We use this to ensure we clean up after ourselves */
static Tcl_Obj *tempFile = NULL;
/*
* This is a very 'hacky' filesystem which is used just to
* test two important features of the vfs code: (1) that
* you can load a shared library from a vfs, (2) that when
* copying files from one fs to another, the 'mtime' is
* preserved.
*
* It treats any file in 'simplefs:/' as a file, and
* artificially creates a real file on the fly which it uses
* to extract information from. The real file it uses is
* whatever follows the trailing '/' (e.g. 'foo' in 'simplefs:/foo'),
* and that file is assumed to exist in the native pwd, and is
* copied over to the native temporary directory where it is
* accessed.
*
* Please do not consider this filesystem a model of how
* things are to be done. It is quite the opposite! But, it
* does allow us to test two important features.
*
* Finally: this fs can only be used from one interpreter.
*/
static int
TestSimpleFilesystemObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
int res, boolVal;
char *msg;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "boolean");
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
return TCL_ERROR;
}
if (boolVal) {
res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
simpleInterpPtr = interp;
} else {
if (tempFile != NULL) {
Tcl_FSDeleteFile(tempFile);
Tcl_DecrRefCount(tempFile);
tempFile = NULL;
}
res = Tcl_FSUnregister(&simpleFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
simpleInterpPtr = NULL;
}
Tcl_SetResult(interp, msg, TCL_VOLATILE);
return res;
}
/*
* Treats a file name 'simplefs:/foo' by copying the file 'foo'
* in the current (native) directory to a temporary native file,
* and then returns that native file.
*/
static Tcl_Obj*
SimpleCopy(pathPtr)
Tcl_Obj *pathPtr; /* Name of file to copy. */
{
int res;
CONST char *str;
Tcl_Obj *origPtr;
Tcl_Obj *tempPtr;
tempPtr = TclpTempFileName();
Tcl_IncrRefCount(tempPtr);
/*
* We assume the same name in the current directory is ok.
*/
str = Tcl_GetString(pathPtr);
origPtr = Tcl_NewStringObj(str+10,-1);
Tcl_IncrRefCount(origPtr);
res = TclCrossFilesystemCopy(simpleInterpPtr, origPtr, tempPtr);
Tcl_DecrRefCount(origPtr);
if (res != TCL_OK) {
Tcl_FSDeleteFile(tempPtr);
Tcl_DecrRefCount(tempPtr);
return NULL;
}
return tempPtr;
}
static Tcl_Channel
SimpleOpenFileChannel(interp, pathPtr, mode, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
Tcl_Obj *pathPtr; /* Name of file to open. */
int mode; /* POSIX open mode. */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Obj *tempPtr;
Tcl_Channel chan;
if ((mode != 0) && !(mode & O_RDONLY)) {
Tcl_AppendResult(interp, "read-only",
(char *) NULL);
return NULL;
}
tempPtr = SimpleCopy(pathPtr);
if (tempPtr == NULL) {
return NULL;
}
chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions);
if (tempFile != NULL) {
Tcl_FSDeleteFile(tempFile);
Tcl_DecrRefCount(tempFile);
tempFile = NULL;
}
/*
* Store file pointer in this global variable so we can delete
* it later
*/
tempFile = tempPtr;
return chan;
}
static int
SimpleAccess(pathPtr, mode)
Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
/* All files exist */
return TCL_OK;
}
static int
SimpleStat(pathPtr, bufPtr)
Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */
{
Tcl_Obj *tempPtr = SimpleCopy(pathPtr);
if (tempPtr == NULL) {
/* We just pretend the file exists anyway */
return TCL_OK;
} else {
int res = Tcl_FSStat(tempPtr, bufPtr);
Tcl_FSDeleteFile(tempPtr);
Tcl_DecrRefCount(tempPtr);
return res;
}
}
static Tcl_Obj*
SimpleListVolumes(void)
{
/* Add one new volume */
Tcl_Obj *retVal;
retVal = Tcl_NewStringObj("simplefs:/",-1);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
static int
TestNumUtfCharsCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
if (objc > 1) {
int len = -1;
if (objc > 2) {
(void) Tcl_GetStringFromObj(objv[1], &len);
}
len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);
Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
}
return TCL_OK;
}
#if defined(HAVE_CPUID) || defined(__WIN32__)
/*
*----------------------------------------------------------------------
*
* TestcpuidCmd --
*
* Retrieves CPU ID information.
*
* Usage:
* testcpuid
*
* Parameters:
* eax - The value to pass in the EAX register to a CPUID instruction.
*
* Results:
* Returns a four-element list containing the values from the
* EAX, EBX, ECX and EDX registers returned from the CPUID instruction.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestcpuidCmd( ClientData dummy,
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *CONST * objv ) /* Parameter vector */
{
int status;
int index;
unsigned int regs[4];
Tcl_Obj * regsObjs[4];
int i;
if ( objc != 2 ) {
Tcl_WrongNumArgs( interp, 1, objv, "eax" );
return TCL_ERROR;
}
if ( Tcl_GetIntFromObj( interp, objv[1], &index ) != TCL_OK ) {
return TCL_ERROR;
}
status = TclWinCPUID( (unsigned int) index, regs );
if ( status != TCL_OK ) {
Tcl_SetObjResult( interp, Tcl_NewStringObj( "operation not available",
-1 ) );
return status;
}
for ( i = 0; i < 4; ++i ) {
regsObjs[i] = Tcl_NewIntObj( (int) regs[i] );
}
Tcl_SetObjResult( interp, Tcl_NewListObj( 4, regsObjs ) );
return TCL_OK;
}
#endif
tcl8.4.20/generic/tclEvent.c 0000644 0036047 0045461 00000111723 11737050674 014270 0 ustar dgp 771div /*
* tclEvent.c --
*
* This file implements some general event related interfaces including
* background errors, exit handlers, and the "vwait" and "update"
* command procedures.
*
* Copyright (c) 1990-1994 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.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* The data structure below is used to report background errors. One
* such structure is allocated for each error; it holds information
* about the interpreter and the error until bgerror can be invoked
* later as an idle handler.
*/
typedef struct BgError {
Tcl_Interp *interp; /* Interpreter in which error occurred. NULL
* means this error report has been cancelled
* (a previous report generated a break). */
char *errorMsg; /* Copy of the error message (the interp's
* result when the error occurred).
* Malloc-ed. */
char *errorInfo; /* Value of the errorInfo variable
* (malloc-ed). */
char *errorCode; /* Value of the errorCode variable
* (malloc-ed). */
struct BgError *nextPtr; /* Next in list of all pending error
* reports for this interpreter, or NULL
* for end of list. */
} BgError;
/*
* One of the structures below is associated with the "tclBgError"
* assoc data for each interpreter. It keeps track of the head and
* tail of the list of pending background errors for the interpreter.
*/
typedef struct ErrAssocData {
BgError *firstBgPtr; /* First in list of all background errors
* waiting to be processed for this
* interpreter (NULL if none). */
BgError *lastBgPtr; /* Last in list of all background errors
* waiting to be processed for this
* interpreter (NULL if none). */
} ErrAssocData;
/*
* For each exit handler created with a call to Tcl_Create(Late)ExitHandler there is
* a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Procedure to call when process exits. */
ClientData clientData; /* One word of information to pass to proc. */
struct ExitHandler *nextPtr;/* Next in list of all exit handlers for
* this application, or NULL for end of list. */
} ExitHandler;
/*
* There is both per-process and per-thread exit handlers.
* The first list is controlled by a mutex. The other is in
* thread local storage.
*/
static ExitHandler *firstExitPtr = NULL;
/* First in list of all exit handlers for
* application. */
static ExitHandler *firstLateExitPtr = NULL;
/* First in list of all late exit handlers for
* application. */
TCL_DECLARE_MUTEX(exitMutex)
/*
* This variable is set to 1 when Tcl_Finalize is called, and at the end of
* its work, it is reset to 0. The variable is checked by TclInExit() to
* allow different behavior for exit-time processing, e.g. in closing of
* files and pipes.
*/
static int inFinalize = 0;
static int subsystemsInitialized = 0;
typedef struct ThreadSpecificData {
ExitHandler *firstExitPtr; /* First in list of all exit handlers for
* this thread. */
int inExit; /* True when this thread is exiting. This
* is used as a hack to decide to close
* the standard channels. */
Tcl_Obj *tclLibraryPath; /* Path(s) to the Tcl library */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Common string for the library path for sharing across threads.
* This is ckalloc'd and cleared in Tcl_Finalize.
*/
static char *tclLibraryPathStr = NULL;
#ifdef TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
ClientData clientData; /* The one argument to Main() */
} ThreadClientData;
static Tcl_ThreadCreateType NewThreadProc _ANSI_ARGS_((
ClientData clientData));
#endif
/*
* Prototypes for procedures referenced only in this file:
*/
static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp));
static void HandleBgErrors _ANSI_ARGS_((ClientData clientData));
static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
/*
*----------------------------------------------------------------------
*
* Tcl_BackgroundError --
*
* This procedure is invoked to handle errors that occur in Tcl
* commands that are invoked in "background" (e.g. from event or
* timer bindings).
*
* Results:
* None.
*
* Side effects:
* The command "bgerror" is invoked later as an idle handler to
* process the error, passing it the error message. If that fails,
* then an error message is output on stderr.
*
*----------------------------------------------------------------------
*/
void
Tcl_BackgroundError(interp)
Tcl_Interp *interp; /* Interpreter in which an error has
* occurred. */
{
BgError *errPtr;
CONST char *errResult, *varValue;
ErrAssocData *assocPtr;
int length;
/*
* The Tcl_AddErrorInfo call below (with an empty string) ensures that
* errorInfo gets properly set. It's needed in cases where the error
* came from a utility procedure like Tcl_GetVar instead of Tcl_Eval;
* in these cases errorInfo still won't have been set when this
* procedure is called.
*/
Tcl_AddErrorInfo(interp, "");
errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
errPtr = (BgError *) ckalloc(sizeof(BgError));
errPtr->interp = interp;
errPtr->errorMsg = (char *) ckalloc((unsigned) (length + 1));
memcpy(errPtr->errorMsg, errResult, (size_t) (length + 1));
varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if (varValue == NULL) {
varValue = errPtr->errorMsg;
}
errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
strcpy(errPtr->errorInfo, varValue);
varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
if (varValue == NULL) {
varValue = "";
}
errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
strcpy(errPtr->errorCode, varValue);
errPtr->nextPtr = NULL;
assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
(Tcl_InterpDeleteProc **) NULL);
if (assocPtr == NULL) {
/*
* This is the first time a background error has occurred in
* this interpreter. Create associated data to keep track of
* pending error reports.
*/
assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
assocPtr->firstBgPtr = NULL;
assocPtr->lastBgPtr = NULL;
Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
(ClientData) assocPtr);
}
if (assocPtr->firstBgPtr == NULL) {
assocPtr->firstBgPtr = errPtr;
Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
} else {
assocPtr->lastBgPtr->nextPtr = errPtr;
}
assocPtr->lastBgPtr = errPtr;
Tcl_ResetResult(interp);
}
/*
*----------------------------------------------------------------------
*
* HandleBgErrors --
*
* This procedure is invoked as an idle handler to process all of
* the accumulated background errors.
*
* Results:
* None.
*
* Side effects:
* Depends on what actions "bgerror" takes for the errors.
*
*----------------------------------------------------------------------
*/
static void
HandleBgErrors(clientData)
ClientData clientData; /* Pointer to ErrAssocData structure. */
{
Tcl_Interp *interp;
CONST char *argv[2];
int code;
BgError *errPtr;
ErrAssocData *assocPtr = (ErrAssocData *) clientData;
Tcl_Channel errChannel;
Tcl_Preserve((ClientData) assocPtr);
while (assocPtr->firstBgPtr != NULL) {
interp = assocPtr->firstBgPtr->interp;
if (interp == NULL) {
goto doneWithInterp;
}
/*
* Restore important state variables to what they were at
* the time the error occurred.
*/
Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo,
TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode,
TCL_GLOBAL_ONLY);
/*
* Create and invoke the bgerror command.
*/
argv[0] = "bgerror";
argv[1] = assocPtr->firstBgPtr->errorMsg;
Tcl_AllowExceptions(interp);
Tcl_Preserve((ClientData) interp);
code = TclGlobalInvoke(interp, 2, argv, 0);
if (code == TCL_ERROR) {
/*
* If the interpreter is safe, we look for a hidden command
* named "bgerror" and call that with the error information.
* Otherwise, simply ignore the error. The rationale is that
* this could be an error caused by a malicious applet trying
* to cause an infinite barrage of error messages. The hidden
* "bgerror" command can be used by a security policy to
* interpose on such attacks and e.g. kill the applet after a
* few attempts.
*/
if (Tcl_IsSafe(interp)) {
Tcl_SavedResult save;
Tcl_SaveResult(interp, &save);
TclGlobalInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN);
Tcl_RestoreResult(interp, &save);
goto doneWithInterp;
}
/*
* We have to get the error output channel at the latest possible
* time, because the eval (above) might have changed the channel.
*/
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != (Tcl_Channel) NULL) {
char *string;
int len;
string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
if (Tcl_FindCommand(interp, "bgerror", NULL, TCL_GLOBAL_ONLY) == NULL) {
Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
Tcl_WriteChars(errChannel, "\n", -1);
} else {
Tcl_WriteChars(errChannel,
"bgerror failed to handle background error.\n",
-1);
Tcl_WriteChars(errChannel, " Original error: ", -1);
Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg,
-1);
Tcl_WriteChars(errChannel, "\n", -1);
Tcl_WriteChars(errChannel, " Error in bgerror: ", -1);
Tcl_WriteChars(errChannel, string, len);
Tcl_WriteChars(errChannel, "\n", -1);
}
Tcl_Flush(errChannel);
}
} else if (code == TCL_BREAK) {
/*
* Break means cancel any remaining error reports for this
* interpreter.
*/
for (errPtr = assocPtr->firstBgPtr; errPtr != NULL;
errPtr = errPtr->nextPtr) {
if (errPtr->interp == interp) {
errPtr->interp = NULL;
}
}
}
/*
* Discard the command and the information about the error report.
*/
doneWithInterp:
if (assocPtr->firstBgPtr) {
ckfree(assocPtr->firstBgPtr->errorMsg);
ckfree(assocPtr->firstBgPtr->errorInfo);
ckfree(assocPtr->firstBgPtr->errorCode);
errPtr = assocPtr->firstBgPtr->nextPtr;
ckfree((char *) assocPtr->firstBgPtr);
assocPtr->firstBgPtr = errPtr;
}
if (interp != NULL) {
Tcl_Release((ClientData) interp);
}
}
assocPtr->lastBgPtr = NULL;
Tcl_Release((ClientData) assocPtr);
}
/*
*----------------------------------------------------------------------
*
* BgErrorDeleteProc --
*
* This procedure is associated with the "tclBgError" assoc data
* for an interpreter; it is invoked when the interpreter is
* deleted in order to free the information assoicated with any
* pending error reports.
*
* Results:
* None.
*
* Side effects:
* Background error information is freed: if there were any
* pending error reports, they are cancelled.
*
*----------------------------------------------------------------------
*/
static void
BgErrorDeleteProc(clientData, interp)
ClientData clientData; /* Pointer to ErrAssocData structure. */
Tcl_Interp *interp; /* Interpreter being deleted. */
{
ErrAssocData *assocPtr = (ErrAssocData *) clientData;
BgError *errPtr;
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
ckfree(errPtr->errorMsg);
ckfree(errPtr->errorInfo);
ckfree(errPtr->errorCode);
ckfree((char *) errPtr);
}
Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateExitHandler --
*
* Arrange for a given procedure to be invoked just before the
* application exits.
*
* Results:
* None.
*
* Side effects:
* Proc will be invoked with clientData as argument when the
* application exits.
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateExitHandler(proc, clientData)
Tcl_ExitProc *proc; /* Procedure to invoke. */
ClientData clientData; /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstExitPtr;
firstExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
}
/*
*----------------------------------------------------------------------
*
* TclCreateLateExitHandler --
*
* Arrange for a given function to be invoked after all pre-thread cleanups
*
* Results:
* None.
*
* Side effects:
* Proc will be invoked with clientData as argument when the application
* exits.
*
*----------------------------------------------------------------------
*/
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstLateExitPtr;
firstLateExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteExitHandler --
*
* This procedure cancels an existing exit handler matching proc
* and clientData, if such a handler exits.
*
* Results:
* None.
*
* Side effects:
* If there is an exit handler corresponding to proc and clientData
* then it is cancelled; if no such handler exists then nothing
* happens.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteExitHandler(proc, clientData)
Tcl_ExitProc *proc; /* Procedure that was previously registered. */
ClientData clientData; /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
firstExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
ckfree((char *) exitPtr);
break;
}
}
Tcl_MutexUnlock(&exitMutex);
return;
}
/*
*----------------------------------------------------------------------
*
* TclDeleteLateExitHandler --
*
* This function cancels an existing late exit handler matching proc and
* clientData, if such a handler exits.
*
* Results:
* None.
*
* Side effects:
* If there is a late exit handler corresponding to proc and clientData then
* it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
void
TclDeleteLateExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstLateExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
firstLateExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
ckfree((char *) exitPtr);
break;
}
}
Tcl_MutexUnlock(&exitMutex);
return;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateThreadExitHandler --
*
* Arrange for a given procedure to be invoked just before the
* current thread exits.
*
* Results:
* None.
*
* Side effects:
* Proc will be invoked with clientData as argument when the
* application exits.
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateThreadExitHandler(proc, clientData)
Tcl_ExitProc *proc; /* Procedure to invoke. */
ClientData clientData; /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
exitPtr->nextPtr = tsdPtr->firstExitPtr;
tsdPtr->firstExitPtr = exitPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteThreadExitHandler --
*
* This procedure cancels an existing exit handler matching proc
* and clientData, if such a handler exits.
*
* Results:
* None.
*
* Side effects:
* If there is an exit handler corresponding to proc and clientData
* then it is cancelled; if no such handler exists then nothing
* happens.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteThreadExitHandler(proc, clientData)
Tcl_ExitProc *proc; /* Procedure that was previously registered. */
ClientData clientData; /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
tsdPtr->firstExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
ckfree((char *) exitPtr);
return;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_Exit --
*
* This procedure is called to terminate the application.
*
* Results:
* None.
*
* Side effects:
* All existing exit handlers are invoked, then the application
* ends.
*
*----------------------------------------------------------------------
*/
void
Tcl_Exit(status)
int status; /* Exit status for application; typically
* 0 for normal return, 1 for error return. */
{
Tcl_Finalize();
TclpExit(status);
}
/*
*-------------------------------------------------------------------------
*
* TclSetLibraryPath --
*
* Set the path that will be used for searching for init.tcl and
* encodings when an interp is being created.
*
* Results:
* None.
*
* Side effects:
* Changing the library path will affect what directories are
* examined when looking for encodings for all interps from that
* point forward.
*
* The refcount of the new library path is incremented and the
* refcount of the old path is decremented.
*
*-------------------------------------------------------------------------
*/
void
TclSetLibraryPath(pathPtr)
Tcl_Obj *pathPtr; /* A Tcl list object whose elements are
* the new library path. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
const char *toDupe;
int size;
if (pathPtr != NULL) {
Tcl_IncrRefCount(pathPtr);
}
if (tsdPtr->tclLibraryPath != NULL) {
Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
}
tsdPtr->tclLibraryPath = pathPtr;
/*
* No mutex locking is needed here as up the stack we're within
* TclpInitLock().
*/
if (tclLibraryPathStr != NULL) {
ckfree(tclLibraryPathStr);
}
toDupe = Tcl_GetStringFromObj(pathPtr, &size);
tclLibraryPathStr = ckalloc((unsigned)size+1);
memcpy(tclLibraryPathStr, toDupe, (unsigned)size+1);
}
/*
*-------------------------------------------------------------------------
*
* TclGetLibraryPath --
*
* Return a Tcl list object whose elements are the library path.
* The caller should not modify the contents of the returned object.
*
* Results:
* As above.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
Tcl_Obj *
TclGetLibraryPath()
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->tclLibraryPath == NULL) {
/*
* Grab the shared string and place it into a new thread specific
* Tcl_Obj.
*/
tsdPtr->tclLibraryPath = Tcl_NewStringObj(tclLibraryPathStr, -1);
/* take ownership */
Tcl_IncrRefCount(tsdPtr->tclLibraryPath);
}
return tsdPtr->tclLibraryPath;
}
/*
*-------------------------------------------------------------------------
*
* TclInitSubsystems --
*
* Initialize various subsytems in Tcl. This should be called the
* first time an interp is created, or before any of the subsystems
* are used. This function ensures an order for the initialization
* of subsystems:
*
* 1. that cannot be initialized in lazy order because they are
* mutually dependent.
*
* 2. so that they can be finalized in a known order w/o causing
* the subsequent re-initialization of a subsystem in the act of
* shutting down another.
*
* Results:
* None.
*
* Side effects:
* Varied, see the respective initialization routines.
*
*-------------------------------------------------------------------------
*/
void
TclInitSubsystems(argv0)
CONST char *argv0; /* Name of executable from argv[0] to main()
* in native multi-byte encoding. */
{
ThreadSpecificData *tsdPtr;
if (inFinalize != 0) {
panic("TclInitSubsystems called while finalizing");
}
/*
* Grab the thread local storage pointer before doing anything because
* the initialization routines will be registering exit handlers.
* We use this pointer to detect if this is the first time this
* thread has created an interpreter.
*/
tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
if (subsystemsInitialized == 0) {
/*
* Double check inside the mutex. There are definitly calls
* back into this routine from some of the procedures below.
*/
TclpInitLock();
if (subsystemsInitialized == 0) {
/*
* Have to set this bit here to avoid deadlock with the
* routines below us that call into TclInitSubsystems.
*/
subsystemsInitialized = 1;
tclExecutableName = NULL;
/*
* Initialize locks used by the memory allocators before anything
* interesting happens so we can use the allocators in the
* implementation of self-initializing locks.
*/
#if USE_TCLALLOC
TclInitAlloc(); /* process wide mutex init */
#endif
#ifdef TCL_MEM_DEBUG
TclInitDbCkalloc(); /* process wide mutex init */
#endif
TclpInitPlatform(); /* creates signal handler(s) */
TclInitObjSubsystem(); /* register obj types, create mutexes */
TclInitIOSubsystem(); /* inits a tsd key (noop) */
TclInitEncodingSubsystem(); /* process wide encoding init */
TclInitNamespaceSubsystem(); /* register ns obj type (mutexed) */
}
TclpInitUnlock();
}
if (tsdPtr == NULL) {
/*
* First time this thread has created an interpreter.
* We fetch the key again just in case no exit handlers were
* registered by this point.
*/
(void) TCL_TSD_INIT(&dataKey);
TclInitNotifier();
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_Finalize --
*
* Shut down Tcl. First calls registered exit handlers, then
* carefully shuts down various subsystems.
* Called by Tcl_Exit or when the Tcl shared library is being
* unloaded.
*
* Results:
* None.
*
* Side effects:
* Varied, see the respective finalization routines.
*
*----------------------------------------------------------------------
*/
void
Tcl_Finalize()
{
ExitHandler *exitPtr;
/*
* Invoke exit handlers first.
*/
Tcl_MutexLock(&exitMutex);
inFinalize = 1;
for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
/*
* Be careful to remove the handler from the list before
* invoking its callback. This protects us against
* double-freeing if the callback should call
* Tcl_DeleteExitHandler on itself.
*/
firstExitPtr = exitPtr->nextPtr;
Tcl_MutexUnlock(&exitMutex);
(*exitPtr->proc)(exitPtr->clientData);
ckfree((char *) exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
TclpInitLock();
if (subsystemsInitialized != 0) {
subsystemsInitialized = 0;
/*
* Ensure the thread-specific data is initialised as it is
* used in Tcl_FinalizeThread()
*/
(void) TCL_TSD_INIT(&dataKey);
/*
* Clean up after the current thread now, after exit handlers.
* In particular, the testexithandler command sets up something
* that writes to standard output, which gets closed.
* Note that there is no thread-local storage after this call.
*/
Tcl_FinalizeThread();
/*
* Now invoke late (process-wide) exit handlers.
*/
Tcl_MutexLock(&exitMutex);
for (exitPtr = firstLateExitPtr; exitPtr != NULL; exitPtr = firstLateExitPtr) {
/*
* Be careful to remove the handler from the list before invoking its
* callback. This protects us against double-freeing if the callback
* should call Tcl_DeleteLateExitHandler on itself.
*/
firstLateExitPtr = exitPtr->nextPtr;
Tcl_MutexUnlock(&exitMutex);
exitPtr->proc(exitPtr->clientData);
ckfree((char *) exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstLateExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
/*
* Now finalize the Tcl execution environment. Note that this must be done
* after the exit handlers, because there are order dependencies.
*/
TclFinalizeCompilation();
TclFinalizeExecution();
TclFinalizeEnvironment();
/*
* Finalizing the filesystem must come after anything which
* might conceivably interact with the 'Tcl_FS' API.
*/
TclFinalizeFilesystem();
/*
* Undo all the Tcl_ObjType registrations, and reset the master list
* of free Tcl_Obj's. After this returns, no more Tcl_Obj's should
* be allocated or freed.
*
* Note in particular that TclFinalizeObjects() must follow
* TclFinalizeFilesystem() because TclFinalizeFilesystem free's
* the Tcl_Obj that holds the path of the current working directory.
*/
TclFinalizeObjects();
/*
* We must be sure the encoding finalization doesn't need
* to examine the filesystem in any way. Since it only
* needs to clean up internal data structures, this is
* fine.
*/
TclFinalizeEncodingSubsystem();
if (tclExecutableName != NULL) {
ckfree(tclExecutableName);
tclExecutableName = NULL;
}
if (tclNativeExecutableName != NULL) {
ckfree(tclNativeExecutableName);
tclNativeExecutableName = NULL;
}
if (tclDefaultEncodingDir != NULL) {
ckfree(tclDefaultEncodingDir);
tclDefaultEncodingDir = NULL;
}
if (tclLibraryPathStr != NULL) {
ckfree(tclLibraryPathStr);
tclLibraryPathStr = NULL;
}
Tcl_SetPanicProc(NULL);
/*
* There have been several bugs in the past that cause
* exit handlers to be established during Tcl_Finalize
* processing. Such exit handlers leave malloc'ed memory,
* and Tcl_FinalizeThreadAlloc or Tcl_FinalizeMemorySubsystem
* will result in a corrupted heap. The result can be a
* mysterious crash on process exit. Check here that
* nobody's done this.
*/
#ifdef TCL_MEM_DEBUG
if ( firstExitPtr != NULL ) {
Tcl_Panic( "exit handlers were created during Tcl_Finalize" );
}
#endif
TclFinalizePreserve();
/*
* Free synchronization objects. There really should only be one
* thread alive at this moment.
*/
TclFinalizeSynchronization();
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) && !defined(TCL_MEM_DEBUG) && !defined(PURIFY)
TclFinalizeThreadAlloc();
#endif
/*
* We defer unloading of packages until very late
* to avoid memory access issues. Both exit callbacks and
* synchronization variables may be stored in packages.
*
* Note that TclFinalizeLoad unloads packages in the reverse
* of the order they were loaded in (i.e. last to be loaded
* is the first to be unloaded). This can be important for
* correct unloading when dependencies exist.
*
* Once load has been finalized, we will have deleted any
* temporary copies of shared libraries and can therefore
* reset the filesystem to its original state.
*/
TclFinalizeLoad();
TclResetFilesystem();
/*
* At this point, there should no longer be any ckalloc'ed memory.
*/
TclFinalizeMemorySubsystem();
inFinalize = 0;
}
TclFinalizeLock();
}
/*
*----------------------------------------------------------------------
*
* Tcl_FinalizeThread --
*
* Runs the exit handlers to allow Tcl to clean up its state
* about a particular thread.
*
* Results:
* None.
*
* Side effects:
* Varied, see the respective finalization routines.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeThread()
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr;
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
tsdPtr->inExit = 1;
/*
* Clean up the library path now, before we invalidate thread-local
* storage or calling thread exit handlers.
*/
if (tsdPtr->tclLibraryPath != NULL) {
Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
tsdPtr->tclLibraryPath = NULL;
}
for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
exitPtr = tsdPtr->firstExitPtr) {
/*
* Be careful to remove the handler from the list before invoking
* its callback. This protects us against double-freeing if the
* callback should call Tcl_DeleteThreadExitHandler on itself.
*/
tsdPtr->firstExitPtr = exitPtr->nextPtr;
(*exitPtr->proc)(exitPtr->clientData);
ckfree((char *) exitPtr);
}
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
TclFinalizeAsync();
}
/*
* Blow away all thread local storage blocks.
*
* Note that Tcl API allows creation of threads which do not use any
* Tcl interp or other Tcl subsytems. Those threads might, however,
* use thread local storage, so we must unconditionally finalize it.
*
* Fix [Bug #571002]
*/
TclFinalizeThreadData();
}
/*
*----------------------------------------------------------------------
*
* TclInExit --
*
* Determines if we are in the middle of exit-time cleanup.
*
* Results:
* If we are in the middle of exiting, 1, otherwise 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclInExit()
{
return inFinalize;
}
/*
*----------------------------------------------------------------------
*
* TclInThreadExit --
*
* Determines if we are in the middle of thread exit-time cleanup.
*
* Results:
* If we are in the middle of exiting this thread, 1, otherwise 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclInThreadExit()
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
return 0;
} else {
return tsdPtr->inExit;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_VwaitObjCmd --
*
* This procedure is invoked to process the "vwait" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_VwaitObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int done, foundEvent;
char *nameString;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
nameString = Tcl_GetString(objv[1]);
if (Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, (ClientData) &done) != TCL_OK) {
return TCL_ERROR;
};
done = 0;
foundEvent = 1;
while (!done && foundEvent) {
foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
}
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, (ClientData) &done);
/*
* Clear out the interpreter's result, since it may have been set
* by event handlers.
*/
Tcl_ResetResult(interp);
if (!foundEvent) {
Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
"\": would wait forever", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/* ARGSUSED */
static char *
VwaitVarProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Pointer to integer to set to 1. */
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *name1; /* Name of variable. */
CONST char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
{
int *donePtr = (int *) clientData;
*donePtr = 1;
return (char *) NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpdateObjCmd --
*
* This procedure is invoked to process the "update" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_UpdateObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int optionIndex;
int flags = 0; /* Initialized to avoid compiler warning. */
static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
enum updateOptions {REGEXP_IDLETASKS};
if (objc == 1) {
flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
} else if (objc == 2) {
if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
"option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum updateOptions) optionIndex) {
case REGEXP_IDLETASKS: {
flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
break;
}
default: {
panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
}
}
} else {
Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
return TCL_ERROR;
}
while (Tcl_DoOneEvent(flags) != 0) {
/* Empty loop body */
}
/*
* Must clear the interpreter's result because event handlers could
* have executed commands.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
#ifdef TCL_THREADS
/*
*-----------------------------------------------------------------------------
*
* NewThreadProc --
*
* Bootstrap function of a new Tcl thread.
*
* Results:
* None.
*
* Side Effects:
* Initializes Tcl notifier for the current thread.
*
*-----------------------------------------------------------------------------
*/
static Tcl_ThreadCreateType
NewThreadProc(ClientData clientData)
{
ThreadClientData *cdPtr;
ClientData threadClientData;
Tcl_ThreadCreateProc *threadProc;
cdPtr = (ThreadClientData*)clientData;
threadProc = cdPtr->proc;
threadClientData = cdPtr->clientData;
ckfree((char*)clientData); /* Allocated in Tcl_CreateThread() */
(*threadProc)(threadClientData);
TCL_THREAD_CREATE_RETURN;
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_CreateThread --
*
* This procedure creates a new thread. This actually belongs
* to the tclThread.c file but since we use some private
* data structures local to this file, it is placed here.
*
* Results:
* TCL_OK if the thread could be created. The thread ID is
* returned in a parameter.
*
* Side effects:
* A new thread is created.
*
*----------------------------------------------------------------------
*/
int
Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags)
Tcl_ThreadId *idPtr; /* Return, the ID of the thread */
Tcl_ThreadCreateProc proc; /* Main() function of the thread */
ClientData clientData; /* The one argument to Main() */
int stackSize; /* Size of stack for the new thread */
int flags; /* Flags controlling behaviour of
* the new thread */
{
#ifdef TCL_THREADS
ThreadClientData *cdPtr;
cdPtr = (ThreadClientData*)ckalloc(sizeof(ThreadClientData));
cdPtr->proc = proc;
cdPtr->clientData = clientData;
return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr,
stackSize, flags);
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
}
tcl8.4.20/generic/tclStubInit.c 0000644 0036047 0045461 00000107651 12144442333 014743 0 ustar dgp 771div /*
* tclStubInit.c --
*
* This file contains the initializers for the Tcl stub vectors.
*
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* Remove macros that will interfere with the definitions below.
*/
#undef Tcl_Alloc
#undef Tcl_Free
#undef Tcl_Realloc
#undef Tcl_NewBooleanObj
#undef Tcl_NewByteArrayObj
#undef Tcl_NewDoubleObj
#undef Tcl_NewIntObj
#undef Tcl_NewListObj
#undef Tcl_NewLongObj
#undef Tcl_NewObj
#undef Tcl_NewStringObj
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
#undef Tcl_FindHashEntry
#undef Tcl_CreateHashEntry
#undef TclpGetPid
#undef TclSockMinimumBuffers
#define TclUnusedStubEntry NULL
/*
* Keep a record of the original Notifier procedures, created in the
* same compilation unit as the stub tables so we can later do reliable,
* portable comparisons to see whether a Tcl_SetNotifier() call swapped
* new routines into the stub table.
*/
Tcl_NotifierProcs tclOriginalNotifier = {
Tcl_SetTimer,
Tcl_WaitForEvent,
#if !defined(__WIN32__) /* UNIX */
Tcl_CreateFileHandler,
Tcl_DeleteFileHandler,
#else
NULL,
NULL,
#endif
NULL,
NULL,
NULL,
NULL
};
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
#ifdef _WIN64
# define TclSockMinimumBuffersOld 0
#else
int TclSockMinimumBuffersOld(sock, size)
int sock;
int size;
{
return TclSockMinimumBuffers((void *) (size_t) sock, size);
}
#endif
#ifdef __WIN32__
# define TclUnixWaitForFile 0
# define TclpReaddir 0
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
# define TclpIsAtty TclPlatIsAtty
# define TclWinSetInterfaces (void (*) (int)) doNothing
# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
# define TclWinFlushDirtyChannels doNothing
# define TclWinResetInterfaces doNothing
# define TclpGetTZName 0
static Tcl_Encoding winTCharEncoding;
static int
TclpIsAtty(int fd)
{
return isatty(fd);
}
int
TclWinGetPlatformId()
{
/* Don't bother to determine the real platform on cygwin,
* because VER_PLATFORM_WIN32_NT is the only supported platform */
return 2; /* VER_PLATFORM_WIN32_NT */;
}
TclPlatformType *
TclWinGetPlatform()
{
return &tclPlatform;
}
void *TclWinGetTclInstance()
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
(const char *)&winTCharEncoding, &hInstance);
return hInstance;
}
unsigned short
TclWinNToHS(unsigned short ns)
{
return ntohs(ns);
}
int
TclWinSetSockOpt(SOCKET s, int level, int optname,
const char *optval, int optlen)
{
return setsockopt((int) s, level, optname, optval, optlen);
}
int
TclWinGetSockOpt(SOCKET s, int level, int optname,
char *optval, int *optlen)
{
return getsockopt((int) s, level, optname, optval, optlen);
}
struct servent *
TclWinGetServByName(const char *name, const char *proto)
{
return getservbyname(name, proto);
}
char *
TclWinNoBackslash(char *path)
{
char *p;
for (p = path; *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
}
}
return path;
}
int
TclpGetPid(Tcl_Pid pid)
{
return (int) (size_t) pid;
}
static void
doNothing(void)
{
/* dummy implementation, no need to do anything */
}
char *
Tcl_WinUtfToTChar(
const char *string,
int len,
Tcl_DString *dsPtr)
{
if (!winTCharEncoding) {
winTCharEncoding = Tcl_GetEncoding(0, "unicode");
}
return Tcl_UtfToExternalDString(winTCharEncoding,
string, len, dsPtr);
}
char *
Tcl_WinTCharToUtf(
const char *string,
int len,
Tcl_DString *dsPtr)
{
if (!winTCharEncoding) {
winTCharEncoding = Tcl_GetEncoding(0, "unicode");
}
return Tcl_ExternalToUtfDString(winTCharEncoding,
string, len, dsPtr);
}
#if defined(TCL_WIDE_INT_IS_LONG)
/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
* we have to make sure that all stub entries on Cygwin64 follow the Win64
* signature. Tcl 9 must find a better solution, but that cannot be done
* without introducing a binary incompatibility.
*/
#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))dbNewLongObj)
static Tcl_Obj *dbNewLongObj(
int intValue,
const char *file,
int line
) {
#ifdef TCL_MEM_DEBUG
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
objPtr->internalRep.longValue = (long) intValue;
objPtr->typePtr = &tclIntType;
return objPtr;
#else
return Tcl_NewIntObj(intValue);
#endif
}
#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetIntFromObj
#define Tcl_NewLongObj (Tcl_Obj*(*)(long))Tcl_NewIntObj
#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))Tcl_SetIntObj
static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
long longValue;
int result = Tcl_ExprLong(interp, expr, &longValue);
if (result == TCL_OK) {
if ((longValue >= -(long)(UINT_MAX))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
Tcl_SetResult(interp,
"integer value too large to represent as non-long integer",
TCL_STATIC);
result = TCL_ERROR;
}
}
return result;
}
#define Tcl_ExprLong (int(*)(Tcl_Interp*,const char*,long*))exprInt
static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
long longValue;
int result = Tcl_ExprLongObj(interp, expr, &longValue);
if (result == TCL_OK) {
if ((longValue >= -(long)(UINT_MAX))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
Tcl_SetResult(interp,
"integer value too large to represent as non-long integer",
TCL_STATIC);
result = TCL_ERROR;
}
}
return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n);
}
#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcmp
static int utfNcmp(const char *s1, const char *s2, unsigned int n){
return Tcl_UtfNcmp(s1, s2, (unsigned long)n);
}
#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))utfNcmp
static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){
return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n);
}
#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp
static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n);
}
#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp
static int formatInt(char *buffer, int n){
return TclFormatInt(buffer, (long)n);
}
#define TclFormatInt (int(*)(char *, long))formatInt
#endif
#else /* UNIX and MAC */
# define TclpGetPid 0
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
#endif
/*
* WARNING: The contents of this file is automatically generated by the
* tools/genStubs.tcl script. Any modifications to the function declarations
* below should be made in the generic/tcl.decls script.
*/
/* !BEGIN!: Do not edit below this line. */
TclIntStubs tclIntStubs = {
TCL_STUB_MAGIC,
NULL,
NULL, /* 0 */
TclAccessDeleteProc, /* 1 */
TclAccessInsertProc, /* 2 */
TclAllocateFreeObjects, /* 3 */
NULL, /* 4 */
TclCleanupChildren, /* 5 */
TclCleanupCommand, /* 6 */
TclCopyAndCollapse, /* 7 */
TclCopyChannel, /* 8 */
TclCreatePipeline, /* 9 */
TclCreateProc, /* 10 */
TclDeleteCompiledLocalVars, /* 11 */
TclDeleteVars, /* 12 */
TclDoGlob, /* 13 */
TclDumpMemoryInfo, /* 14 */
NULL, /* 15 */
TclExprFloatError, /* 16 */
NULL, /* 17 */
NULL, /* 18 */
NULL, /* 19 */
NULL, /* 20 */
NULL, /* 21 */
TclFindElement, /* 22 */
TclFindProc, /* 23 */
TclFormatInt, /* 24 */
TclFreePackageInfo, /* 25 */
NULL, /* 26 */
TclGetDate, /* 27 */
TclpGetDefaultStdChannel, /* 28 */
NULL, /* 29 */
NULL, /* 30 */
TclGetExtension, /* 31 */
TclGetFrame, /* 32 */
TclGetInterpProc, /* 33 */
TclGetIntForIndex, /* 34 */
NULL, /* 35 */
TclGetLong, /* 36 */
TclGetLoadedPackages, /* 37 */
TclGetNamespaceForQualName, /* 38 */
TclGetObjInterpProc, /* 39 */
TclGetOpenMode, /* 40 */
TclGetOriginalCommand, /* 41 */
TclpGetUserHome, /* 42 */
TclGlobalInvoke, /* 43 */
TclGuessPackageName, /* 44 */
TclHideUnsafeCommands, /* 45 */
TclInExit, /* 46 */
NULL, /* 47 */
NULL, /* 48 */
TclIncrVar2, /* 49 */
TclInitCompiledLocals, /* 50 */
TclInterpInit, /* 51 */
TclInvoke, /* 52 */
TclInvokeObjectCommand, /* 53 */
TclInvokeStringCommand, /* 54 */
TclIsProc, /* 55 */
NULL, /* 56 */
NULL, /* 57 */
TclLookupVar, /* 58 */
NULL, /* 59 */
TclNeedSpace, /* 60 */
TclNewProcBodyObj, /* 61 */
TclObjCommandComplete, /* 62 */
TclObjInterpProc, /* 63 */
TclObjInvoke, /* 64 */
TclObjInvokeGlobal, /* 65 */
TclOpenFileChannelDeleteProc, /* 66 */
TclOpenFileChannelInsertProc, /* 67 */
NULL, /* 68 */
TclpAlloc, /* 69 */
NULL, /* 70 */
NULL, /* 71 */
NULL, /* 72 */
NULL, /* 73 */
TclpFree, /* 74 */
TclpGetClicks, /* 75 */
TclpGetSeconds, /* 76 */
TclpGetTime, /* 77 */
TclpGetTimeZone, /* 78 */
NULL, /* 79 */
NULL, /* 80 */
TclpRealloc, /* 81 */
NULL, /* 82 */
NULL, /* 83 */
NULL, /* 84 */
NULL, /* 85 */
NULL, /* 86 */
NULL, /* 87 */
TclPrecTraceProc, /* 88 */
TclPreventAliasLoop, /* 89 */
NULL, /* 90 */
TclProcCleanupProc, /* 91 */
TclProcCompileProc, /* 92 */
TclProcDeleteProc, /* 93 */
TclProcInterpProc, /* 94 */
NULL, /* 95 */
TclRenameCommand, /* 96 */
TclResetShadowedCmdRefs, /* 97 */
TclServiceIdle, /* 98 */
NULL, /* 99 */
NULL, /* 100 */
TclSetPreInitScript, /* 101 */
TclSetupEnv, /* 102 */
TclSockGetPort, /* 103 */
TclSockMinimumBuffersOld, /* 104 */
NULL, /* 105 */
TclStatDeleteProc, /* 106 */
TclStatInsertProc, /* 107 */
TclTeardownNamespace, /* 108 */
TclUpdateReturnInfo, /* 109 */
TclSockMinimumBuffers, /* 110 */
Tcl_AddInterpResolvers, /* 111 */
Tcl_AppendExportList, /* 112 */
Tcl_CreateNamespace, /* 113 */
Tcl_DeleteNamespace, /* 114 */
Tcl_Export, /* 115 */
Tcl_FindCommand, /* 116 */
Tcl_FindNamespace, /* 117 */
Tcl_GetInterpResolvers, /* 118 */
Tcl_GetNamespaceResolvers, /* 119 */
Tcl_FindNamespaceVar, /* 120 */
Tcl_ForgetImport, /* 121 */
Tcl_GetCommandFromObj, /* 122 */
Tcl_GetCommandFullName, /* 123 */
Tcl_GetCurrentNamespace, /* 124 */
Tcl_GetGlobalNamespace, /* 125 */
Tcl_GetVariableFullName, /* 126 */
Tcl_Import, /* 127 */
Tcl_PopCallFrame, /* 128 */
Tcl_PushCallFrame, /* 129 */
Tcl_RemoveInterpResolvers, /* 130 */
Tcl_SetNamespaceResolvers, /* 131 */
TclpHasSockets, /* 132 */
TclpGetDate, /* 133 */
TclpStrftime, /* 134 */
TclpCheckStackSpace, /* 135 */
NULL, /* 136 */
NULL, /* 137 */
TclGetEnv, /* 138 */
NULL, /* 139 */
TclLooksLikeInt, /* 140 */
TclpGetCwd, /* 141 */
TclSetByteCodeFromAny, /* 142 */
TclAddLiteralObj, /* 143 */
TclHideLiteral, /* 144 */
TclGetAuxDataType, /* 145 */
TclHandleCreate, /* 146 */
TclHandleFree, /* 147 */
TclHandlePreserve, /* 148 */
TclHandleRelease, /* 149 */
TclRegAbout, /* 150 */
TclRegExpRangeUniChar, /* 151 */
TclSetLibraryPath, /* 152 */
TclGetLibraryPath, /* 153 */
NULL, /* 154 */
NULL, /* 155 */
TclRegError, /* 156 */
TclVarTraceExists, /* 157 */
TclSetStartupScriptFileName, /* 158 */
TclGetStartupScriptFileName, /* 159 */
NULL, /* 160 */
TclChannelTransform, /* 161 */
TclChannelEventScriptInvoker, /* 162 */
TclGetInstructionTable, /* 163 */
TclExpandCodeArray, /* 164 */
TclpSetInitialEncodings, /* 165 */
TclListObjSetElement, /* 166 */
TclSetStartupScriptPath, /* 167 */
TclGetStartupScriptPath, /* 168 */
TclpUtfNcmp2, /* 169 */
TclCheckInterpTraces, /* 170 */
TclCheckExecutionTraces, /* 171 */
TclInThreadExit, /* 172 */
TclUniCharMatch, /* 173 */
NULL, /* 174 */
NULL, /* 175 */
NULL, /* 176 */
NULL, /* 177 */
NULL, /* 178 */
NULL, /* 179 */
NULL, /* 180 */
NULL, /* 181 */
TclpLocaltime, /* 182 */
TclpGmtime, /* 183 */
NULL, /* 184 */
NULL, /* 185 */
NULL, /* 186 */
NULL, /* 187 */
NULL, /* 188 */
NULL, /* 189 */
NULL, /* 190 */
NULL, /* 191 */
NULL, /* 192 */
NULL, /* 193 */
NULL, /* 194 */
NULL, /* 195 */
NULL, /* 196 */
NULL, /* 197 */
NULL, /* 198 */
TclMatchIsTrivial, /* 199 */
NULL, /* 200 */
NULL, /* 201 */
NULL, /* 202 */
NULL, /* 203 */
NULL, /* 204 */
NULL, /* 205 */
NULL, /* 206 */
NULL, /* 207 */
NULL, /* 208 */
NULL, /* 209 */
NULL, /* 210 */
NULL, /* 211 */
NULL, /* 212 */
NULL, /* 213 */
NULL, /* 214 */
NULL, /* 215 */
NULL, /* 216 */
NULL, /* 217 */
NULL, /* 218 */
NULL, /* 219 */
NULL, /* 220 */
NULL, /* 221 */
NULL, /* 222 */
NULL, /* 223 */
NULL, /* 224 */
NULL, /* 225 */
NULL, /* 226 */
NULL, /* 227 */
NULL, /* 228 */
NULL, /* 229 */
NULL, /* 230 */
NULL, /* 231 */
NULL, /* 232 */
NULL, /* 233 */
NULL, /* 234 */
NULL, /* 235 */
NULL, /* 236 */
NULL, /* 237 */
NULL, /* 238 */
NULL, /* 239 */
NULL, /* 240 */
NULL, /* 241 */
NULL, /* 242 */
NULL, /* 243 */
NULL, /* 244 */
NULL, /* 245 */
NULL, /* 246 */
NULL, /* 247 */
NULL, /* 248 */
TclUnusedStubEntry, /* 249 */
};
TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
NULL,
#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
NULL, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
TclpCreateTempFile, /* 9 */
TclpReaddir, /* 10 */
TclpLocaltime_unix, /* 11 */
TclpGmtime_unix, /* 12 */
TclpInetNtoa, /* 13 */
NULL, /* 14 */
NULL, /* 15 */
NULL, /* 16 */
NULL, /* 17 */
NULL, /* 18 */
NULL, /* 19 */
NULL, /* 20 */
NULL, /* 21 */
NULL, /* 22 */
NULL, /* 23 */
NULL, /* 24 */
NULL, /* 25 */
NULL, /* 26 */
NULL, /* 27 */
NULL, /* 28 */
TclWinCPUID, /* 29 */
#endif /* UNIX */
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
TclWinConvertError, /* 0 */
TclWinConvertWSAError, /* 1 */
TclWinGetServByName, /* 2 */
TclWinGetSockOpt, /* 3 */
TclWinGetTclInstance, /* 4 */
TclUnixWaitForFile, /* 5 */
TclWinNToHS, /* 6 */
TclWinSetSockOpt, /* 7 */
TclpGetPid, /* 8 */
TclWinGetPlatformId, /* 9 */
TclpReaddir, /* 10 */
TclGetAndDetachPids, /* 11 */
TclpCloseFile, /* 12 */
TclpCreateCommandChannel, /* 13 */
TclpCreatePipe, /* 14 */
TclpCreateProcess, /* 15 */
TclpIsAtty, /* 16 */
NULL, /* 17 */
TclpMakeFile, /* 18 */
TclpOpenFile, /* 19 */
TclWinAddProcess, /* 20 */
TclpInetNtoa, /* 21 */
TclpCreateTempFile, /* 22 */
TclpGetTZName, /* 23 */
TclWinNoBackslash, /* 24 */
TclWinGetPlatform, /* 25 */
TclWinSetInterfaces, /* 26 */
TclWinFlushDirtyChannels, /* 27 */
TclWinResetInterfaces, /* 28 */
TclWinCPUID, /* 29 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
NULL, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
TclpCreateTempFile, /* 9 */
TclpReaddir, /* 10 */
TclpLocaltime_unix, /* 11 */
TclpGmtime_unix, /* 12 */
TclpInetNtoa, /* 13 */
NULL, /* 14 */
NULL, /* 15 */
NULL, /* 16 */
NULL, /* 17 */
NULL, /* 18 */
NULL, /* 19 */
NULL, /* 20 */
NULL, /* 21 */
NULL, /* 22 */
NULL, /* 23 */
NULL, /* 24 */
NULL, /* 25 */
NULL, /* 26 */
NULL, /* 27 */
NULL, /* 28 */
TclWinCPUID, /* 29 */
#endif /* MACOSX */
};
TclPlatStubs tclPlatStubs = {
TCL_STUB_MAGIC,
NULL,
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
Tcl_WinUtfToTChar, /* 0 */
Tcl_WinTCharToUtf, /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_MacOSXOpenBundleResources, /* 0 */
Tcl_MacOSXOpenVersionedBundleResources, /* 1 */
#endif /* MACOSX */
};
static TclStubHooks tclStubHooks = {
&tclPlatStubs,
&tclIntStubs,
&tclIntPlatStubs
};
TclStubs tclStubs = {
TCL_STUB_MAGIC,
&tclStubHooks,
Tcl_PkgProvideEx, /* 0 */
Tcl_PkgRequireEx, /* 1 */
Tcl_Panic, /* 2 */
Tcl_Alloc, /* 3 */
Tcl_Free, /* 4 */
Tcl_Realloc, /* 5 */
Tcl_DbCkalloc, /* 6 */
Tcl_DbCkfree, /* 7 */
Tcl_DbCkrealloc, /* 8 */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
Tcl_CreateFileHandler, /* 9 */
#endif /* UNIX */
#if defined(__WIN32__) /* WIN */
NULL, /* 9 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_CreateFileHandler, /* 9 */
#endif /* MACOSX */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
Tcl_DeleteFileHandler, /* 10 */
#endif /* UNIX */
#if defined(__WIN32__) /* WIN */
NULL, /* 10 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_DeleteFileHandler, /* 10 */
#endif /* MACOSX */
Tcl_SetTimer, /* 11 */
Tcl_Sleep, /* 12 */
Tcl_WaitForEvent, /* 13 */
Tcl_AppendAllObjTypes, /* 14 */
Tcl_AppendStringsToObj, /* 15 */
Tcl_AppendToObj, /* 16 */
Tcl_ConcatObj, /* 17 */
Tcl_ConvertToType, /* 18 */
Tcl_DbDecrRefCount, /* 19 */
Tcl_DbIncrRefCount, /* 20 */
Tcl_DbIsShared, /* 21 */
Tcl_DbNewBooleanObj, /* 22 */
Tcl_DbNewByteArrayObj, /* 23 */
Tcl_DbNewDoubleObj, /* 24 */
Tcl_DbNewListObj, /* 25 */
Tcl_DbNewLongObj, /* 26 */
Tcl_DbNewObj, /* 27 */
Tcl_DbNewStringObj, /* 28 */
Tcl_DuplicateObj, /* 29 */
TclFreeObj, /* 30 */
Tcl_GetBoolean, /* 31 */
Tcl_GetBooleanFromObj, /* 32 */
Tcl_GetByteArrayFromObj, /* 33 */
Tcl_GetDouble, /* 34 */
Tcl_GetDoubleFromObj, /* 35 */
Tcl_GetIndexFromObj, /* 36 */
Tcl_GetInt, /* 37 */
Tcl_GetIntFromObj, /* 38 */
Tcl_GetLongFromObj, /* 39 */
Tcl_GetObjType, /* 40 */
Tcl_GetStringFromObj, /* 41 */
Tcl_InvalidateStringRep, /* 42 */
Tcl_ListObjAppendList, /* 43 */
Tcl_ListObjAppendElement, /* 44 */
Tcl_ListObjGetElements, /* 45 */
Tcl_ListObjIndex, /* 46 */
Tcl_ListObjLength, /* 47 */
Tcl_ListObjReplace, /* 48 */
Tcl_NewBooleanObj, /* 49 */
Tcl_NewByteArrayObj, /* 50 */
Tcl_NewDoubleObj, /* 51 */
Tcl_NewIntObj, /* 52 */
Tcl_NewListObj, /* 53 */
Tcl_NewLongObj, /* 54 */
Tcl_NewObj, /* 55 */
Tcl_NewStringObj, /* 56 */
Tcl_SetBooleanObj, /* 57 */
Tcl_SetByteArrayLength, /* 58 */
Tcl_SetByteArrayObj, /* 59 */
Tcl_SetDoubleObj, /* 60 */
Tcl_SetIntObj, /* 61 */
Tcl_SetListObj, /* 62 */
Tcl_SetLongObj, /* 63 */
Tcl_SetObjLength, /* 64 */
Tcl_SetStringObj, /* 65 */
Tcl_AddErrorInfo, /* 66 */
Tcl_AddObjErrorInfo, /* 67 */
Tcl_AllowExceptions, /* 68 */
Tcl_AppendElement, /* 69 */
Tcl_AppendResult, /* 70 */
Tcl_AsyncCreate, /* 71 */
Tcl_AsyncDelete, /* 72 */
Tcl_AsyncInvoke, /* 73 */
Tcl_AsyncMark, /* 74 */
Tcl_AsyncReady, /* 75 */
Tcl_BackgroundError, /* 76 */
Tcl_Backslash, /* 77 */
Tcl_BadChannelOption, /* 78 */
Tcl_CallWhenDeleted, /* 79 */
Tcl_CancelIdleCall, /* 80 */
Tcl_Close, /* 81 */
Tcl_CommandComplete, /* 82 */
Tcl_Concat, /* 83 */
Tcl_ConvertElement, /* 84 */
Tcl_ConvertCountedElement, /* 85 */
Tcl_CreateAlias, /* 86 */
Tcl_CreateAliasObj, /* 87 */
Tcl_CreateChannel, /* 88 */
Tcl_CreateChannelHandler, /* 89 */
Tcl_CreateCloseHandler, /* 90 */
Tcl_CreateCommand, /* 91 */
Tcl_CreateEventSource, /* 92 */
Tcl_CreateExitHandler, /* 93 */
Tcl_CreateInterp, /* 94 */
Tcl_CreateMathFunc, /* 95 */
Tcl_CreateObjCommand, /* 96 */
Tcl_CreateSlave, /* 97 */
Tcl_CreateTimerHandler, /* 98 */
Tcl_CreateTrace, /* 99 */
Tcl_DeleteAssocData, /* 100 */
Tcl_DeleteChannelHandler, /* 101 */
Tcl_DeleteCloseHandler, /* 102 */
Tcl_DeleteCommand, /* 103 */
Tcl_DeleteCommandFromToken, /* 104 */
Tcl_DeleteEvents, /* 105 */
Tcl_DeleteEventSource, /* 106 */
Tcl_DeleteExitHandler, /* 107 */
Tcl_DeleteHashEntry, /* 108 */
Tcl_DeleteHashTable, /* 109 */
Tcl_DeleteInterp, /* 110 */
Tcl_DetachPids, /* 111 */
Tcl_DeleteTimerHandler, /* 112 */
Tcl_DeleteTrace, /* 113 */
Tcl_DontCallWhenDeleted, /* 114 */
Tcl_DoOneEvent, /* 115 */
Tcl_DoWhenIdle, /* 116 */
Tcl_DStringAppend, /* 117 */
Tcl_DStringAppendElement, /* 118 */
Tcl_DStringEndSublist, /* 119 */
Tcl_DStringFree, /* 120 */
Tcl_DStringGetResult, /* 121 */
Tcl_DStringInit, /* 122 */
Tcl_DStringResult, /* 123 */
Tcl_DStringSetLength, /* 124 */
Tcl_DStringStartSublist, /* 125 */
Tcl_Eof, /* 126 */
Tcl_ErrnoId, /* 127 */
Tcl_ErrnoMsg, /* 128 */
Tcl_Eval, /* 129 */
Tcl_EvalFile, /* 130 */
Tcl_EvalObj, /* 131 */
Tcl_EventuallyFree, /* 132 */
Tcl_Exit, /* 133 */
Tcl_ExposeCommand, /* 134 */
Tcl_ExprBoolean, /* 135 */
Tcl_ExprBooleanObj, /* 136 */
Tcl_ExprDouble, /* 137 */
Tcl_ExprDoubleObj, /* 138 */
Tcl_ExprLong, /* 139 */
Tcl_ExprLongObj, /* 140 */
Tcl_ExprObj, /* 141 */
Tcl_ExprString, /* 142 */
Tcl_Finalize, /* 143 */
Tcl_FindExecutable, /* 144 */
Tcl_FirstHashEntry, /* 145 */
Tcl_Flush, /* 146 */
Tcl_FreeResult, /* 147 */
Tcl_GetAlias, /* 148 */
Tcl_GetAliasObj, /* 149 */
Tcl_GetAssocData, /* 150 */
Tcl_GetChannel, /* 151 */
Tcl_GetChannelBufferSize, /* 152 */
Tcl_GetChannelHandle, /* 153 */
Tcl_GetChannelInstanceData, /* 154 */
Tcl_GetChannelMode, /* 155 */
Tcl_GetChannelName, /* 156 */
Tcl_GetChannelOption, /* 157 */
Tcl_GetChannelType, /* 158 */
Tcl_GetCommandInfo, /* 159 */
Tcl_GetCommandName, /* 160 */
Tcl_GetErrno, /* 161 */
Tcl_GetHostName, /* 162 */
Tcl_GetInterpPath, /* 163 */
Tcl_GetMaster, /* 164 */
Tcl_GetNameOfExecutable, /* 165 */
Tcl_GetObjResult, /* 166 */
#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
Tcl_GetOpenFile, /* 167 */
#endif /* UNIX */
#if defined(__WIN32__) /* WIN */
NULL, /* 167 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_GetOpenFile, /* 167 */
#endif /* MACOSX */
Tcl_GetPathType, /* 168 */
Tcl_Gets, /* 169 */
Tcl_GetsObj, /* 170 */
Tcl_GetServiceMode, /* 171 */
Tcl_GetSlave, /* 172 */
Tcl_GetStdChannel, /* 173 */
Tcl_GetStringResult, /* 174 */
Tcl_GetVar, /* 175 */
Tcl_GetVar2, /* 176 */
Tcl_GlobalEval, /* 177 */
Tcl_GlobalEvalObj, /* 178 */
Tcl_HideCommand, /* 179 */
Tcl_Init, /* 180 */
Tcl_InitHashTable, /* 181 */
Tcl_InputBlocked, /* 182 */
Tcl_InputBuffered, /* 183 */
Tcl_InterpDeleted, /* 184 */
Tcl_IsSafe, /* 185 */
Tcl_JoinPath, /* 186 */
Tcl_LinkVar, /* 187 */
NULL, /* 188 */
Tcl_MakeFileChannel, /* 189 */
Tcl_MakeSafe, /* 190 */
Tcl_MakeTcpClientChannel, /* 191 */
Tcl_Merge, /* 192 */
Tcl_NextHashEntry, /* 193 */
Tcl_NotifyChannel, /* 194 */
Tcl_ObjGetVar2, /* 195 */
Tcl_ObjSetVar2, /* 196 */
Tcl_OpenCommandChannel, /* 197 */
Tcl_OpenFileChannel, /* 198 */
Tcl_OpenTcpClient, /* 199 */
Tcl_OpenTcpServer, /* 200 */
Tcl_Preserve, /* 201 */
Tcl_PrintDouble, /* 202 */
Tcl_PutEnv, /* 203 */
Tcl_PosixError, /* 204 */
Tcl_QueueEvent, /* 205 */
Tcl_Read, /* 206 */
Tcl_ReapDetachedProcs, /* 207 */
Tcl_RecordAndEval, /* 208 */
Tcl_RecordAndEvalObj, /* 209 */
Tcl_RegisterChannel, /* 210 */
Tcl_RegisterObjType, /* 211 */
Tcl_RegExpCompile, /* 212 */
Tcl_RegExpExec, /* 213 */
Tcl_RegExpMatch, /* 214 */
Tcl_RegExpRange, /* 215 */
Tcl_Release, /* 216 */
Tcl_ResetResult, /* 217 */
Tcl_ScanElement, /* 218 */
Tcl_ScanCountedElement, /* 219 */
Tcl_SeekOld, /* 220 */
Tcl_ServiceAll, /* 221 */
Tcl_ServiceEvent, /* 222 */
Tcl_SetAssocData, /* 223 */
Tcl_SetChannelBufferSize, /* 224 */
Tcl_SetChannelOption, /* 225 */
Tcl_SetCommandInfo, /* 226 */
Tcl_SetErrno, /* 227 */
Tcl_SetErrorCode, /* 228 */
Tcl_SetMaxBlockTime, /* 229 */
Tcl_SetPanicProc, /* 230 */
Tcl_SetRecursionLimit, /* 231 */
Tcl_SetResult, /* 232 */
Tcl_SetServiceMode, /* 233 */
Tcl_SetObjErrorCode, /* 234 */
Tcl_SetObjResult, /* 235 */
Tcl_SetStdChannel, /* 236 */
Tcl_SetVar, /* 237 */
Tcl_SetVar2, /* 238 */
Tcl_SignalId, /* 239 */
Tcl_SignalMsg, /* 240 */
Tcl_SourceRCFile, /* 241 */
Tcl_SplitList, /* 242 */
Tcl_SplitPath, /* 243 */
Tcl_StaticPackage, /* 244 */
Tcl_StringMatch, /* 245 */
Tcl_TellOld, /* 246 */
Tcl_TraceVar, /* 247 */
Tcl_TraceVar2, /* 248 */
Tcl_TranslateFileName, /* 249 */
Tcl_Ungets, /* 250 */
Tcl_UnlinkVar, /* 251 */
Tcl_UnregisterChannel, /* 252 */
Tcl_UnsetVar, /* 253 */
Tcl_UnsetVar2, /* 254 */
Tcl_UntraceVar, /* 255 */
Tcl_UntraceVar2, /* 256 */
Tcl_UpdateLinkedVar, /* 257 */
Tcl_UpVar, /* 258 */
Tcl_UpVar2, /* 259 */
Tcl_VarEval, /* 260 */
Tcl_VarTraceInfo, /* 261 */
Tcl_VarTraceInfo2, /* 262 */
Tcl_Write, /* 263 */
Tcl_WrongNumArgs, /* 264 */
Tcl_DumpActiveMemory, /* 265 */
Tcl_ValidateAllMemory, /* 266 */
Tcl_AppendResultVA, /* 267 */
Tcl_AppendStringsToObjVA, /* 268 */
Tcl_HashStats, /* 269 */
Tcl_ParseVar, /* 270 */
Tcl_PkgPresent, /* 271 */
Tcl_PkgPresentEx, /* 272 */
Tcl_PkgProvide, /* 273 */
Tcl_PkgRequire, /* 274 */
Tcl_SetErrorCodeVA, /* 275 */
Tcl_VarEvalVA, /* 276 */
Tcl_WaitPid, /* 277 */
Tcl_PanicVA, /* 278 */
Tcl_GetVersion, /* 279 */
Tcl_InitMemory, /* 280 */
Tcl_StackChannel, /* 281 */
Tcl_UnstackChannel, /* 282 */
Tcl_GetStackedChannel, /* 283 */
Tcl_SetMainLoop, /* 284 */
NULL, /* 285 */
Tcl_AppendObjToObj, /* 286 */
Tcl_CreateEncoding, /* 287 */
Tcl_CreateThreadExitHandler, /* 288 */
Tcl_DeleteThreadExitHandler, /* 289 */
Tcl_DiscardResult, /* 290 */
Tcl_EvalEx, /* 291 */
Tcl_EvalObjv, /* 292 */
Tcl_EvalObjEx, /* 293 */
Tcl_ExitThread, /* 294 */
Tcl_ExternalToUtf, /* 295 */
Tcl_ExternalToUtfDString, /* 296 */
Tcl_FinalizeThread, /* 297 */
Tcl_FinalizeNotifier, /* 298 */
Tcl_FreeEncoding, /* 299 */
Tcl_GetCurrentThread, /* 300 */
Tcl_GetEncoding, /* 301 */
Tcl_GetEncodingName, /* 302 */
Tcl_GetEncodingNames, /* 303 */
Tcl_GetIndexFromObjStruct, /* 304 */
Tcl_GetThreadData, /* 305 */
Tcl_GetVar2Ex, /* 306 */
Tcl_InitNotifier, /* 307 */
Tcl_MutexLock, /* 308 */
Tcl_MutexUnlock, /* 309 */
Tcl_ConditionNotify, /* 310 */
Tcl_ConditionWait, /* 311 */
Tcl_NumUtfChars, /* 312 */
Tcl_ReadChars, /* 313 */
Tcl_RestoreResult, /* 314 */
Tcl_SaveResult, /* 315 */
Tcl_SetSystemEncoding, /* 316 */
Tcl_SetVar2Ex, /* 317 */
Tcl_ThreadAlert, /* 318 */
Tcl_ThreadQueueEvent, /* 319 */
Tcl_UniCharAtIndex, /* 320 */
Tcl_UniCharToLower, /* 321 */
Tcl_UniCharToTitle, /* 322 */
Tcl_UniCharToUpper, /* 323 */
Tcl_UniCharToUtf, /* 324 */
Tcl_UtfAtIndex, /* 325 */
Tcl_UtfCharComplete, /* 326 */
Tcl_UtfBackslash, /* 327 */
Tcl_UtfFindFirst, /* 328 */
Tcl_UtfFindLast, /* 329 */
Tcl_UtfNext, /* 330 */
Tcl_UtfPrev, /* 331 */
Tcl_UtfToExternal, /* 332 */
Tcl_UtfToExternalDString, /* 333 */
Tcl_UtfToLower, /* 334 */
Tcl_UtfToTitle, /* 335 */
Tcl_UtfToUniChar, /* 336 */
Tcl_UtfToUpper, /* 337 */
Tcl_WriteChars, /* 338 */
Tcl_WriteObj, /* 339 */
Tcl_GetString, /* 340 */
Tcl_GetDefaultEncodingDir, /* 341 */
Tcl_SetDefaultEncodingDir, /* 342 */
Tcl_AlertNotifier, /* 343 */
Tcl_ServiceModeHook, /* 344 */
Tcl_UniCharIsAlnum, /* 345 */
Tcl_UniCharIsAlpha, /* 346 */
Tcl_UniCharIsDigit, /* 347 */
Tcl_UniCharIsLower, /* 348 */
Tcl_UniCharIsSpace, /* 349 */
Tcl_UniCharIsUpper, /* 350 */
Tcl_UniCharIsWordChar, /* 351 */
Tcl_UniCharLen, /* 352 */
Tcl_UniCharNcmp, /* 353 */
Tcl_UniCharToUtfDString, /* 354 */
Tcl_UtfToUniCharDString, /* 355 */
Tcl_GetRegExpFromObj, /* 356 */
Tcl_EvalTokens, /* 357 */
Tcl_FreeParse, /* 358 */
Tcl_LogCommandInfo, /* 359 */
Tcl_ParseBraces, /* 360 */
Tcl_ParseCommand, /* 361 */
Tcl_ParseExpr, /* 362 */
Tcl_ParseQuotedString, /* 363 */
Tcl_ParseVarName, /* 364 */
Tcl_GetCwd, /* 365 */
Tcl_Chdir, /* 366 */
Tcl_Access, /* 367 */
Tcl_Stat, /* 368 */
Tcl_UtfNcmp, /* 369 */
Tcl_UtfNcasecmp, /* 370 */
Tcl_StringCaseMatch, /* 371 */
Tcl_UniCharIsControl, /* 372 */
Tcl_UniCharIsGraph, /* 373 */
Tcl_UniCharIsPrint, /* 374 */
Tcl_UniCharIsPunct, /* 375 */
Tcl_RegExpExecObj, /* 376 */
Tcl_RegExpGetInfo, /* 377 */
Tcl_NewUnicodeObj, /* 378 */
Tcl_SetUnicodeObj, /* 379 */
Tcl_GetCharLength, /* 380 */
Tcl_GetUniChar, /* 381 */
Tcl_GetUnicode, /* 382 */
Tcl_GetRange, /* 383 */
Tcl_AppendUnicodeToObj, /* 384 */
Tcl_RegExpMatchObj, /* 385 */
Tcl_SetNotifier, /* 386 */
Tcl_GetAllocMutex, /* 387 */
Tcl_GetChannelNames, /* 388 */
Tcl_GetChannelNamesEx, /* 389 */
Tcl_ProcObjCmd, /* 390 */
Tcl_ConditionFinalize, /* 391 */
Tcl_MutexFinalize, /* 392 */
Tcl_CreateThread, /* 393 */
Tcl_ReadRaw, /* 394 */
Tcl_WriteRaw, /* 395 */
Tcl_GetTopChannel, /* 396 */
Tcl_ChannelBuffered, /* 397 */
Tcl_ChannelName, /* 398 */
Tcl_ChannelVersion, /* 399 */
Tcl_ChannelBlockModeProc, /* 400 */
Tcl_ChannelCloseProc, /* 401 */
Tcl_ChannelClose2Proc, /* 402 */
Tcl_ChannelInputProc, /* 403 */
Tcl_ChannelOutputProc, /* 404 */
Tcl_ChannelSeekProc, /* 405 */
Tcl_ChannelSetOptionProc, /* 406 */
Tcl_ChannelGetOptionProc, /* 407 */
Tcl_ChannelWatchProc, /* 408 */
Tcl_ChannelGetHandleProc, /* 409 */
Tcl_ChannelFlushProc, /* 410 */
Tcl_ChannelHandlerProc, /* 411 */
Tcl_JoinThread, /* 412 */
Tcl_IsChannelShared, /* 413 */
Tcl_IsChannelRegistered, /* 414 */
Tcl_CutChannel, /* 415 */
Tcl_SpliceChannel, /* 416 */
Tcl_ClearChannelHandlers, /* 417 */
Tcl_IsChannelExisting, /* 418 */
Tcl_UniCharNcasecmp, /* 419 */
Tcl_UniCharCaseMatch, /* 420 */
Tcl_FindHashEntry, /* 421 */
Tcl_CreateHashEntry, /* 422 */
Tcl_InitCustomHashTable, /* 423 */
Tcl_InitObjHashTable, /* 424 */
Tcl_CommandTraceInfo, /* 425 */
Tcl_TraceCommand, /* 426 */
Tcl_UntraceCommand, /* 427 */
Tcl_AttemptAlloc, /* 428 */
Tcl_AttemptDbCkalloc, /* 429 */
Tcl_AttemptRealloc, /* 430 */
Tcl_AttemptDbCkrealloc, /* 431 */
Tcl_AttemptSetObjLength, /* 432 */
Tcl_GetChannelThread, /* 433 */
Tcl_GetUnicodeFromObj, /* 434 */
Tcl_GetMathFuncInfo, /* 435 */
Tcl_ListMathFuncs, /* 436 */
Tcl_SubstObj, /* 437 */
Tcl_DetachChannel, /* 438 */
Tcl_IsStandardChannel, /* 439 */
Tcl_FSCopyFile, /* 440 */
Tcl_FSCopyDirectory, /* 441 */
Tcl_FSCreateDirectory, /* 442 */
Tcl_FSDeleteFile, /* 443 */
Tcl_FSLoadFile, /* 444 */
Tcl_FSMatchInDirectory, /* 445 */
Tcl_FSLink, /* 446 */
Tcl_FSRemoveDirectory, /* 447 */
Tcl_FSRenameFile, /* 448 */
Tcl_FSLstat, /* 449 */
Tcl_FSUtime, /* 450 */
Tcl_FSFileAttrsGet, /* 451 */
Tcl_FSFileAttrsSet, /* 452 */
Tcl_FSFileAttrStrings, /* 453 */
Tcl_FSStat, /* 454 */
Tcl_FSAccess, /* 455 */
Tcl_FSOpenFileChannel, /* 456 */
Tcl_FSGetCwd, /* 457 */
Tcl_FSChdir, /* 458 */
Tcl_FSConvertToPathType, /* 459 */
Tcl_FSJoinPath, /* 460 */
Tcl_FSSplitPath, /* 461 */
Tcl_FSEqualPaths, /* 462 */
Tcl_FSGetNormalizedPath, /* 463 */
Tcl_FSJoinToPath, /* 464 */
Tcl_FSGetInternalRep, /* 465 */
Tcl_FSGetTranslatedPath, /* 466 */
Tcl_FSEvalFile, /* 467 */
Tcl_FSNewNativePath, /* 468 */
Tcl_FSGetNativePath, /* 469 */
Tcl_FSFileSystemInfo, /* 470 */
Tcl_FSPathSeparator, /* 471 */
Tcl_FSListVolumes, /* 472 */
Tcl_FSRegister, /* 473 */
Tcl_FSUnregister, /* 474 */
Tcl_FSData, /* 475 */
Tcl_FSGetTranslatedStringPath, /* 476 */
Tcl_FSGetFileSystemForPath, /* 477 */
Tcl_FSGetPathType, /* 478 */
Tcl_OutputBuffered, /* 479 */
Tcl_FSMountsChanged, /* 480 */
Tcl_EvalTokensStandard, /* 481 */
Tcl_GetTime, /* 482 */
Tcl_CreateObjTrace, /* 483 */
Tcl_GetCommandInfoFromToken, /* 484 */
Tcl_SetCommandInfoFromToken, /* 485 */
Tcl_DbNewWideIntObj, /* 486 */
Tcl_GetWideIntFromObj, /* 487 */
Tcl_NewWideIntObj, /* 488 */
Tcl_SetWideIntObj, /* 489 */
Tcl_AllocStatBuf, /* 490 */
Tcl_Seek, /* 491 */
Tcl_Tell, /* 492 */
Tcl_ChannelWideSeekProc, /* 493 */
NULL, /* 494 */
NULL, /* 495 */
NULL, /* 496 */
NULL, /* 497 */
NULL, /* 498 */
NULL, /* 499 */
NULL, /* 500 */
NULL, /* 501 */
NULL, /* 502 */
NULL, /* 503 */
NULL, /* 504 */
NULL, /* 505 */
NULL, /* 506 */
NULL, /* 507 */
NULL, /* 508 */
NULL, /* 509 */
NULL, /* 510 */
NULL, /* 511 */
NULL, /* 512 */
NULL, /* 513 */
NULL, /* 514 */
NULL, /* 515 */
NULL, /* 516 */
NULL, /* 517 */
NULL, /* 518 */
NULL, /* 519 */
NULL, /* 520 */
NULL, /* 521 */
NULL, /* 522 */
NULL, /* 523 */
NULL, /* 524 */
NULL, /* 525 */
NULL, /* 526 */
NULL, /* 527 */
NULL, /* 528 */
NULL, /* 529 */
NULL, /* 530 */
NULL, /* 531 */
NULL, /* 532 */
NULL, /* 533 */
NULL, /* 534 */
NULL, /* 535 */
NULL, /* 536 */
NULL, /* 537 */
NULL, /* 538 */
NULL, /* 539 */
NULL, /* 540 */
NULL, /* 541 */
NULL, /* 542 */
NULL, /* 543 */
NULL, /* 544 */
NULL, /* 545 */
NULL, /* 546 */
NULL, /* 547 */
NULL, /* 548 */
NULL, /* 549 */
NULL, /* 550 */
NULL, /* 551 */
NULL, /* 552 */
NULL, /* 553 */
Tcl_ChannelThreadActionProc, /* 554 */
NULL, /* 555 */
NULL, /* 556 */
NULL, /* 557 */
NULL, /* 558 */
NULL, /* 559 */
NULL, /* 560 */
NULL, /* 561 */
NULL, /* 562 */
NULL, /* 563 */
NULL, /* 564 */
NULL, /* 565 */
NULL, /* 566 */
NULL, /* 567 */
NULL, /* 568 */
NULL, /* 569 */
NULL, /* 570 */
NULL, /* 571 */
NULL, /* 572 */
Tcl_PkgRequireProc, /* 573 */
NULL, /* 574 */
NULL, /* 575 */
NULL, /* 576 */
NULL, /* 577 */
NULL, /* 578 */
NULL, /* 579 */
NULL, /* 580 */
NULL, /* 581 */
NULL, /* 582 */
NULL, /* 583 */
NULL, /* 584 */
NULL, /* 585 */
NULL, /* 586 */
NULL, /* 587 */
NULL, /* 588 */
NULL, /* 589 */
NULL, /* 590 */
NULL, /* 591 */
NULL, /* 592 */
NULL, /* 593 */
NULL, /* 594 */
NULL, /* 595 */
NULL, /* 596 */
NULL, /* 597 */
NULL, /* 598 */
NULL, /* 599 */
NULL, /* 600 */
NULL, /* 601 */
NULL, /* 602 */
NULL, /* 603 */
NULL, /* 604 */
NULL, /* 605 */
NULL, /* 606 */
NULL, /* 607 */
NULL, /* 608 */
NULL, /* 609 */
NULL, /* 610 */
NULL, /* 611 */
NULL, /* 612 */
NULL, /* 613 */
NULL, /* 614 */
NULL, /* 615 */
NULL, /* 616 */
NULL, /* 617 */
NULL, /* 618 */
NULL, /* 619 */
NULL, /* 620 */
NULL, /* 621 */
NULL, /* 622 */
NULL, /* 623 */
NULL, /* 624 */
NULL, /* 625 */
NULL, /* 626 */
NULL, /* 627 */
NULL, /* 628 */
NULL, /* 629 */
TclUnusedStubEntry, /* 630 */
};
/* !END!: Do not edit above this line. */
tcl8.4.20/generic/tclPosixStr.c 0000644 0036047 0045461 00000067614 11737050674 015013 0 ustar dgp 771div /*
* tclPosixStr.c --
*
* This file contains procedures that generate strings
* corresponding to various POSIX-related codes, such
* as errno and signals.
*
* Copyright (c) 1991-1994 The Regents of the University of California.
* Copyright (c) 1994-1996 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
*----------------------------------------------------------------------
*
* Tcl_ErrnoId --
*
* Return a textual identifier for the current errno value.
*
* Results:
* This procedure returns a machine-readable textual identifier
* that corresponds to the current errno value (e.g. "EPERM").
* The identifier is the same as the #define name in errno.h.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_ErrnoId()
{
switch (errno) {
#if defined(E2BIG) && (!defined(EOVERFLOW) || (E2BIG != EOVERFLOW))
case E2BIG: return "E2BIG";
#endif
#ifdef EACCES
case EACCES: return "EACCES";
#endif
#ifdef EADDRINUSE
case EADDRINUSE: return "EADDRINUSE";
#endif
#ifdef EADDRNOTAVAIL
case EADDRNOTAVAIL: return "EADDRNOTAVAIL";
#endif
#ifdef EADV
case EADV: return "EADV";
#endif
#ifdef EAFNOSUPPORT
case EAFNOSUPPORT: return "EAFNOSUPPORT";
#endif
#ifdef EAGAIN
case EAGAIN: return "EAGAIN";
#endif
#ifdef EALIGN
case EALIGN: return "EALIGN";
#endif
#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY))
case EALREADY: return "EALREADY";
#endif
#ifdef EBADE
case EBADE: return "EBADE";
#endif
#ifdef EBADF
case EBADF: return "EBADF";
#endif
#ifdef EBADFD
case EBADFD: return "EBADFD";
#endif
#ifdef EBADMSG
case EBADMSG: return "EBADMSG";
#endif
#ifdef EBADR
case EBADR: return "EBADR";
#endif
#ifdef EBADRPC
case EBADRPC: return "EBADRPC";
#endif
#ifdef EBADRQC
case EBADRQC: return "EBADRQC";
#endif
#ifdef EBADSLT
case EBADSLT: return "EBADSLT";
#endif
#ifdef EBFONT
case EBFONT: return "EBFONT";
#endif
#ifdef EBUSY
case EBUSY: return "EBUSY";
#endif
#ifdef ECHILD
case ECHILD: return "ECHILD";
#endif
#ifdef ECHRNG
case ECHRNG: return "ECHRNG";
#endif
#ifdef ECOMM
case ECOMM: return "ECOMM";
#endif
#ifdef ECONNABORTED
case ECONNABORTED: return "ECONNABORTED";
#endif
#ifdef ECONNREFUSED
case ECONNREFUSED: return "ECONNREFUSED";
#endif
#ifdef ECONNRESET
case ECONNRESET: return "ECONNRESET";
#endif
#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))
case EDEADLK: return "EDEADLK";
#endif
#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK))
case EDEADLOCK: return "EDEADLOCK";
#endif
#ifdef EDESTADDRREQ
case EDESTADDRREQ: return "EDESTADDRREQ";
#endif
#ifdef EDIRTY
case EDIRTY: return "EDIRTY";
#endif
#ifdef EDOM
case EDOM: return "EDOM";
#endif
#ifdef EDOTDOT
case EDOTDOT: return "EDOTDOT";
#endif
#ifdef EDQUOT
case EDQUOT: return "EDQUOT";
#endif
#ifdef EDUPPKG
case EDUPPKG: return "EDUPPKG";
#endif
#ifdef EEXIST
case EEXIST: return "EEXIST";
#endif
#ifdef EFAULT
case EFAULT: return "EFAULT";
#endif
#ifdef EFBIG
case EFBIG: return "EFBIG";
#endif
#ifdef EHOSTDOWN
case EHOSTDOWN: return "EHOSTDOWN";
#endif
#ifdef EHOSTUNREACH
case EHOSTUNREACH: return "EHOSTUNREACH";
#endif
#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS))
case EIDRM: return "EIDRM";
#endif
#ifdef EINIT
case EINIT: return "EINIT";
#endif
#ifdef EINPROGRESS
case EINPROGRESS: return "EINPROGRESS";
#endif
#ifdef EINTR
case EINTR: return "EINTR";
#endif
#ifdef EINVAL
case EINVAL: return "EINVAL";
#endif
#ifdef EIO
case EIO: return "EIO";
#endif
#ifdef EISCONN
case EISCONN: return "EISCONN";
#endif
#ifdef EISDIR
case EISDIR: return "EISDIR";
#endif
#ifdef EISNAME
case EISNAM: return "EISNAM";
#endif
#ifdef ELBIN
case ELBIN: return "ELBIN";
#endif
#ifdef EL2HLT
case EL2HLT: return "EL2HLT";
#endif
#ifdef EL2NSYNC
case EL2NSYNC: return "EL2NSYNC";
#endif
#ifdef EL3HLT
case EL3HLT: return "EL3HLT";
#endif
#ifdef EL3RST
case EL3RST: return "EL3RST";
#endif
#ifdef ELIBACC
case ELIBACC: return "ELIBACC";
#endif
#ifdef ELIBBAD
case ELIBBAD: return "ELIBBAD";
#endif
#ifdef ELIBEXEC
case ELIBEXEC: return "ELIBEXEC";
#endif
#ifdef ELIBMAX
case ELIBMAX: return "ELIBMAX";
#endif
#ifdef ELIBSCN
case ELIBSCN: return "ELIBSCN";
#endif
#ifdef ELNRNG
case ELNRNG: return "ELNRNG";
#endif
#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT))
case ELOOP: return "ELOOP";
#endif
#ifdef EMFILE
case EMFILE: return "EMFILE";
#endif
#ifdef EMLINK
case EMLINK: return "EMLINK";
#endif
#ifdef EMSGSIZE
case EMSGSIZE: return "EMSGSIZE";
#endif
#ifdef EMULTIHOP
case EMULTIHOP: return "EMULTIHOP";
#endif
#ifdef ENAMETOOLONG
case ENAMETOOLONG: return "ENAMETOOLONG";
#endif
#ifdef ENAVAIL
case ENAVAIL: return "ENAVAIL";
#endif
#ifdef ENET
case ENET: return "ENET";
#endif
#ifdef ENETDOWN
case ENETDOWN: return "ENETDOWN";
#endif
#ifdef ENETRESET
case ENETRESET: return "ENETRESET";
#endif
#ifdef ENETUNREACH
case ENETUNREACH: return "ENETUNREACH";
#endif
#ifdef ENFILE
case ENFILE: return "ENFILE";
#endif
#ifdef ENOANO
case ENOANO: return "ENOANO";
#endif
#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR))
case ENOBUFS: return "ENOBUFS";
#endif
#ifdef ENOCSI
case ENOCSI: return "ENOCSI";
#endif
#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED))
case ENODATA: return "ENODATA";
#endif
#ifdef ENODEV
case ENODEV: return "ENODEV";
#endif
#ifdef ENOENT
case ENOENT: return "ENOENT";
#endif
#ifdef ENOEXEC
case ENOEXEC: return "ENOEXEC";
#endif
#ifdef ENOLCK
case ENOLCK: return "ENOLCK";
#endif
#if defined(ENOLINK) && (!defined(ESOCKTNOSUPPORT) || (ESOCKTNOSUPPORT != ENOLINK))
case ENOLINK: return "ENOLINK";
#endif
#ifdef ENOMEM
case ENOMEM: return "ENOMEM";
#endif
#ifdef ENOMSG
case ENOMSG: return "ENOMSG";
#endif
#ifdef ENONET
case ENONET: return "ENONET";
#endif
#ifdef ENOPKG
case ENOPKG: return "ENOPKG";
#endif
#if defined(ENOPROTOOPT) && (!defined(EPFNOSUPPORT) || (EPFNOSUPPORT != ENOPROTOOPT))
case ENOPROTOOPT: return "ENOPROTOOPT";
#endif
#ifdef ENOSPC
case ENOSPC: return "ENOSPC";
#endif
#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR))
case ENOSR: return "ENOSR";
#endif
#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR))
case ENOSTR: return "ENOSTR";
#endif
#ifdef ENOSYM
case ENOSYM: return "ENOSYM";
#endif
#ifdef ENOSYS
case ENOSYS: return "ENOSYS";
#endif
#ifdef ENOTBLK
case ENOTBLK: return "ENOTBLK";
#endif
#ifdef ENOTCONN
case ENOTCONN: return "ENOTCONN";
#endif
#ifdef ENOTDIR
case ENOTDIR: return "ENOTDIR";
#endif
#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST))
case ENOTEMPTY: return "ENOTEMPTY";
#endif
#ifdef ENOTNAM
case ENOTNAM: return "ENOTNAM";
#endif
#ifdef ENOTSOCK
case ENOTSOCK: return "ENOTSOCK";
#endif
#ifdef ENOTSUP
case ENOTSUP: return "ENOTSUP";
#endif
#ifdef ENOTTY
case ENOTTY: return "ENOTTY";
#endif
#ifdef ENOTUNIQ
case ENOTUNIQ: return "ENOTUNIQ";
#endif
#ifdef ENXIO
case ENXIO: return "ENXIO";
#endif
#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
case EOPNOTSUPP: return "EOPNOTSUPP";
#endif
#if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) && (!defined(EINVAL) || (EOVERFLOW != EINVAL))
case EOVERFLOW: return "EOVERFLOW";
#endif
#ifdef EPERM
case EPERM: return "EPERM";
#endif
#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT))
case EPFNOSUPPORT: return "EPFNOSUPPORT";
#endif
#ifdef EPIPE
case EPIPE: return "EPIPE";
#endif
#ifdef EPROCLIM
case EPROCLIM: return "EPROCLIM";
#endif
#ifdef EPROCUNAVAIL
case EPROCUNAVAIL: return "EPROCUNAVAIL";
#endif
#ifdef EPROGMISMATCH
case EPROGMISMATCH: return "EPROGMISMATCH";
#endif
#ifdef EPROGUNAVAIL
case EPROGUNAVAIL: return "EPROGUNAVAIL";
#endif
#ifdef EPROTO
case EPROTO: return "EPROTO";
#endif
#ifdef EPROTONOSUPPORT
case EPROTONOSUPPORT: return "EPROTONOSUPPORT";
#endif
#ifdef EPROTOTYPE
case EPROTOTYPE: return "EPROTOTYPE";
#endif
#ifdef ERANGE
case ERANGE: return "ERANGE";
#endif
#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED))
case EREFUSED: return "EREFUSED";
#endif
#ifdef EREMCHG
case EREMCHG: return "EREMCHG";
#endif
#ifdef EREMDEV
case EREMDEV: return "EREMDEV";
#endif
#ifdef EREMOTE
case EREMOTE: return "EREMOTE";
#endif
#ifdef EREMOTEIO
case EREMOTEIO: return "EREMOTEIO";
#endif
#ifdef EREMOTERELEASE
case EREMOTERELEASE: return "EREMOTERELEASE";
#endif
#ifdef EROFS
case EROFS: return "EROFS";
#endif
#ifdef ERPCMISMATCH
case ERPCMISMATCH: return "ERPCMISMATCH";
#endif
#ifdef ERREMOTE
case ERREMOTE: return "ERREMOTE";
#endif
#ifdef ESHUTDOWN
case ESHUTDOWN: return "ESHUTDOWN";
#endif
#ifdef ESOCKTNOSUPPORT
case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT";
#endif
#ifdef ESPIPE
case ESPIPE: return "ESPIPE";
#endif
#ifdef ESRCH
case ESRCH: return "ESRCH";
#endif
#ifdef ESRMNT
case ESRMNT: return "ESRMNT";
#endif
#ifdef ESTALE
case ESTALE: return "ESTALE";
#endif
#ifdef ESUCCESS
case ESUCCESS: return "ESUCCESS";
#endif
#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP))
case ETIME: return "ETIME";
#endif
#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR))
case ETIMEDOUT: return "ETIMEDOUT";
#endif
#ifdef ETOOMANYREFS
case ETOOMANYREFS: return "ETOOMANYREFS";
#endif
#ifdef ETXTBSY
case ETXTBSY: return "ETXTBSY";
#endif
#ifdef EUCLEAN
case EUCLEAN: return "EUCLEAN";
#endif
#ifdef EUNATCH
case EUNATCH: return "EUNATCH";
#endif
#ifdef EUSERS
case EUSERS: return "EUSERS";
#endif
#ifdef EVERSION
case EVERSION: return "EVERSION";
#endif
#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN))
case EWOULDBLOCK: return "EWOULDBLOCK";
#endif
#ifdef EXDEV
case EXDEV: return "EXDEV";
#endif
#ifdef EXFULL
case EXFULL: return "EXFULL";
#endif
}
return "unknown error";
}
/*
*----------------------------------------------------------------------
*
* Tcl_ErrnoMsg --
*
* Return a human-readable message corresponding to a given
* errno value.
*
* Results:
* The return value is the standard POSIX error message for
* errno. This procedure is used instead of strerror because
* strerror returns slightly different values on different
* machines (e.g. different capitalizations), which cause
* problems for things such as regression tests. This procedure
* provides messages for most standard errors, then it calls
* strerror for things it doesn't understand.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_ErrnoMsg(err)
int err; /* Error number (such as in errno variable). */
{
switch (err) {
#if defined(E2BIG) && (!defined(EOVERFLOW) || (E2BIG != EOVERFLOW))
case E2BIG: return "argument list too long";
#endif
#ifdef EACCES
case EACCES: return "permission denied";
#endif
#ifdef EADDRINUSE
case EADDRINUSE: return "address already in use";
#endif
#ifdef EADDRNOTAVAIL
case EADDRNOTAVAIL: return "can't assign requested address";
#endif
#ifdef EADV
case EADV: return "advertise error";
#endif
#ifdef EAFNOSUPPORT
case EAFNOSUPPORT: return "address family not supported by protocol family";
#endif
#ifdef EAGAIN
case EAGAIN: return "resource temporarily unavailable";
#endif
#ifdef EALIGN
case EALIGN: return "EALIGN";
#endif
#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY))
case EALREADY: return "operation already in progress";
#endif
#ifdef EBADE
case EBADE: return "bad exchange descriptor";
#endif
#ifdef EBADF
case EBADF: return "bad file number";
#endif
#ifdef EBADFD
case EBADFD: return "file descriptor in bad state";
#endif
#ifdef EBADMSG
case EBADMSG: return "not a data message";
#endif
#ifdef EBADR
case EBADR: return "bad request descriptor";
#endif
#ifdef EBADRPC
case EBADRPC: return "RPC structure is bad";
#endif
#ifdef EBADRQC
case EBADRQC: return "bad request code";
#endif
#ifdef EBADSLT
case EBADSLT: return "invalid slot";
#endif
#ifdef EBFONT
case EBFONT: return "bad font file format";
#endif
#ifdef EBUSY
case EBUSY: return "file busy";
#endif
#ifdef ECHILD
case ECHILD: return "no children";
#endif
#ifdef ECHRNG
case ECHRNG: return "channel number out of range";
#endif
#ifdef ECOMM
case ECOMM: return "communication error on send";
#endif
#ifdef ECONNABORTED
case ECONNABORTED: return "software caused connection abort";
#endif
#ifdef ECONNREFUSED
case ECONNREFUSED: return "connection refused";
#endif
#ifdef ECONNRESET
case ECONNRESET: return "connection reset by peer";
#endif
#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))
case EDEADLK: return "resource deadlock avoided";
#endif
#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK))
case EDEADLOCK: return "resource deadlock avoided";
#endif
#ifdef EDESTADDRREQ
case EDESTADDRREQ: return "destination address required";
#endif
#ifdef EDIRTY
case EDIRTY: return "mounting a dirty fs w/o force";
#endif
#ifdef EDOM
case EDOM: return "math argument out of range";
#endif
#ifdef EDOTDOT
case EDOTDOT: return "cross mount point";
#endif
#ifdef EDQUOT
case EDQUOT: return "disk quota exceeded";
#endif
#ifdef EDUPPKG
case EDUPPKG: return "duplicate package name";
#endif
#ifdef EEXIST
case EEXIST: return "file already exists";
#endif
#ifdef EFAULT
case EFAULT: return "bad address in system call argument";
#endif
#ifdef EFBIG
case EFBIG: return "file too large";
#endif
#ifdef EHOSTDOWN
case EHOSTDOWN: return "host is down";
#endif
#ifdef EHOSTUNREACH
case EHOSTUNREACH: return "host is unreachable";
#endif
#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS))
case EIDRM: return "identifier removed";
#endif
#ifdef EINIT
case EINIT: return "initialization error";
#endif
#ifdef EINPROGRESS
case EINPROGRESS: return "operation now in progress";
#endif
#ifdef EINTR
case EINTR: return "interrupted system call";
#endif
#ifdef EINVAL
case EINVAL: return "invalid argument";
#endif
#ifdef EIO
case EIO: return "I/O error";
#endif
#ifdef EISCONN
case EISCONN: return "socket is already connected";
#endif
#ifdef EISDIR
case EISDIR: return "illegal operation on a directory";
#endif
#ifdef EISNAME
case EISNAM: return "is a name file";
#endif
#ifdef ELBIN
case ELBIN: return "ELBIN";
#endif
#ifdef EL2HLT
case EL2HLT: return "level 2 halted";
#endif
#ifdef EL2NSYNC
case EL2NSYNC: return "level 2 not synchronized";
#endif
#ifdef EL3HLT
case EL3HLT: return "level 3 halted";
#endif
#ifdef EL3RST
case EL3RST: return "level 3 reset";
#endif
#ifdef ELIBACC
case ELIBACC: return "can not access a needed shared library";
#endif
#ifdef ELIBBAD
case ELIBBAD: return "accessing a corrupted shared library";
#endif
#ifdef ELIBEXEC
case ELIBEXEC: return "can not exec a shared library directly";
#endif
#ifdef ELIBMAX
case ELIBMAX: return
"attempting to link in more shared libraries than system limit";
#endif
#ifdef ELIBSCN
case ELIBSCN: return ".lib section in a.out corrupted";
#endif
#ifdef ELNRNG
case ELNRNG: return "link number out of range";
#endif
#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT))
case ELOOP: return "too many levels of symbolic links";
#endif
#ifdef EMFILE
case EMFILE: return "too many open files";
#endif
#ifdef EMLINK
case EMLINK: return "too many links";
#endif
#ifdef EMSGSIZE
case EMSGSIZE: return "message too long";
#endif
#ifdef EMULTIHOP
case EMULTIHOP: return "multihop attempted";
#endif
#ifdef ENAMETOOLONG
case ENAMETOOLONG: return "file name too long";
#endif
#ifdef ENAVAIL
case ENAVAIL: return "not available";
#endif
#ifdef ENET
case ENET: return "ENET";
#endif
#ifdef ENETDOWN
case ENETDOWN: return "network is down";
#endif
#ifdef ENETRESET
case ENETRESET: return "network dropped connection on reset";
#endif
#ifdef ENETUNREACH
case ENETUNREACH: return "network is unreachable";
#endif
#ifdef ENFILE
case ENFILE: return "file table overflow";
#endif
#ifdef ENOANO
case ENOANO: return "anode table overflow";
#endif
#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR))
case ENOBUFS: return "no buffer space available";
#endif
#ifdef ENOCSI
case ENOCSI: return "no CSI structure available";
#endif
#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED))
case ENODATA: return "no data available";
#endif
#ifdef ENODEV
case ENODEV: return "no such device";
#endif
#ifdef ENOENT
case ENOENT: return "no such file or directory";
#endif
#ifdef ENOEXEC
case ENOEXEC: return "exec format error";
#endif
#ifdef ENOLCK
case ENOLCK: return "no locks available";
#endif
#if defined(ENOLINK) && (!defined(ESOCKTNOSUPPORT) || (ESOCKTNOSUPPORT != ENOLINK))
case ENOLINK: return "link has been severed";
#endif
#ifdef ENOMEM
case ENOMEM: return "not enough memory";
#endif
#ifdef ENOMSG
case ENOMSG: return "no message of desired type";
#endif
#ifdef ENONET
case ENONET: return "machine is not on the network";
#endif
#ifdef ENOPKG
case ENOPKG: return "package not installed";
#endif
#if defined(ENOPROTOOPT) && (!defined(EPFNOSUPPORT) || (EPFNOSUPPORT != ENOPROTOOPT))
case ENOPROTOOPT: return "bad protocol option";
#endif
#ifdef ENOSPC
case ENOSPC: return "no space left on device";
#endif
#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR))
case ENOSR: return "out of stream resources";
#endif
#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR))
case ENOSTR: return "not a stream device";
#endif
#ifdef ENOSYM
case ENOSYM: return "unresolved symbol name";
#endif
#ifdef ENOSYS
case ENOSYS: return "function not implemented";
#endif
#ifdef ENOTBLK
case ENOTBLK: return "block device required";
#endif
#ifdef ENOTCONN
case ENOTCONN: return "socket is not connected";
#endif
#ifdef ENOTDIR
case ENOTDIR: return "not a directory";
#endif
#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST))
case ENOTEMPTY: return "directory not empty";
#endif
#ifdef ENOTNAM
case ENOTNAM: return "not a name file";
#endif
#ifdef ENOTSOCK
case ENOTSOCK: return "socket operation on non-socket";
#endif
#ifdef ENOTSUP
case ENOTSUP: return "operation not supported";
#endif
#ifdef ENOTTY
case ENOTTY: return "inappropriate device for ioctl";
#endif
#ifdef ENOTUNIQ
case ENOTUNIQ: return "name not unique on network";
#endif
#ifdef ENXIO
case ENXIO: return "no such device or address";
#endif
#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
case EOPNOTSUPP: return "operation not supported on socket";
#endif
#if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) && (!defined(EINVAL) || (EOVERFLOW != EINVAL))
case EOVERFLOW: return "file too big";
#endif
#ifdef EPERM
case EPERM: return "not owner";
#endif
#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT))
case EPFNOSUPPORT: return "protocol family not supported";
#endif
#ifdef EPIPE
case EPIPE: return "broken pipe";
#endif
#ifdef EPROCLIM
case EPROCLIM: return "too many processes";
#endif
#ifdef EPROCUNAVAIL
case EPROCUNAVAIL: return "bad procedure for program";
#endif
#ifdef EPROGMISMATCH
case EPROGMISMATCH: return "program version wrong";
#endif
#ifdef EPROGUNAVAIL
case EPROGUNAVAIL: return "RPC program not available";
#endif
#ifdef EPROTO
case EPROTO: return "protocol error";
#endif
#ifdef EPROTONOSUPPORT
case EPROTONOSUPPORT: return "protocol not supported";
#endif
#ifdef EPROTOTYPE
case EPROTOTYPE: return "protocol wrong type for socket";
#endif
#ifdef ERANGE
case ERANGE: return "math result unrepresentable";
#endif
#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED))
case EREFUSED: return "EREFUSED";
#endif
#ifdef EREMCHG
case EREMCHG: return "remote address changed";
#endif
#ifdef EREMDEV
case EREMDEV: return "remote device";
#endif
#ifdef EREMOTE
case EREMOTE: return "pathname hit remote file system";
#endif
#ifdef EREMOTEIO
case EREMOTEIO: return "remote i/o error";
#endif
#ifdef EREMOTERELEASE
case EREMOTERELEASE: return "EREMOTERELEASE";
#endif
#ifdef EROFS
case EROFS: return "read-only file system";
#endif
#ifdef ERPCMISMATCH
case ERPCMISMATCH: return "RPC version is wrong";
#endif
#ifdef ERREMOTE
case ERREMOTE: return "object is remote";
#endif
#ifdef ESHUTDOWN
case ESHUTDOWN: return "can't send after socket shutdown";
#endif
#ifdef ESOCKTNOSUPPORT
case ESOCKTNOSUPPORT: return "socket type not supported";
#endif
#ifdef ESPIPE
case ESPIPE: return "invalid seek";
#endif
#ifdef ESRCH
case ESRCH: return "no such process";
#endif
#ifdef ESRMNT
case ESRMNT: return "srmount error";
#endif
#ifdef ESTALE
case ESTALE: return "stale remote file handle";
#endif
#ifdef ESUCCESS
case ESUCCESS: return "Error 0";
#endif
#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP))
case ETIME: return "timer expired";
#endif
#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR))
case ETIMEDOUT: return "connection timed out";
#endif
#ifdef ETOOMANYREFS
case ETOOMANYREFS: return "too many references: can't splice";
#endif
#ifdef ETXTBSY
case ETXTBSY: return "text file or pseudo-device busy";
#endif
#ifdef EUCLEAN
case EUCLEAN: return "structure needs cleaning";
#endif
#ifdef EUNATCH
case EUNATCH: return "protocol driver not attached";
#endif
#ifdef EUSERS
case EUSERS: return "too many users";
#endif
#ifdef EVERSION
case EVERSION: return "version mismatch";
#endif
#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN))
case EWOULDBLOCK: return "operation would block";
#endif
#ifdef EXDEV
case EXDEV: return "cross-domain link";
#endif
#ifdef EXFULL
case EXFULL: return "message tables full";
#endif
default:
#ifdef NO_STRERROR
return "unknown POSIX error";
#else
return strerror(err);
#endif
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SignalId --
*
* Return a textual identifier for a signal number.
*
* Results:
* This procedure returns a machine-readable textual identifier
* that corresponds to sig. The identifier is the same as the
* #define name in signal.h.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_SignalId(sig)
int sig; /* Number of signal. */
{
switch (sig) {
#ifdef SIGABRT
case SIGABRT: return "SIGABRT";
#endif
#ifdef SIGALRM
case SIGALRM: return "SIGALRM";
#endif
#ifdef SIGBUS
case SIGBUS: return "SIGBUS";
#endif
#ifdef SIGCHLD
case SIGCHLD: return "SIGCHLD";
#endif
#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD))
case SIGCLD: return "SIGCLD";
#endif
#ifdef SIGCONT
case SIGCONT: return "SIGCONT";
#endif
#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU))
case SIGEMT: return "SIGEMT";
#endif
#ifdef SIGFPE
case SIGFPE: return "SIGFPE";
#endif
#ifdef SIGHUP
case SIGHUP: return "SIGHUP";
#endif
#ifdef SIGILL
case SIGILL: return "SIGILL";
#endif
#ifdef SIGINT
case SIGINT: return "SIGINT";
#endif
#ifdef SIGIO
case SIGIO: return "SIGIO";
#endif
#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT))
case SIGIOT: return "SIGIOT";
#endif
#ifdef SIGKILL
case SIGKILL: return "SIGKILL";
#endif
#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO))
case SIGLOST: return "SIGLOST";
#endif
#ifdef SIGPIPE
case SIGPIPE: return "SIGPIPE";
#endif
#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO))
case SIGPOLL: return "SIGPOLL";
#endif
#ifdef SIGPROF
case SIGPROF: return "SIGPROF";
#endif
#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST))
case SIGPWR: return "SIGPWR";
#endif
#ifdef SIGQUIT
case SIGQUIT: return "SIGQUIT";
#endif
#if defined(SIGSEGV) && (!defined(SIGBUS) || (SIGSEGV != SIGBUS))
case SIGSEGV: return "SIGSEGV";
#endif
#ifdef SIGSTOP
case SIGSTOP: return "SIGSTOP";
#endif
#ifdef SIGSYS
case SIGSYS: return "SIGSYS";
#endif
#ifdef SIGTERM
case SIGTERM: return "SIGTERM";
#endif
#ifdef SIGTRAP
case SIGTRAP: return "SIGTRAP";
#endif
#ifdef SIGTSTP
case SIGTSTP: return "SIGTSTP";
#endif
#ifdef SIGTTIN
case SIGTTIN: return "SIGTTIN";
#endif
#ifdef SIGTTOU
case SIGTTOU: return "SIGTTOU";
#endif
#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO))
case SIGURG: return "SIGURG";
#endif
#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO))
case SIGUSR1: return "SIGUSR1";
#endif
#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG))
case SIGUSR2: return "SIGUSR2";
#endif
#ifdef SIGVTALRM
case SIGVTALRM: return "SIGVTALRM";
#endif
#ifdef SIGWINCH
case SIGWINCH: return "SIGWINCH";
#endif
#ifdef SIGXCPU
case SIGXCPU: return "SIGXCPU";
#endif
#ifdef SIGXFSZ
case SIGXFSZ: return "SIGXFSZ";
#endif
}
return "unknown signal";
}
/*
*----------------------------------------------------------------------
*
* Tcl_SignalMsg --
*
* Return a human-readable message describing a signal.
*
* Results:
* This procedure returns a string describing sig that should
* make sense to a human. It may not be easy for a machine
* to parse.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_SignalMsg(sig)
int sig; /* Number of signal. */
{
switch (sig) {
#ifdef SIGABRT
case SIGABRT: return "SIGABRT";
#endif
#ifdef SIGALRM
case SIGALRM: return "alarm clock";
#endif
#ifdef SIGBUS
case SIGBUS: return "bus error";
#endif
#ifdef SIGCHLD
case SIGCHLD: return "child status changed";
#endif
#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD))
case SIGCLD: return "child status changed";
#endif
#ifdef SIGCONT
case SIGCONT: return "continue after stop";
#endif
#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU))
case SIGEMT: return "EMT instruction";
#endif
#ifdef SIGFPE
case SIGFPE: return "floating-point exception";
#endif
#ifdef SIGHUP
case SIGHUP: return "hangup";
#endif
#ifdef SIGILL
case SIGILL: return "illegal instruction";
#endif
#ifdef SIGINT
case SIGINT: return "interrupt";
#endif
#ifdef SIGIO
case SIGIO: return "input/output possible on file";
#endif
#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT))
case SIGIOT: return "IOT instruction";
#endif
#ifdef SIGKILL
case SIGKILL: return "kill signal";
#endif
#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO))
case SIGLOST: return "resource lost";
#endif
#ifdef SIGPIPE
case SIGPIPE: return "write on pipe with no readers";
#endif
#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO))
case SIGPOLL: return "input/output possible on file";
#endif
#ifdef SIGPROF
case SIGPROF: return "profiling alarm";
#endif
#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST))
case SIGPWR: return "power-fail restart";
#endif
#ifdef SIGQUIT
case SIGQUIT: return "quit signal";
#endif
#if defined(SIGSEGV) && (!defined(SIGBUS) || (SIGSEGV != SIGBUS))
case SIGSEGV: return "segmentation violation";
#endif
#ifdef SIGSTOP
case SIGSTOP: return "stop";
#endif
#ifdef SIGSYS
case SIGSYS: return "bad argument to system call";
#endif
#ifdef SIGTERM
case SIGTERM: return "software termination signal";
#endif
#ifdef SIGTRAP
case SIGTRAP: return "trace trap";
#endif
#ifdef SIGTSTP
case SIGTSTP: return "stop signal from tty";
#endif
#ifdef SIGTTIN
case SIGTTIN: return "background tty read";
#endif
#ifdef SIGTTOU
case SIGTTOU: return "background tty write";
#endif
#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO))
case SIGURG: return "urgent I/O condition";
#endif
#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO))
case SIGUSR1: return "user-defined signal 1";
#endif
#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG))
case SIGUSR2: return "user-defined signal 2";
#endif
#ifdef SIGVTALRM
case SIGVTALRM: return "virtual time alarm";
#endif
#ifdef SIGWINCH
case SIGWINCH: return "window changed";
#endif
#ifdef SIGXCPU
case SIGXCPU: return "exceeded CPU time limit";
#endif
#ifdef SIGXFSZ
case SIGXFSZ: return "exceeded file size limit";
#endif
}
return "unknown signal";
}
tcl8.4.20/generic/tclCompCmds.c 0000644 0036047 0045461 00000310337 11737050674 014716 0 ustar dgp 771div /*
* tclCompCmds.c --
*
* This file contains compilation procedures that compile various
* Tcl commands into a sequence of instructions ("bytecodes").
*
* Copyright (c) 1997-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
* 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.
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
* Prototypes for procedures defined later in this file:
*/
static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData));
#ifndef TCL_TIP280
static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr));
#define TclPushVarNameWord(i,v,e,f,l,s,sc,word) \
TclPushVarName (i,v,e,f,l,s,sc) /* ignoring word */
#define DefineLineInformation /**/
#define SetLineInformation(word) /**/
#else
static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr,
int line, int* clNext));
#define TclPushVarNameWord(i,v,e,f,l,s,sc,word) \
TclPushVarName (i,v,e,f,l,s,sc, \
mapPtr->loc [eclIndex].line [(word)], \
mapPtr->loc [eclIndex].next [(word)])
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation may
* reallocate, i.e. move, the array. This is also the reason to save the nuloc
* now, it may change during the course of the function.
*
* Macros to encapsulate the variable definition and setup, and their use.
*/
#define DefineLineInformation \
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
int eclIndex = mapPtr->nuloc - 1
#define SetLineInformation(word) \
envPtr->line = mapPtr->loc [eclIndex].line [(word)]; \
envPtr->clNext = mapPtr->loc [eclIndex].next [(word)]
#endif
/*
* Flags bits used by TclPushVarName.
*/
#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */
#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
/*
* The structures below define the AuxData types defined in this file.
*/
AuxDataType tclForeachInfoType = {
"ForeachInfo", /* name */
DupForeachInfo, /* dupProc */
FreeForeachInfo /* freeProc */
};
/*
*----------------------------------------------------------------------
*
* TclCompileAppendCmd --
*
* Procedure called to compile the "append" command.
*
* Results:
* The return value is a standard Tcl result, which is normally TCL_OK
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message. If
* compilation fails because the command requires a second level of
* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
* command should be compiled "out of line" by emitting code to
* invoke its command procedure (Tcl_AppendObjCmd) at runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "append" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileAppendCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int simpleVarName, isScalar, localIndex, numWords;
int code = TCL_OK;
DefineLineInformation;
numWords = parsePtr->numWords;
if (numWords == 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"append varName ?value value ...?\"",
-1);
return TCL_ERROR;
} else if (numWords == 2) {
/*
* append varName === set varName
*/
return TclCompileSetCmd(interp, parsePtr, envPtr);
} else if (numWords > 3) {
/*
* APPEND instructions currently only handle one value
*/
return TCL_OUT_LINE_COMPILE;
}
/*
* Decide if we can use a frame slot for the var/array name or if we
* need to emit code to compute and push the name at runtime. We use a
* frame slot (entry in the array of local vars) if we are compiling a
* procedure body and if the name is simple text that does not include
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
&localIndex, &simpleVarName, &isScalar, 1);
if (code != TCL_OK) {
goto done;
}
/*
* We are doing an assignment, otherwise TclCompileSetCmd was called,
* so push the new value. This will need to be extended to push a
* value for each argument.
*/
if (numWords > 2) {
valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
} else {
SetLineInformation (2);
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
}
/*
* Emit instructions to set/get the variable.
*/
if (simpleVarName) {
if (isScalar) {
if (localIndex >= 0) {
if (localIndex <= 255) {
TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
} else {
TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
}
} else {
TclEmitOpcode(INST_APPEND_STK, envPtr);
}
} else {
if (localIndex >= 0) {
if (localIndex <= 255) {
TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
} else {
TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
}
} else {
TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
}
}
} else {
TclEmitOpcode(INST_APPEND_STK, envPtr);
}
done:
return code;
}
/*
*----------------------------------------------------------------------
*
* TclCompileBreakCmd --
*
* Procedure called to compile the "break" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK unless
* there was an error during compilation. If an error occurs then
* the interpreter's result contains a standard error message.
*
* Side effects:
* Instructions are added to envPtr to execute the "break" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileBreakCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
if (parsePtr->numWords != 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"break\"", -1);
return TCL_ERROR;
}
/*
* Emit a break instruction.
*/
TclEmitOpcode(INST_BREAK, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileCatchCmd --
*
* Procedure called to compile the "catch" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK if
* compilation was successful. If an error occurs then the
* interpreter's result contains a standard error message and TCL_ERROR
* is returned. If the command is too complex for TclCompileCatchCmd,
* TCL_OUT_LINE_COMPILE is returned indicating that the catch command
* should be compiled "out of line" by emitting code to invoke its
* command procedure at runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "catch" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileCatchCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *nameTokenPtr;
CONST char *name;
int localIndex, nameChars, range, startOffset, jumpDist;
int code;
int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation;
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"catch command ?varName?\"", -1);
return TCL_ERROR;
}
/*
* If a variable was specified and the catch command is at global level
* (not in a procedure), don't compile it inline: the payoff is
* too small.
*/
if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) {
return TCL_OUT_LINE_COMPILE;
}
/*
* Make sure the variable name, if any, has no substitutions and just
* refers to a local scaler.
*/
localIndex = -1;
cmdTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
if (parsePtr->numWords == 3) {
nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1);
if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
name = nameTokenPtr[1].start;
nameChars = nameTokenPtr[1].size;
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_OUT_LINE_COMPILE;
}
localIndex = TclFindCompiledLocal(nameTokenPtr[1].start,
nameTokenPtr[1].size, /*create*/ 1,
/*flags*/ VAR_SCALAR, envPtr->procPtr);
} else {
return TCL_OUT_LINE_COMPILE;
}
}
/*
* We will compile the catch command. Emit a beginCatch instruction at
* the start of the catch body: the subcommand it controls.
*/
envPtr->exceptDepth++;
envPtr->maxExceptDepth =
TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
/*
* If the body is a simple word, compile the instructions to
* eval it. Otherwise, compile instructions to substitute its
* text without catching, a catch instruction that resets the
* stack to what it was before substituting the body, and then
* an instruction to eval the body. Care has to be taken to
* register the correct startOffset for the catch range so that
* errors in the substitution are not catched [Bug 219184]
*/
SetLineInformation (1);
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
startOffset = (envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr);
} else {
code = TclCompileTokens(interp, cmdTokenPtr+1,
cmdTokenPtr->numComponents, envPtr);
startOffset = (envPtr->codeNext - envPtr->codeStart);
TclEmitOpcode(INST_EVAL_STK, envPtr);
}
envPtr->exceptArrayPtr[range].codeOffset = startOffset;
if (code != TCL_OK) {
code = TCL_OUT_LINE_COMPILE;
goto done;
}
envPtr->exceptArrayPtr[range].numCodeBytes =
(envPtr->codeNext - envPtr->codeStart) - startOffset;
/*
* The "no errors" epilogue code: store the body's result into the
* variable (if any), push "0" (TCL_OK) as the catch's "no error"
* result, and jump around the "error case" code.
*/
if (localIndex != -1) {
if (localIndex <= 255) {
TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
} else {
TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
}
}
TclEmitOpcode(INST_POP, envPtr);
TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
/*
* The "error case" code: store the body's result into the variable (if
* any), then push the error result code. The initial PC offset here is
* the catch's error target.
*/
envPtr->currStackDepth = savedStackDepth;
envPtr->exceptArrayPtr[range].catchOffset =
(envPtr->codeNext - envPtr->codeStart);
if (localIndex != -1) {
TclEmitOpcode(INST_PUSH_RESULT, envPtr);
if (localIndex <= 255) {
TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
} else {
TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
}
TclEmitOpcode(INST_POP, envPtr);
}
TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
/*
* Update the target of the jump after the "no errors" code, then emit
* an endCatch instruction at the end of the catch command.
*/
jumpDist = (envPtr->codeNext - envPtr->codeStart)
- jumpFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
}
TclEmitOpcode(INST_END_CATCH, envPtr);
done:
envPtr->currStackDepth = savedStackDepth + 1;
envPtr->exceptDepth--;
return code;
}
/*
*----------------------------------------------------------------------
*
* TclCompileContinueCmd --
*
* Procedure called to compile the "continue" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK unless
* there was an error while parsing string. If an error occurs then
* the interpreter's result contains a standard error message.
*
* Side effects:
* Instructions are added to envPtr to execute the "continue" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileContinueCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
/*
* There should be no argument after the "continue".
*/
if (parsePtr->numWords != 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"continue\"", -1);
return TCL_ERROR;
}
/*
* Emit a continue instruction.
*/
TclEmitOpcode(INST_CONTINUE, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileExprCmd --
*
* Procedure called to compile the "expr" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message.
*
* Side effects:
* Instructions are added to envPtr to execute the "expr" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileExprCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *firstWordPtr;
DefineLineInformation;
if (parsePtr->numWords == 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"expr arg ?arg ...?\"", -1);
return TCL_ERROR;
}
SetLineInformation (1);
firstWordPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1),
envPtr);
}
/*
*----------------------------------------------------------------------
*
* TclCompileForCmd --
*
* Procedure called to compile the "for" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK unless
* there was an error while parsing string. If an error occurs then
* the interpreter's result contains a standard error message.
*
* Side effects:
* Instructions are added to envPtr to execute the "for" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileForCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange, code;
char buffer[32 + TCL_INTEGER_SPACE];
int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation;
if (parsePtr->numWords != 5) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"for start test next command\"", -1);
return TCL_ERROR;
}
/*
* If the test expression requires substitutions, don't compile the for
* command inline. E.g., the expression might cause the loop to never
* execute or execute forever, as in "for {} "$x > 5" {incr x} {}".
*/
startTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1);
if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_OUT_LINE_COMPILE;
}
/*
* Bail out also if the body or the next expression require substitutions
* in order to insure correct behaviour [Bug 219166]
*/
nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);
if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
|| (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
return TCL_OUT_LINE_COMPILE;
}
/*
* Create ExceptionRange records for the body and the "next" command.
* The "next" command's ExceptionRange supports break but not continue
* (and has a -1 continueOffset).
*/
envPtr->exceptDepth++;
envPtr->maxExceptDepth =
TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
/*
* Inline compile the initial command.
*/
SetLineInformation (1);
code = TclCompileCmdWord(interp, startTokenPtr+1,
startTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"for\" initial command)", -1);
}
goto done;
}
TclEmitOpcode(INST_POP, envPtr);
/*
* Jump to the evaluation of the condition. This code uses the "loop
* rotation" optimisation (which eliminates one branch from the loop).
* "for start cond next body" produces then:
* start
* goto A
* B: body : bodyCodeOffset
* next : nextCodeOffset, continueOffset
* A: cond -> result : testCodeOffset
* if (result) goto B
*/
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
/*
* Compile the loop body.
*/
bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
SetLineInformation (4);
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"for\" body line %d)",
interp->errorLine);
Tcl_AddObjErrorInfo(interp, buffer, -1);
}
goto done;
}
envPtr->exceptArrayPtr[bodyRange].numCodeBytes =
(envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
/*
* Compile the "next" subcommand.
*/
nextCodeOffset = (envPtr->codeNext - envPtr->codeStart);
SetLineInformation (3);
envPtr->currStackDepth = savedStackDepth;
code = TclCompileCmdWord(interp, nextTokenPtr+1,
nextTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"for\" loop-end command)", -1);
}
goto done;
}
envPtr->exceptArrayPtr[nextRange].numCodeBytes =
(envPtr->codeNext - envPtr->codeStart)
- nextCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
envPtr->currStackDepth = savedStackDepth;
/*
* Compile the test expression then emit the conditional jump that
* terminates the for.
*/
testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
bodyCodeOffset += 3;
nextCodeOffset += 3;
testCodeOffset += 3;
}
SetLineInformation (2);
envPtr->currStackDepth = savedStackDepth;
code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"for\" test expression)", -1);
}
goto done;
}
envPtr->currStackDepth = savedStackDepth + 1;
jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
if (jumpDist > 127) {
TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
} else {
TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
}
/*
* Set the loop's offsets and break target.
*/
envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset;
envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset;
envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;
envPtr->exceptArrayPtr[bodyRange].breakOffset =
envPtr->exceptArrayPtr[nextRange].breakOffset =
(envPtr->codeNext - envPtr->codeStart);
/*
* The for command's result is an empty string.
*/
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
code = TCL_OK;
done:
envPtr->exceptDepth--;
return code;
}
/*
*----------------------------------------------------------------------
*
* TclCompileForeachCmd --
*
* Procedure called to compile the "foreach" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK if
* compilation was successful. If an error occurs then the
* interpreter's result contains a standard error message and TCL_ERROR
* is returned. If the command is too complex for TclCompileForeachCmd,
* TCL_OUT_LINE_COMPILE is returned indicating that the foreach command
* should be compiled "out of line" by emitting code to invoke its
* command procedure at runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "foreach" command
* at runtime.
*
n*----------------------------------------------------------------------
*/
int
TclCompileForeachCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
int firstValueTemp; /* Index of the first temp var in the frame
* used to point to a value list. */
int loopCtTemp; /* Index of temp var holding the loop's
* iteration count. */
Tcl_Token *tokenPtr, *bodyTokenPtr;
unsigned char *jumpPc;
JumpFixup jumpFalseFixup;
int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
char buffer[32 + TCL_INTEGER_SPACE];
int savedStackDepth = envPtr->currStackDepth;
#ifdef TCL_TIP280
int bodyIndex;
#endif
/*
* We parse the variable list argument words and create two arrays:
* varcList[i] is number of variables in i-th var list
* varvList[i] points to array of var names in i-th var list
*/
#define STATIC_VAR_LIST_SIZE 5
int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
CONST char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
int *varcList = varcListStaticSpace;
CONST char ***varvList = varvListStaticSpace;
DefineLineInformation;
/*
* If the foreach command isn't in a procedure, don't compile it inline:
* the payoff is too small.
*/
if (procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
}
numWords = parsePtr->numWords;
if ((numWords < 4) || (numWords%2 != 0)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
return TCL_ERROR;
}
/*
* Bail out if the body requires substitutions
* in order to insure correct behaviour [Bug 219166]
*/
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr += (tokenPtr->numComponents + 1)) {
}
bodyTokenPtr = tokenPtr;
if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_OUT_LINE_COMPILE;
}
#ifdef TCL_TIP280
bodyIndex = i-1;
#endif
/*
* Allocate storage for the varcList and varvList arrays if necessary.
*/
numLists = (numWords - 2)/2;
if (numLists > STATIC_VAR_LIST_SIZE) {
varcList = (int *) ckalloc(numLists * sizeof(int));
varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **));
}
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
varcList[loopIndex] = 0;
varvList[loopIndex] = NULL;
}
/*
* Set the exception stack depth.
*/
envPtr->exceptDepth++;
envPtr->maxExceptDepth =
TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
/*
* Break up each var list and set the varcList and varvList arrays.
* Don't compile the foreach inline if any var name needs substitutions
* or isn't a scalar, or if any var list needs substitutions.
*/
loopIndex = 0;
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr += (tokenPtr->numComponents + 1)) {
if (i%2 == 1) {
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
code = TCL_OUT_LINE_COMPILE;
goto done;
} else {
/* Lots of copying going on here. Need a ListObj wizard
* to show a better way. */
Tcl_DString varList;
Tcl_DStringInit(&varList);
Tcl_DStringAppend(&varList, tokenPtr[1].start,
tokenPtr[1].size);
code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
&varcList[loopIndex], &varvList[loopIndex]);
Tcl_DStringFree(&varList);
if (code != TCL_OK) {
goto done;
}
numVars = varcList[loopIndex];
/*
* If the variable list is empty, we can enter an infinite
* loop when the interpreted version would not. Take care to
* ensure this does not happen. [Bug 1671138]
*/
if (numVars == 0) {
code = TCL_OUT_LINE_COMPILE;
goto done;
}
for (j = 0; j < numVars; j++) {
CONST char *varName = varvList[loopIndex][j];
if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
code = TCL_OUT_LINE_COMPILE;
goto done;
}
}
}
loopIndex++;
}
}
/*
* We will compile the foreach command.
* Reserve (numLists + 1) temporary variables:
* - numLists temps to hold each value list
* - 1 temp for the loop counter (index of next element in each list)
* At this time we don't try to reuse temporaries; if there are two
* nonoverlapping foreach loops, they don't share any temps.
*/
firstValueTemp = -1;
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
/*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
if (loopIndex == 0) {
firstValueTemp = tempVar;
}
}
loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
/*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
/*
* Create and initialize the ForeachInfo and ForeachVarList data
* structures describing this command. Then create a AuxData record
* pointing to the ForeachInfo structure.
*/
infoPtr = (ForeachInfo *) ckalloc((unsigned)
(sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
infoPtr->numLists = numLists;
infoPtr->firstValueTemp = firstValueTemp;
infoPtr->loopCtTemp = loopCtTemp;
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
ForeachVarList *varListPtr;
numVars = varcList[loopIndex];
varListPtr = (ForeachVarList *) ckalloc((unsigned)
sizeof(ForeachVarList) + (numVars * sizeof(int)));
varListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
CONST char *varName = varvList[loopIndex][j];
int nameChars = strlen(varName);
varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
}
infoPtr->varLists[loopIndex] = varListPtr;
}
infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr);
/*
* Evaluate then store each value list in the associated temporary.
*/
range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
loopIndex = 0;
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr += (tokenPtr->numComponents + 1)) {
if ((i%2 == 0) && (i > 0)) {
SetLineInformation (i);
code = TclCompileTokens(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
tempVar = (firstValueTemp + loopIndex);
if (tempVar <= 255) {
TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
} else {
TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
}
TclEmitOpcode(INST_POP, envPtr);
loopIndex++;
}
}
/*
* Initialize the temporary var that holds the count of loop iterations.
*/
TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
/*
* Top of loop code: assign each loop variable and check whether
* to terminate the loop.
*/
envPtr->exceptArrayPtr[range].continueOffset =
(envPtr->codeNext - envPtr->codeStart);
TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
/*
* Inline compile the loop body.
*/
SetLineInformation (bodyIndex);
envPtr->exceptArrayPtr[range].codeOffset =
(envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"foreach\" body line %d)",
interp->errorLine);
Tcl_AddObjErrorInfo(interp, buffer, -1);
}
goto done;
}
envPtr->exceptArrayPtr[range].numCodeBytes =
(envPtr->codeNext - envPtr->codeStart)
- envPtr->exceptArrayPtr[range].codeOffset;
TclEmitOpcode(INST_POP, envPtr);
/*
* Jump back to the test at the top of the loop. Generate a 4 byte jump
* if the distance to the test is > 120 bytes. This is conservative and
* ensures that we won't have to replace this jump if we later need to
* replace the ifFalse jump with a 4 byte jump.
*/
jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
jumpBackDist =
(jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset);
if (jumpBackDist > 120) {
TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
} else {
TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
}
/*
* Fix the target of the jump after the foreach_step test.
*/
jumpDist = (envPtr->codeNext - envPtr->codeStart)
- jumpFalseFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
/*
* Update the loop body's starting PC offset since it moved down.
*/
envPtr->exceptArrayPtr[range].codeOffset += 3;
/*
* Update the jump back to the test at the top of the loop since it
* also moved down 3 bytes.
*/
jumpBackOffset += 3;
jumpPc = (envPtr->codeStart + jumpBackOffset);
jumpBackDist += 3;
if (jumpBackDist > 120) {
TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
} else {
TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
}
}
/*
* Set the loop's break target.
*/
envPtr->exceptArrayPtr[range].breakOffset =
(envPtr->codeNext - envPtr->codeStart);
/*
* The foreach command's result is an empty string.
*/
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
done:
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
if (varvList[loopIndex] != (CONST char **) NULL) {
ckfree((char *) varvList[loopIndex]);
}
}
if (varcList != varcListStaticSpace) {
ckfree((char *) varcList);
ckfree((char *) varvList);
}
envPtr->exceptDepth--;
return code;
}
/*
*----------------------------------------------------------------------
*
* DupForeachInfo --
*
* This procedure duplicates a ForeachInfo structure created as
* auxiliary data during the compilation of a foreach command.
*
* Results:
* A pointer to a newly allocated copy of the existing ForeachInfo
* structure is returned.
*
* Side effects:
* Storage for the copied ForeachInfo record is allocated. If the
* original ForeachInfo structure pointed to any ForeachVarList
* records, these structures are also copied and pointers to them
* are stored in the new ForeachInfo record.
*
*----------------------------------------------------------------------
*/
static ClientData
DupForeachInfo(clientData)
ClientData clientData; /* The foreach command's compilation
* auxiliary data to duplicate. */
{
register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
ForeachInfo *dupPtr;
register ForeachVarList *srcListPtr, *dupListPtr;
int numLists = srcPtr->numLists;
int numVars, i, j;
dupPtr = (ForeachInfo *) ckalloc((unsigned)
(sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
dupPtr->numLists = numLists;
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
dupPtr->loopCtTemp = srcPtr->loopCtTemp;
for (i = 0; i < numLists; i++) {
srcListPtr = srcPtr->varLists[i];
numVars = srcListPtr->numVars;
dupListPtr = (ForeachVarList *) ckalloc((unsigned)
sizeof(ForeachVarList) + numVars*sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
}
dupPtr->varLists[i] = dupListPtr;
}
return (ClientData) dupPtr;
}
/*
*----------------------------------------------------------------------
*
* FreeForeachInfo --
*
* Procedure to free a ForeachInfo structure created as auxiliary data
* during the compilation of a foreach command.
*
* Results:
* None.
*
* Side effects:
* Storage for the ForeachInfo structure pointed to by the ClientData
* argument is freed as is any ForeachVarList record pointed to by the
* ForeachInfo structure.
*
*----------------------------------------------------------------------
*/
static void
FreeForeachInfo(clientData)
ClientData clientData; /* The foreach command's compilation
* auxiliary data to free. */
{
register ForeachInfo *infoPtr = (ForeachInfo *) clientData;
register ForeachVarList *listPtr;
int numLists = infoPtr->numLists;
register int i;
for (i = 0; i < numLists; i++) {
listPtr = infoPtr->varLists[i];
ckfree((char *) listPtr);
}
ckfree((char *) infoPtr);
}
/*
*----------------------------------------------------------------------
*
* TclCompileIfCmd --
*
* Procedure called to compile the "if" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK if
* compilation was successful. If an error occurs then the
* interpreter's result contains a standard error message and TCL_ERROR
* is returned. If the command is too complex for TclCompileIfCmd,
* TCL_OUT_LINE_COMPILE is returned indicating that the if command
* should be compiled "out of line" by emitting code to invoke its
* command procedure at runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "if" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileIfCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
JumpFixupArray jumpFalseFixupArray;
/* Used to fix the ifFalse jump after each
* test when its target PC is determined. */
JumpFixupArray jumpEndFixupArray;
/* Used to fix the jump after each "then"
* body to the end of the "if" when that PC
* is determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
int jumpDist, jumpFalseDist;
int jumpIndex = 0; /* avoid compiler warning. */
int numWords, wordIdx, numBytes, j, code;
CONST char *word;
char buffer[100];
int savedStackDepth = envPtr->currStackDepth;
/* Saved stack depth at the start of the first
* test; the envPtr current depth is restored
* to this value at the start of each test. */
int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */
int boolVal; /* value of static condition */
int compileScripts = 1;
DefineLineInformation;
/*
* Only compile the "if" command if all arguments are simple
* words, in order to insure correct substitution [Bug 219166]
*/
tokenPtr = parsePtr->tokenPtr;
wordIdx = 0;
numWords = parsePtr->numWords;
for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_OUT_LINE_COMPILE;
}
tokenPtr += 2;
}
TclInitJumpFixupArray(&jumpFalseFixupArray);
TclInitJumpFixupArray(&jumpEndFixupArray);
code = TCL_OK;
/*
* Each iteration of this loop compiles one "if expr ?then? body"
* or "elseif expr ?then? body" clause.
*/
tokenPtr = parsePtr->tokenPtr;
wordIdx = 0;
while (wordIdx < numWords) {
/*
* Stop looping if the token isn't "if" or "elseif".
*/
word = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
if ((tokenPtr == parsePtr->tokenPtr)
|| ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
tokenPtr += (tokenPtr->numComponents + 1);
wordIdx++;
} else {
break;
}
if (wordIdx >= numWords) {
sprintf(buffer,
"wrong # args: no expression after \"%.*s\" argument",
(numBytes > 50 ? 50 : numBytes), word);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
code = TCL_ERROR;
goto done;
}
/*
* Compile the test expression then emit the conditional jump
* around the "then" part.
*/
envPtr->currStackDepth = savedStackDepth;
testTokenPtr = tokenPtr;
if (realCond) {
/*
* Find out if the condition is a constant.
*/
Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
testTokenPtr[1].size);
Tcl_IncrRefCount(boolObj);
code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
Tcl_DecrRefCount(boolObj);
if (code == TCL_OK) {
/*
* A static condition
*/
realCond = 0;
if (!boolVal) {
compileScripts = 0;
}
} else {
Tcl_ResetResult(interp);
SetLineInformation (wordIdx);
code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"if\" test expression)", -1);
}
goto done;
}
if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
TclExpandJumpFixupArray(&jumpFalseFixupArray);
}
jumpIndex = jumpFalseFixupArray.next;
jumpFalseFixupArray.next++;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
&(jumpFalseFixupArray.fixup[jumpIndex]));
}
}
/*
* Skip over the optional "then" before the then clause.
*/
tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
wordIdx++;
if (wordIdx >= numWords) {
sprintf(buffer,
"wrong # args: no script following \"%.*s\" argument",
(testTokenPtr->size > 50 ? 50 : testTokenPtr->size),
testTokenPtr->start);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
code = TCL_ERROR;
goto done;
}
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
word = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
tokenPtr += (tokenPtr->numComponents + 1);
wordIdx++;
if (wordIdx >= numWords) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: no script following \"then\" argument", -1);
code = TCL_ERROR;
goto done;
}
}
}
/*
* Compile the "then" command body.
*/
if (compileScripts) {
SetLineInformation (wordIdx);
envPtr->currStackDepth = savedStackDepth;
code = TclCompileCmdWord(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"if\" then script line %d)",
interp->errorLine);
Tcl_AddObjErrorInfo(interp, buffer, -1);
}
goto done;
}
}
if (realCond) {
/*
* Jump to the end of the "if" command. Both jumpFalseFixupArray and
* jumpEndFixupArray are indexed by "jumpIndex".
*/
if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
TclExpandJumpFixupArray(&jumpEndFixupArray);
}
jumpEndFixupArray.next++;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
&(jumpEndFixupArray.fixup[jumpIndex]));
/*
* Fix the target of the jumpFalse after the test. Generate a 4 byte
* jump if the distance is > 120 bytes. This is conservative, and
* ensures that we won't have to replace this jump if we later also
* need to replace the proceeding jump to the end of the "if" with a
* 4 byte jump.
*/
jumpDist = (envPtr->codeNext - envPtr->codeStart)
- jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
if (TclFixupForwardJump(envPtr,
&(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
/*
* Adjust the code offset for the proceeding jump to the end
* of the "if" command.
*/
jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
}
} else if (boolVal) {
/*
*We were processing an "if 1 {...}"; stop compiling
* scripts
*/
compileScripts = 0;
} else {
/*
*We were processing an "if 0 {...}"; reset so that
* the rest (elseif, else) is compiled correctly
*/
realCond = 1;
compileScripts = 1;
}
tokenPtr += (tokenPtr->numComponents + 1);
wordIdx++;
}
/*
* Restore the current stack depth in the environment; the
* "else" clause (or its default) will add 1 to this.
*/
envPtr->currStackDepth = savedStackDepth;
/*
* Check for the optional else clause. Do not compile
* anything if this was an "if 1 {...}" case.
*/
if ((wordIdx < numWords)
&& (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
/*
* There is an else clause. Skip over the optional "else" word.
*/
word = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
tokenPtr += (tokenPtr->numComponents + 1);
wordIdx++;
if (wordIdx >= numWords) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: no script following \"else\" argument", -1);
code = TCL_ERROR;
goto done;
}
}
if (compileScripts) {
/*
* Compile the else command body.
*/
SetLineInformation (wordIdx);
code = TclCompileCmdWord(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"if\" else script line %d)",
interp->errorLine);
Tcl_AddObjErrorInfo(interp, buffer, -1);
}
goto done;
}
}
/*
* Make sure there are no words after the else clause.
*/
wordIdx++;
if (wordIdx < numWords) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: extra words after \"else\" clause in \"if\" command", -1);
code = TCL_ERROR;
goto done;
}
} else {
/*
* No else clause: the "if" command's result is an empty string.
*/
if (compileScripts) {
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
}
}
/*
* Fix the unconditional jumps to the end of the "if" command.
*/
for (j = jumpEndFixupArray.next; j > 0; j--) {
jumpIndex = (j - 1); /* i.e. process the closest jump first */
jumpDist = (envPtr->codeNext - envPtr->codeStart)
- jumpEndFixupArray.fixup[jumpIndex].codeOffset;
if (TclFixupForwardJump(envPtr,
&(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
/*
* Adjust the immediately preceeding "ifFalse" jump. We moved
* it's target (just after this jump) down three bytes.
*/
unsigned char *ifFalsePc = envPtr->codeStart
+ jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
unsigned char opCode = *ifFalsePc;
if (opCode == INST_JUMP_FALSE1) {
jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
jumpFalseDist += 3;
TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else if (opCode == INST_JUMP_FALSE4) {
jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
jumpFalseDist += 3;
TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else {
panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
}
}
}
/*
* Free the jumpFixupArray array if malloc'ed storage was used.
*/
done:
envPtr->currStackDepth = savedStackDepth + 1;
TclFreeJumpFixupArray(&jumpFalseFixupArray);
TclFreeJumpFixupArray(&jumpEndFixupArray);
return code;
}
/*
*----------------------------------------------------------------------
*
* TclCompileIncrCmd --
*
* Procedure called to compile the "incr" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK if
* compilation was successful. If an error occurs then the
* interpreter's result contains a standard error message and TCL_ERROR
* is returned. If the command is too complex for TclCompileIncrCmd,
* TCL_OUT_LINE_COMPILE is returned indicating that the incr command
* should be compiled "out of line" by emitting code to invoke its
* command procedure at runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "incr" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileIncrCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *incrTokenPtr;
int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
int code = TCL_OK;
DefineLineInformation;
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"incr varName ?increment?\"", -1);
return TCL_ERROR;
}
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarNameWord(interp, varTokenPtr, envPtr,
(TCL_NO_LARGE_INDEX | TCL_CREATE_VAR),
&localIndex, &simpleVarName, &isScalar, 1);
if (code != TCL_OK) {
goto done;
}
/*
* If an increment is given, push it, but see first if it's a small
* integer.
*/
haveImmValue = 0;
immValue = 1;
if (parsePtr->numWords == 3) {
incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
CONST char *word = incrTokenPtr[1].start;
int numBytes = incrTokenPtr[1].size;
/*
* Note there is a danger that modifying the string could have
* undesirable side effects. In this case, TclLooksLikeInt has
* no dependencies on shared strings so we should be safe.
*/
if (TclLooksLikeInt(word, numBytes)) {
int code;
Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
Tcl_IncrRefCount(intObj);
code = Tcl_GetIntFromObj(NULL, intObj, &immValue);
Tcl_DecrRefCount(intObj);
if ((code == TCL_OK)
&& (-127 <= immValue) && (immValue <= 127)) {
haveImmValue = 1;
}
}
if (!haveImmValue) {
TclEmitPush(
TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
}
} else {
SetLineInformation (2);
code = TclCompileTokens(interp, incrTokenPtr+1,
incrTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
} else { /* no incr amount given so use 1 */
haveImmValue = 1;
}
/*
* Emit the instruction to increment the variable.
*/
if (simpleVarName) {
if (isScalar) {
if (localIndex >= 0) {
if (haveImmValue) {
TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
TclEmitInt1(immValue, envPtr);
} else {
TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
}
} else {
if (haveImmValue) {
TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
} else {
TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
}
}
} else {
if (localIndex >= 0) {
if (haveImmValue) {
TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
TclEmitInt1(immValue, envPtr);
} else {
TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
}
} else {
if (haveImmValue) {
TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
} else {
TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
}
}
}
} else { /* non-simple variable name */
if (haveImmValue) {
TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
} else {
TclEmitOpcode(INST_INCR_STK, envPtr);
}
}
done:
return code;
}
/*
*----------------------------------------------------------------------
*
* TclCompileLappendCmd --
*
* Procedure called to compile the "lappend" command.
*
* Results:
* The return value is a standard Tcl result, which is normally TCL_OK
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message. If
* compilation fails because the command requires a second level of
* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
* command should be compiled "out of line" by emitting code to
* invoke its command procedure (Tcl_LappendObjCmd) at runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "lappend" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileLappendCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int simpleVarName, isScalar, localIndex, numWords;
int code = TCL_OK;
DefineLineInformation;
/*
* If we're not in a procedure, don't compile.
*/
if (envPtr->procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
}
numWords = parsePtr->numWords;
if (numWords == 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"lappend varName ?value value ...?\"", -1);
return TCL_ERROR;
}
if (numWords != 3) {
/*
* LAPPEND instructions currently only handle one value appends
*/
return TCL_OUT_LINE_COMPILE;
}
/*
* Decide if we can use a frame slot for the var/array name or if we
* need to emit code to compute and push the name at runtime. We use a
* frame slot (entry in the array of local vars) if we are compiling a
* procedure body and if the name is simple text that does not include
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
&localIndex, &simpleVarName, &isScalar, 1);
if (code != TCL_OK) {
goto done;
}
/*
* If we are doing an assignment, push the new value.
* In the no values case, create an empty object.
*/
if (numWords > 2) {
valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
} else {
SetLineInformation (2);
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
}
/*
* Emit instructions to set/get the variable.
*/
/*
* The *_STK opcodes should be refactored to make better use of existing
* LOAD/STORE instructions.
*/
if (simpleVarName) {
if (isScalar) {
if (localIndex >= 0) {
if (localIndex <= 255) {
TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
} else {
TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
}
} else {
TclEmitOpcode(INST_LAPPEND_STK, envPtr);
}
} else {
if (localIndex >= 0) {
if (localIndex <= 255) {
TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
} else {
TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
}
} else {
TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
}
}
} else {
TclEmitOpcode(INST_LAPPEND_STK, envPtr);
}
done:
return code;
}
/*
*----------------------------------------------------------------------
*
* TclCompileLindexCmd --
*
* Procedure called to compile the "lindex" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK if the
* compilation was successful. If the command cannot be byte-compiled,
* TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
* interpreter's result contains an error message, and TCL_ERROR is
* returned.
*
* Side effects:
* Instructions are added to envPtr to execute the "lindex" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileLindexCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int code, i;
int numWords;
DefineLineInformation;
numWords = parsePtr->numWords;
/*
* Quit if too few args
*/
if ( numWords <= 1 ) {
return TCL_OUT_LINE_COMPILE;
}
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
/*
* Push the operands onto the stack.
*/
for ( i = 1 ; i < numWords ; i++ ) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(
TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
varTokenPtr[1].size), envPtr);
} else {
SetLineInformation (i);
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
}
/*
* Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI
* if there are multiple index args.
*/
if ( numWords == 3 ) {
TclEmitOpcode( INST_LIST_INDEX, envPtr );
} else {
TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr );
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileListCmd --
*
* Procedure called to compile the "list" command.
*
* Results:
* The return value is a standard Tcl result, which is normally TCL_OK
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message. If
* compilation fails because the command requires a second level of
* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
* command should be compiled "out of line" by emitting code to
* invoke its command procedure (Tcl_ListObjCmd) at runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "list" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileListCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
DefineLineInformation;
/*
* If we're not in a procedure, don't compile.
*/
if (envPtr->procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
}
if (parsePtr->numWords == 1) {
/*
* Empty args case
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
} else {
/*
* Push the all values onto the stack.
*/
Tcl_Token *valueTokenPtr;
int i, code, numWords;
numWords = parsePtr->numWords;
valueTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
for (i = 1; i < numWords; i++) {
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
} else {
SetLineInformation (i);
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);
}
TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileLlengthCmd --
*
* Procedure called to compile the "llength" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK if the
* compilation was successful. If the command cannot be byte-compiled,
* TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
* interpreter's result contains an error message, and TCL_ERROR is
* returned.
*
* Side effects:
* Instructions are added to envPtr to execute the "llength" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileLlengthCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int code;
DefineLineInformation;
if (parsePtr->numWords != 2) {
Tcl_SetResult(interp, "wrong # args: should be \"llength list\"",
TCL_STATIC);
return TCL_ERROR;
}
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
* We could simply count the number of elements here and push
* that value, but that is too rare a case to waste the code space.
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
varTokenPtr[1].size), envPtr);
} else {
SetLineInformation (1);
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
TclEmitOpcode(INST_LIST_LENGTH, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileLsetCmd --
*
* Procedure called to compile the "lset" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK if
* the compilation was successful. If the "lset" command is too
* complex for this function, then TCL_OUT_LINE_COMPILE is returned,
* indicating that the command should be compiled "out of line"
* (that is, not byte-compiled). If an error occurs, TCL_ERROR is
* returned, and the interpreter result contains an error message.
*
* Side effects:
* Instructions are added to envPtr to execute the "lset" command
* at runtime.
*
* The general template for execution of the "lset" command is:
* (1) Instructions to push the variable name, unless the
* variable is local to the stack frame.
* (2) If the variable is an array element, instructions
* to push the array element name.
* (3) Instructions to push each of zero or more "index" arguments
* to the stack, followed with the "newValue" element.
* (4) Instructions to duplicate the variable name and/or array
* element name onto the top of the stack, if either was
* pushed at steps (1) and (2).
* (5) The appropriate INST_LOAD_* instruction to place the
* original value of the list variable at top of stack.
* (6) At this point, the stack contains:
* varName? arrayElementName? index1 index2 ... newValue oldList
* The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
* according as whether there is exactly one index element (LIST)
* or either zero or else two or more (FLAT). This instruction
* removes everything from the stack except for the two names
* and pushes the new value of the variable.
* (7) Finally, INST_STORE_* stores the new value in the variable
* and cleans up the stack.
*
*----------------------------------------------------------------------
*/
int
TclCompileLsetCmd( interp, parsePtr, envPtr )
Tcl_Interp* interp; /* Tcl interpreter for error reporting */
Tcl_Parse* parsePtr; /* Points to a parse structure for
* the command */
CompileEnv* envPtr; /* Holds the resulting instructions */
{
int tempDepth; /* Depth used for emitting one part
* of the code burst. */
Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing
* the parse of the variable name */
int result; /* Status return from library calls */
int localIndex; /* Index of var in local var table */
int simpleVarName; /* Flag == 1 if var name is simple */
int isScalar; /* Flag == 1 if scalar, 0 if array */
int i;
DefineLineInformation;
/* Check argument count */
if ( parsePtr->numWords < 3 ) {
/* Fail at run time, not in compilation */
return TCL_OUT_LINE_COMPILE;
}
/*
* Decide if we can use a frame slot for the var/array name or if we
* need to emit code to compute and push the name at runtime. We use a
* frame slot (entry in the array of local vars) if we are compiling a
* procedure body and if the name is simple text that does not include
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
result = TclPushVarNameWord( interp, varTokenPtr, envPtr,
TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1);
if (result != TCL_OK) {
return result;
}
/* Push the "index" args and the new element value. */
for ( i = 2; i < parsePtr->numWords; ++i ) {
/* Advance to next arg */
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
/* Push an arg */
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
varTokenPtr[1].size), envPtr);
} else {
SetLineInformation (i);
result = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if ( result != TCL_OK ) {
return result;
}
}
}
/*
* Duplicate the variable name if it's been pushed.
*/
if ( !simpleVarName || localIndex < 0 ) {
if ( !simpleVarName || isScalar ) {
tempDepth = parsePtr->numWords - 2;
} else {
tempDepth = parsePtr->numWords - 1;
}
TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
}
/*
* Duplicate an array index if one's been pushed
*/
if ( simpleVarName && !isScalar ) {
if ( localIndex < 0 ) {
tempDepth = parsePtr->numWords - 1;
} else {
tempDepth = parsePtr->numWords - 2;
}
TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
}
/*
* Emit code to load the variable's value.
*/
if ( !simpleVarName ) {
TclEmitOpcode( INST_LOAD_STK, envPtr );
} else if ( isScalar ) {
if ( localIndex < 0 ) {
TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr );
} else if ( localIndex < 0x100 ) {
TclEmitInstInt1( INST_LOAD_SCALAR1, localIndex, envPtr );
} else {
TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr );
}
} else {
if ( localIndex < 0 ) {
TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr );
} else if ( localIndex < 0x100 ) {
TclEmitInstInt1( INST_LOAD_ARRAY1, localIndex, envPtr );
} else {
TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr );
}
}
/*
* Emit the correct variety of 'lset' instruction
*/
if ( parsePtr->numWords == 4 ) {
TclEmitOpcode( INST_LSET_LIST, envPtr );
} else {
TclEmitInstInt4( INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr );
}
/*
* Emit code to put the value back in the variable
*/
if ( !simpleVarName ) {
TclEmitOpcode( INST_STORE_STK, envPtr );
} else if ( isScalar ) {
if ( localIndex < 0 ) {
TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr );
} else if ( localIndex < 0x100 ) {
TclEmitInstInt1( INST_STORE_SCALAR1, localIndex, envPtr );
} else {
TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr );
}
} else {
if ( localIndex < 0 ) {
TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr );
} else if ( localIndex < 0x100 ) {
TclEmitInstInt1( INST_STORE_ARRAY1, localIndex, envPtr );
} else {
TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr );
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileRegexpCmd --
*
* Procedure called to compile the "regexp" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK if
* the compilation was successful. If the "regexp" command is too
* complex for this function, then TCL_OUT_LINE_COMPILE is returned,
* indicating that the command should be compiled "out of line"
* (that is, not byte-compiled). If an error occurs, TCL_ERROR is
* returned, and the interpreter result contains an error message.
*
* Side effects:
* Instructions are added to envPtr to execute the "regexp" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileRegexpCmd(interp, parsePtr, envPtr)
Tcl_Interp* interp; /* Tcl interpreter for error reporting */
Tcl_Parse* parsePtr; /* Points to a parse structure for
* the command */
CompileEnv* envPtr; /* Holds the resulting instructions */
{
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing
* the parse of the RE or string */
int i, len, code, nocase, anchorLeft, anchorRight, start;
char *str;
DefineLineInformation;
/*
* We are only interested in compiling simple regexp cases.
* Currently supported compile cases are:
* regexp ?-nocase? ?--? staticString $var
* regexp ?-nocase? ?--? {^staticString$} $var
*/
if (parsePtr->numWords < 3) {
return TCL_OUT_LINE_COMPILE;
}
nocase = 0;
varTokenPtr = parsePtr->tokenPtr;
/*
* We only look for -nocase and -- as options. Everything else
* gets pushed to runtime execution. This is different than regexp's
* runtime option handling, but satisfies our stricter needs.
*/
for (i = 1; i < parsePtr->numWords - 2; i++) {
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/* Not a simple string - punt to runtime. */
return TCL_OUT_LINE_COMPILE;
}
str = (char *) varTokenPtr[1].start;
len = varTokenPtr[1].size;
if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
i++;
break;
} else if ((len > 1)
&& (strncmp(str, "-nocase", (unsigned) len) == 0)) {
nocase = 1;
} else {
/* Not an option we recognize. */
return TCL_OUT_LINE_COMPILE;
}
}
if ((parsePtr->numWords - i) != 2) {
/* We don't support capturing to variables */
return TCL_OUT_LINE_COMPILE;
}
/*
* Get the regexp string. If it is not a simple string, punt to runtime.
* If it has a '-', it could be an incorrectly formed regexp command.
*/
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
str = (char *) varTokenPtr[1].start;
len = varTokenPtr[1].size;
if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) {
return TCL_OUT_LINE_COMPILE;
}
if (len == 0) {
/*
* The semantics of regexp are always match on re == "".
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
return TCL_OK;
}
/*
* Make a copy of the string that is null-terminated for checks which
* require such.
*/
str = (char *) ckalloc((unsigned) len + 1);
strncpy(str, varTokenPtr[1].start, (size_t) len);
str[len] = '\0';
start = 0;
/*
* Check for anchored REs (ie ^foo$), so we can use string equal if
* possible. Do not alter the start of str so we can free it correctly.
*/
if (str[0] == '^') {
start++;
anchorLeft = 1;
} else {
anchorLeft = 0;
}
if ((str[len-1] == '$') && ((len == 1) || (str[len-2] != '\\'))) {
anchorRight = 1;
str[--len] = '\0';
} else {
anchorRight = 0;
}
/*
* On the first (pattern) arg, check to see if any RE special characters
* are in the word. If not, this is the same as 'string equal'.
*/
if ((len > (1+start)) && (str[start] == '.') && (str[start+1] == '*')) {
start += 2;
anchorLeft = 0;
}
if ((len > (2+start)) && (str[len-3] != '\\')
&& (str[len-2] == '.') && (str[len-1] == '*')) {
len -= 2;
str[len] = '\0';
anchorRight = 0;
}
/*
* Don't do anything with REs with other special chars. Also check if
* this is a bad RE (do this at the end because it can be expensive).
* If so, let it complain at runtime.
*/
if ((strpbrk(str + start, "*+?{}()[].\\|^$") != NULL)
|| (Tcl_RegExpCompile(NULL, str) == NULL)) {
ckfree((char *) str);
return TCL_OUT_LINE_COMPILE;
}
if (anchorLeft && anchorRight) {
TclEmitPush(TclRegisterNewLiteral(envPtr, str+start, len-start),
envPtr);
} else {
/*
* This needs to find the substring anywhere in the string, so
* use string match and *foo*, with appropriate anchoring.
*/
char *newStr = ckalloc((unsigned) len + 3);
len -= start;
if (anchorLeft) {
strncpy(newStr, str + start, (size_t) len);
} else {
newStr[0] = '*';
strncpy(newStr + 1, str + start, (size_t) len++);
}
if (!anchorRight) {
newStr[len++] = '*';
}
newStr[len] = '\0';
TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len), envPtr);
ckfree((char *) newStr);
}
ckfree((char *) str);
/*
* Push the string arg
*/
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
} else {
SetLineInformation (parsePtr->numWords-1);
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
if (anchorLeft && anchorRight && !nocase) {
TclEmitOpcode(INST_STR_EQ, envPtr);
} else {
TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileReturnCmd --
*
* Procedure called to compile the "return" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK if the
* compilation was successful. If the particular return command is
* too complex for this function (ie, return with any flags like "-code"
* or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that
* the command should be compiled "out of line" (eg, not byte compiled).
* If an error occurs then the interpreter's result contains a standard
* error message.
*
* Side effects:
* Instructions are added to envPtr to execute the "return" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileReturnCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int code;
int index = envPtr->exceptArrayNext - 1;
DefineLineInformation;
/*
* If we're not in a procedure, don't compile.
*/
if (envPtr->procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
}
/*
* Look back through the ExceptionRanges of the current CompileEnv,
* from exceptArrayPtr[(exceptArrayNext - 1)] down to
* exceptArrayPtr[0] to see if any of them is an enclosing [catch].
* If there's an enclosing [catch], don't compile.
*/
while (index >= 0) {
ExceptionRange range = envPtr->exceptArrayPtr[index];
if ((range.type == CATCH_EXCEPTION_RANGE)
&& (range.catchOffset == -1)) {
return TCL_OUT_LINE_COMPILE;
}
index--;
}
switch (parsePtr->numWords) {
case 1: {
/*
* Simple case: [return]
* Just push the literal string "".
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
break;
}
case 2: {
/*
* More complex cases:
* [return "foo"]
* [return $value]
* [return [otherCmd]]
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
* [return "foo"] case: the parse token is a simple word,
* so just push it.
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
varTokenPtr[1].size), envPtr);
} else {
/*
* Parse token is more complex, so compile it; this handles the
* variable reference and nested command cases. If the
* parse token can be byte-compiled, then this instance of
* "return" will be byte-compiled; otherwise it will be
* out line compiled.
*/
SetLineInformation (1);
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
break;
}
default: {
/*
* Most complex return cases: everything else, including
* [return -code error], etc.
*/
return TCL_OUT_LINE_COMPILE;
}
}
/*
* The INST_DONE opcode actually causes the branching out of the
* subroutine, and takes the top stack item as the return result
* (which is why we pushed the value above).
*/
TclEmitOpcode(INST_DONE, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileSetCmd --
*
* Procedure called to compile the "set" command.
*
* Results:
* The return value is a standard Tcl result, which is normally TCL_OK
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message. If
* compilation fails because the set command requires a second level of
* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
* set command should be compiled "out of line" by emitting code to
* invoke its command procedure (Tcl_SetCmd) at runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "set" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileSetCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isAssignment, isScalar, simpleVarName, localIndex, numWords;
int code = TCL_OK;
DefineLineInformation;
numWords = parsePtr->numWords;
if ((numWords != 2) && (numWords != 3)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"set varName ?newValue?\"", -1);
return TCL_ERROR;
}
isAssignment = (numWords == 3);
/*
* Decide if we can use a frame slot for the var/array name or if we
* need to emit code to compute and push the name at runtime. We use a
* frame slot (entry in the array of local vars) if we are compiling a
* procedure body and if the name is simple text that does not include
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
&localIndex, &simpleVarName, &isScalar, 1);
if (code != TCL_OK) {
goto done;
}
/*
* If we are doing an assignment, push the new value.
*/
if (isAssignment) {
valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
valueTokenPtr[1].size), envPtr);
} else {
SetLineInformation (2);
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
}
/*
* Emit instructions to set/get the variable.
*/
if (simpleVarName) {
if (isScalar) {
if (localIndex >= 0) {
if (localIndex <= 255) {
TclEmitInstInt1((isAssignment?
INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
localIndex, envPtr);
} else {
TclEmitInstInt4((isAssignment?
INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
localIndex, envPtr);
}
} else {
TclEmitOpcode((isAssignment?
INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
}
} else {
if (localIndex >= 0) {
if (localIndex <= 255) {
TclEmitInstInt1((isAssignment?
INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
localIndex, envPtr);
} else {
TclEmitInstInt4((isAssignment?
INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
localIndex, envPtr);
}
} else {
TclEmitOpcode((isAssignment?
INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
}
}
} else {
TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
}
done:
return code;
}
/*
*----------------------------------------------------------------------
*
* TclCompileStringCmd --
*
* Procedure called to compile the "string" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK if the
* compilation was successful. If the command cannot be byte-compiled,
* TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
* interpreter's result contains an error message, and TCL_ERROR is
* returned.
*
* Side effects:
* Instructions are added to envPtr to execute the "string" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileStringCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *opTokenPtr, *varTokenPtr;
Tcl_Obj *opObj;
int index;
int code;
static CONST char *options[] = {
"bytelength", "compare", "equal", "first",
"index", "is", "last", "length",
"map", "match", "range", "repeat",
"replace", "tolower", "toupper", "totitle",
"trim", "trimleft", "trimright",
"wordend", "wordstart", (char *) NULL
};
enum options {
STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
STR_WORDEND, STR_WORDSTART
};
DefineLineInformation;
if (parsePtr->numWords < 2) {
/* Fail at run time, not in compilation */
return TCL_OUT_LINE_COMPILE;
}
opTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size);
if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0,
&index) != TCL_OK) {
Tcl_DecrRefCount(opObj);
Tcl_ResetResult(interp);
return TCL_OUT_LINE_COMPILE;
}
Tcl_DecrRefCount(opObj);
varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1);
switch ((enum options) index) {
case STR_BYTELENGTH:
case STR_FIRST:
case STR_IS:
case STR_LAST:
case STR_MAP:
case STR_RANGE:
case STR_REPEAT:
case STR_REPLACE:
case STR_TOLOWER:
case STR_TOUPPER:
case STR_TOTITLE:
case STR_TRIM:
case STR_TRIMLEFT:
case STR_TRIMRIGHT:
case STR_WORDEND:
case STR_WORDSTART:
/*
* All other cases: compile out of line.
*/
return TCL_OUT_LINE_COMPILE;
case STR_COMPARE:
case STR_EQUAL: {
int i;
/*
* If there are any flags to the command, we can't byte compile it
* because the INST_STR_EQ bytecode doesn't support flags.
*/
if (parsePtr->numWords != 4) {
return TCL_OUT_LINE_COMPILE;
}
/*
* Push the two operands onto the stack.
*/
for (i = 0; i < 2; i++) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
} else {
SetLineInformation (i);
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
}
TclEmitOpcode(((((enum options) index) == STR_COMPARE) ?
INST_STR_CMP : INST_STR_EQ), envPtr);
return TCL_OK;
}
case STR_INDEX: {
int i;
if (parsePtr->numWords != 4) {
/* Fail at run time, not in compilation */
return TCL_OUT_LINE_COMPILE;
}
/*
* Push the two operands onto the stack.
*/
for (i = 0; i < 2; i++) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
} else {
SetLineInformation (i);
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
}
TclEmitOpcode(INST_STR_INDEX, envPtr);
return TCL_OK;
}
case STR_LENGTH: {
if (parsePtr->numWords != 3) {
/* Fail at run time, not in compilation */
return TCL_OUT_LINE_COMPILE;
}
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
* Here someone is asking for the length of a static string.
* Just push the actual character (not byte) length.
*/
char buf[TCL_INTEGER_SPACE];
int len = Tcl_NumUtfChars(varTokenPtr[1].start,
varTokenPtr[1].size);
len = sprintf(buf, "%d", len);
TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
return TCL_OK;
} else {
SetLineInformation (2);
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
TclEmitOpcode(INST_STR_LEN, envPtr);
return TCL_OK;
}
case STR_MATCH: {
int i, length, exactMatch = 0, nocase = 0;
CONST char *str;
if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
/* Fail at run time, not in compilation */
return TCL_OUT_LINE_COMPILE;
}
if (parsePtr->numWords == 5) {
if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_OUT_LINE_COMPILE;
}
str = varTokenPtr[1].start;
length = varTokenPtr[1].size;
if ((length > 1) &&
strncmp(str, "-nocase", (size_t) length) == 0) {
nocase = 1;
} else {
/* Fail at run time, not in compilation */
return TCL_OUT_LINE_COMPILE;
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
}
for (i = 0; i < 2; i++) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
str = varTokenPtr[1].start;
length = varTokenPtr[1].size;
if (!nocase && (i == 0)) {
/*
* On the first (pattern) arg, check to see if any
* glob special characters are in the word '*[]?\\'.
* If not, this is the same as 'string equal'. We
* can use strpbrk here because the glob chars are all
* in the ascii-7 range. If -nocase was specified,
* we can't do this because INST_STR_EQ has no support
* for nocase.
*/
Tcl_Obj *copy = Tcl_NewStringObj(str, length);
Tcl_IncrRefCount(copy);
exactMatch = (strpbrk(Tcl_GetString(copy),
"*[]?\\") == NULL);
Tcl_DecrRefCount(copy);
}
TclEmitPush(
TclRegisterNewLiteral(envPtr, str, length), envPtr);
} else {
SetLineInformation (i);
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
}
if (exactMatch) {
TclEmitOpcode(INST_STR_EQ, envPtr);
} else {
TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
}
return TCL_OK;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileVariableCmd --
*
* Procedure called to reserve the local variables for the
* "variable" command. The command itself is *not* compiled.
*
* Results:
* Always returns TCL_OUT_LINE_COMPILE.
*
* Side effects:
* Indexed local variables are added to the environment.
*
*----------------------------------------------------------------------
*/
int
TclCompileVariableCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int i, numWords;
CONST char *varName, *tail;
if (envPtr->procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
}
numWords = parsePtr->numWords;
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
for (i = 1; i < numWords; i += 2) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
varName = varTokenPtr[1].start;
tail = varName + varTokenPtr[1].size - 1;
if ((*tail == ')') || (tail < varName)) continue;
while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
tail--;
}
if ((*tail == ':') && (tail > varName)) {
tail++;
}
(void) TclFindCompiledLocal(tail, (tail-varName+1),
/*create*/ 1, /*flags*/ 0, envPtr->procPtr);
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
}
}
return TCL_OUT_LINE_COMPILE;
}
/*
*----------------------------------------------------------------------
*
* TclCompileWhileCmd --
*
* Procedure called to compile the "while" command.
*
* Results:
* The return value is a standard Tcl result, which is TCL_OK if
* compilation was successful. If an error occurs then the
* interpreter's result contains a standard error message and TCL_ERROR
* is returned. If compilation failed because the command is too
* complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
* indicating that the while command should be compiled "out of line"
* by emitting code to invoke its command procedure at runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "while" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileWhileCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *testTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, jumpDist;
int range, code;
char buffer[32 + TCL_INTEGER_SPACE];
int savedStackDepth = envPtr->currStackDepth;
int loopMayEnd = 1; /* This is set to 0 if it is recognized as
* an infinite loop. */
Tcl_Obj *boolObj;
int boolVal;
DefineLineInformation;
if (parsePtr->numWords != 3) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"while test command\"", -1);
return TCL_ERROR;
}
/*
* If the test expression requires substitutions, don't compile the
* while command inline. E.g., the expression might cause the loop to
* never execute or execute forever, as in "while "$x < 5" {}".
*
* Bail out also if the body expression requires substitutions
* in order to insure correct behaviour [Bug 219166]
*/
testTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
|| (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
return TCL_OUT_LINE_COMPILE;
}
/*
* Find out if the condition is a constant.
*/
boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
Tcl_IncrRefCount(boolObj);
code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
Tcl_DecrRefCount(boolObj);
if (code == TCL_OK) {
if (boolVal) {
/*
* it is an infinite loop
*/
loopMayEnd = 0;
} else {
/*
* This is an empty loop: "while 0 {...}" or such.
* Compile no bytecodes.
*/
goto pushResult;
}
}
/*
* Create a ExceptionRange record for the loop body. This is used to
* implement break and continue.
*/
envPtr->exceptDepth++;
envPtr->maxExceptDepth =
TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
/*
* Jump to the evaluation of the condition. This code uses the "loop
* rotation" optimisation (which eliminates one branch from the loop).
* "while cond body" produces then:
* goto A
* B: body : bodyCodeOffset
* A: cond -> result : testCodeOffset, continueOffset
* if (result) goto B
*
* The infinite loop "while 1 body" produces:
* B: body : all three offsets here
* goto B
*/
if (loopMayEnd) {
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
testCodeOffset = 0; /* avoid compiler warning */
} else {
testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
}
/*
* Compile the loop body.
*/
SetLineInformation (2);
bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"while\" body line %d)",
interp->errorLine);
Tcl_AddObjErrorInfo(interp, buffer, -1);
}
goto error;
}
envPtr->exceptArrayPtr[range].numCodeBytes =
(envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
/*
* Compile the test expression then emit the conditional jump that
* terminates the while. We already know it's a simple word.
*/
if (loopMayEnd) {
testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
bodyCodeOffset += 3;
testCodeOffset += 3;
}
envPtr->currStackDepth = savedStackDepth;
SetLineInformation (1);
code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"while\" test expression)", -1);
}
goto error;
}
envPtr->currStackDepth = savedStackDepth + 1;
jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
if (jumpDist > 127) {
TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
} else {
TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
}
} else {
jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
if (jumpDist > 127) {
TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
} else {
TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
}
}
/*
* Set the loop's body, continue and break offsets.
*/
envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
envPtr->exceptArrayPtr[range].breakOffset =
(envPtr->codeNext - envPtr->codeStart);
/*
* The while command's result is an empty string.
*/
pushResult:
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
envPtr->exceptDepth--;
return TCL_OK;
error:
envPtr->exceptDepth--;
return code;
}
/*
*----------------------------------------------------------------------
*
* TclPushVarName --
*
* Procedure used in the compiling where pushing a variable name
* is necessary (append, lappend, set).
*
* Results:
* The return value is a standard Tcl result, which is normally TCL_OK
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message.
*
* Side effects:
* Instructions are added to envPtr to execute the "set" command
* at runtime.
*
*----------------------------------------------------------------------
*/
static int
TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
#ifndef TCL_TIP280
simpleVarNamePtr, isScalarPtr)
#else
simpleVarNamePtr, isScalarPtr, line, clNext)
#endif
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Token *varTokenPtr; /* Points to a variable token. */
CompileEnv *envPtr; /* Holds resulting instructions. */
int flags; /* takes TCL_CREATE_VAR or
* TCL_NO_LARGE_INDEX */
int *localIndexPtr; /* must not be NULL */
int *simpleVarNamePtr; /* must not be NULL */
int *isScalarPtr; /* must not be NULL */
#ifdef TCL_TIP280
int line; /* line the token starts on */
int* clNext;
#endif
{
register CONST char *p;
CONST char *name, *elName;
register int i, n;
int nameChars, elNameChars, simpleVarName, localIndex;
int code = TCL_OK;
Tcl_Token *elemTokenPtr = NULL;
int elemTokenCount = 0;
int allocedTokens = 0;
int removedParen = 0;
/*
* Decide if we can use a frame slot for the var/array name or if we
* need to emit code to compute and push the name at runtime. We use a
* frame slot (entry in the array of local vars) if we are compiling a
* procedure body and if the name is simple text that does not include
* namespace qualifiers.
*/
simpleVarName = 0;
name = elName = NULL;
nameChars = elNameChars = 0;
localIndex = -1;
/*
* Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
* curly braces surround the variable name.
* This really matters for array elements to handle things like
* set {x($foo)} 5
* which raises an undefined var error if we are not careful here.
*/
if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
(varTokenPtr->start[0] != '{')) {
/*
* A simple variable name. Divide it up into "name" and "elName"
* strings. If it is not a local variable, look it up at runtime.
*/
simpleVarName = 1;
name = varTokenPtr[1].start;
nameChars = varTokenPtr[1].size;
if ( *(name + nameChars - 1) == ')') {
/*
* last char is ')' => potential array reference.
*/
for (i = 0, p = name; i < nameChars; i++, p++) {
if (*p == '(') {
elName = p + 1;
elNameChars = nameChars - i - 2;
nameChars = i ;
break;
}
}
if ((elName != NULL) && elNameChars) {
/*
* An array element, the element name is a simple
* string: assemble the corresponding token.
*/
elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
elemTokenPtr->size = elNameChars;
elemTokenPtr->numComponents = 0;
elemTokenCount = 1;
}
}
} else if (((n = varTokenPtr->numComponents) > 1)
&& (varTokenPtr[1].type == TCL_TOKEN_TEXT)
&& (varTokenPtr[n].type == TCL_TOKEN_TEXT)
&& (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
/*
* Check for parentheses inside first token
*/
simpleVarName = 0;
for (i = 0, p = varTokenPtr[1].start;
i < varTokenPtr[1].size; i++, p++) {
if (*p == '(') {
simpleVarName = 1;
break;
}
}
if (simpleVarName) {
int remainingChars;
/*
* Check the last token: if it is just ')', do not count
* it. Otherwise, remove the ')' and flag so that it is
* restored at the end.
*/
if (varTokenPtr[n].size == 1) {
--n;
} else {
--varTokenPtr[n].size;
removedParen = n;
}
name = varTokenPtr[1].start;
nameChars = p - varTokenPtr[1].start;
elName = p + 1;
remainingChars = (varTokenPtr[2].start - p) - 1;
elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;
if (remainingChars) {
/*
* Make a first token with the extra characters in the first
* token.
*/
elemTokenPtr = (Tcl_Token *) ckalloc(n * sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
elemTokenPtr->size = remainingChars;
elemTokenPtr->numComponents = 0;
elemTokenCount = n;
/*
* Copy the remaining tokens.
*/
memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]),
((n-1) * sizeof(Tcl_Token)));
} else {
/*
* Use the already available tokens.
*/
elemTokenPtr = &varTokenPtr[2];
elemTokenCount = n - 1;
}
}
}
if (simpleVarName) {
/*
* See whether name has any namespace separators (::'s).
*/
int hasNsQualifiers = 0;
for (i = 0, p = name; i < nameChars; i++, p++) {
if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
hasNsQualifiers = 1;
break;
}
}
/*
* Look up the var name's index in the array of local vars in the
* proc frame. If retrieving the var's value and it doesn't already
* exist, push its name and look it up at runtime.
*/
if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
localIndex = TclFindCompiledLocal(name, nameChars,
/*create*/ (flags & TCL_CREATE_VAR),
/*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
envPtr->procPtr);
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
/* we'll push the name */
localIndex = -1;
}
}
if (localIndex < 0) {
TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr);
}
/*
* Compile the element script, if any.
*/
if (elName != NULL) {
if (elNameChars) {
#ifdef TCL_TIP280
envPtr->line = line;
envPtr->clNext = clNext;
#endif
code = TclCompileTokens(interp, elemTokenPtr,
elemTokenCount, envPtr);
if (code != TCL_OK) {
goto done;
}
} else {
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
}
}
} else {
/*
* The var name isn't simple: compile and push it.
*/
#ifdef TCL_TIP280
envPtr->line = line;
envPtr->clNext = clNext;
#endif
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
done:
if (removedParen) {
++varTokenPtr[removedParen].size;
}
if (allocedTokens) {
ckfree((char *) elemTokenPtr);
}
*localIndexPtr = localIndex;
*simpleVarNamePtr = simpleVarName;
*isScalarPtr = (elName == NULL);
return code;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclResolve.c 0000644 0036047 0045461 00000033206 11737050674 014625 0 ustar dgp 771div /*
* tclResolve.c --
*
* Contains hooks for customized command/variable name resolution
* schemes. These hooks allow extensions like [incr Tcl] to add
* their own name resolution rules to the Tcl language. Rules can
* be applied to a particular namespace, to the interpreter as a
* whole, or both.
*
* Copyright (c) 1998 Lucent Technologies, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* Declarations for procedures local to this file:
*/
static void BumpCmdRefEpochs _ANSI_ARGS_((Namespace *nsPtr));
/*
*----------------------------------------------------------------------
*
* Tcl_AddInterpResolvers --
*
* Adds a set of command/variable resolution procedures to an
* interpreter. These procedures are consulted when commands
* are resolved in Tcl_FindCommand, and when variables are
* resolved in TclLookupVar and LookupCompiledLocal. Each
* namespace may also have its own set of resolution procedures
* which take precedence over those for the interpreter.
*
* When a name is resolved, it is handled as follows. First,
* the name is passed to the resolution procedures for the
* namespace. If not resolved, the name is passed to each of
* the resolution procedures added to the interpreter. Finally,
* if still not resolved, the name is handled using the default
* Tcl rules for name resolution.
*
* Results:
* Returns pointers to the current name resolution procedures
* in the cmdProcPtr, varProcPtr and compiledVarProcPtr
* arguments.
*
* Side effects:
* If a compiledVarProc is specified, this procedure bumps the
* compileEpoch for the interpreter, forcing all code to be
* recompiled. If a cmdProc is specified, this procedure bumps
* the cmdRefEpoch in all namespaces, forcing commands to be
* resolved again using the new rules.
*
*----------------------------------------------------------------------
*/
void
Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc)
Tcl_Interp *interp; /* Interpreter whose name resolution
* rules are being modified. */
CONST char *name; /* Name of this resolution scheme. */
Tcl_ResolveCmdProc *cmdProc; /* New procedure for command
* resolution */
Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution
* at runtime */
Tcl_ResolveCompiledVarProc *compiledVarProc;
/* Procedure for variable resolution
* at compile time. */
{
Interp *iPtr = (Interp*)interp;
ResolverScheme *resPtr;
/*
* Since we're adding a new name resolution scheme, we must force
* all code to be recompiled to use the new scheme. If there
* are new compiled variable resolution rules, bump the compiler
* epoch to invalidate compiled code. If there are new command
* resolution rules, bump the cmdRefEpoch in all namespaces.
*/
if (compiledVarProc) {
iPtr->compileEpoch++;
}
if (cmdProc) {
BumpCmdRefEpochs(iPtr->globalNsPtr);
}
/*
* Look for an existing scheme with the given name. If found,
* then replace its rules.
*/
for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
resPtr->cmdResProc = cmdProc;
resPtr->varResProc = varProc;
resPtr->compiledVarResProc = compiledVarProc;
return;
}
}
/*
* Otherwise, this is a new scheme. Add it to the FRONT
* of the linked list, so that it overrides existing schemes.
*/
resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme));
resPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1));
strcpy(resPtr->name, name);
resPtr->cmdResProc = cmdProc;
resPtr->varResProc = varProc;
resPtr->compiledVarResProc = compiledVarProc;
resPtr->nextPtr = iPtr->resolverPtr;
iPtr->resolverPtr = resPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetInterpResolvers --
*
* Looks for a set of command/variable resolution procedures with
* the given name in an interpreter. These procedures are
* registered by calling Tcl_AddInterpResolvers.
*
* Results:
* If the name is recognized, this procedure returns non-zero,
* along with pointers to the name resolution procedures in
* the Tcl_ResolverInfo structure. If the name is not recognized,
* this procedure returns zero.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetInterpResolvers(interp, name, resInfoPtr)
Tcl_Interp *interp; /* Interpreter whose name resolution
* rules are being queried. */
CONST char *name; /* Look for a scheme with this name. */
Tcl_ResolverInfo *resInfoPtr; /* Returns pointers to the procedures,
* if found */
{
Interp *iPtr = (Interp*)interp;
ResolverScheme *resPtr;
/*
* Look for an existing scheme with the given name. If found,
* then return pointers to its procedures.
*/
for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
resInfoPtr->cmdResProc = resPtr->cmdResProc;
resInfoPtr->varResProc = resPtr->varResProc;
resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc;
return 1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RemoveInterpResolvers --
*
* Removes a set of command/variable resolution procedures
* previously added by Tcl_AddInterpResolvers. The next time
* a command/variable name is resolved, these procedures
* won't be consulted.
*
* Results:
* Returns non-zero if the name was recognized and the
* resolution scheme was deleted. Returns zero otherwise.
*
* Side effects:
* If a scheme with a compiledVarProc was deleted, this procedure
* bumps the compileEpoch for the interpreter, forcing all code
* to be recompiled. If a scheme with a cmdProc was deleted,
* this procedure bumps the cmdRefEpoch in all namespaces,
* forcing commands to be resolved again using the new rules.
*
*----------------------------------------------------------------------
*/
int
Tcl_RemoveInterpResolvers(interp, name)
Tcl_Interp *interp; /* Interpreter whose name resolution
* rules are being modified. */
CONST char *name; /* Name of the scheme to be removed. */
{
Interp *iPtr = (Interp*)interp;
ResolverScheme **prevPtrPtr, *resPtr;
/*
* Look for an existing scheme with the given name.
*/
prevPtrPtr = &iPtr->resolverPtr;
for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
break;
}
prevPtrPtr = &resPtr->nextPtr;
}
/*
* If we found the scheme, delete it.
*/
if (resPtr) {
/*
* If we're deleting a scheme with compiled variable resolution
* rules, bump the compiler epoch to invalidate compiled code.
* If we're deleting a scheme with command resolution rules,
* bump the cmdRefEpoch in all namespaces.
*/
if (resPtr->compiledVarResProc) {
iPtr->compileEpoch++;
}
if (resPtr->cmdResProc) {
BumpCmdRefEpochs(iPtr->globalNsPtr);
}
*prevPtrPtr = resPtr->nextPtr;
ckfree(resPtr->name);
ckfree((char *) resPtr);
return 1;
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* BumpCmdRefEpochs --
*
* This procedure is used to bump the cmdRefEpoch counters in
* the specified namespace and all of its child namespaces.
* It is used whenever name resolution schemes are added/removed
* from an interpreter, to invalidate all command references.
*
* Results:
* None.
*
* Side effects:
* Bumps the cmdRefEpoch in the specified namespace and its
* children, recursively.
*
*----------------------------------------------------------------------
*/
static void
BumpCmdRefEpochs(nsPtr)
Namespace *nsPtr; /* Namespace being modified. */
{
Tcl_HashEntry *entry;
Tcl_HashSearch search;
Namespace *childNsPtr;
nsPtr->cmdRefEpoch++;
for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entry != NULL;
entry = Tcl_NextHashEntry(&search)) {
childNsPtr = (Namespace *) Tcl_GetHashValue(entry);
BumpCmdRefEpochs(childNsPtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetNamespaceResolvers --
*
* Sets the command/variable resolution procedures for a namespace,
* thereby changing the way that command/variable names are
* interpreted. This allows extension writers to support different
* name resolution schemes, such as those for object-oriented
* packages.
*
* Command resolution is handled by a procedure of the following
* type:
*
* typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((
* Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
* int flags, Tcl_Command *rPtr));
*
* Whenever a command is executed or Tcl_FindCommand is invoked
* within the namespace, this procedure is called to resolve the
* command name. If this procedure is able to resolve the name,
* it should return the status code TCL_OK, along with the
* corresponding Tcl_Command in the rPtr argument. Otherwise,
* the procedure can return TCL_CONTINUE, and the command will
* be treated under the usual name resolution rules. Or, it can
* return TCL_ERROR, and the command will be considered invalid.
*
* Variable resolution is handled by two procedures. The first
* is called whenever a variable needs to be resolved at compile
* time:
*
* typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
* Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
* Tcl_ResolvedVarInfo *rPtr));
*
* If this procedure is able to resolve the name, it should return
* the status code TCL_OK, along with variable resolution info in
* the rPtr argument; this info will be used to set up compiled
* locals in the call frame at runtime. The procedure may also
* return TCL_CONTINUE, and the variable will be treated under
* the usual name resolution rules. Or, it can return TCL_ERROR,
* and the variable will be considered invalid.
*
* Another procedure is used whenever a variable needs to be
* resolved at runtime but it is not recognized as a compiled local.
* (For example, the variable may be requested via
* Tcl_FindNamespaceVar.) This procedure has the following type:
*
* typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
* Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
* int flags, Tcl_Var *rPtr));
*
* This procedure is quite similar to the compile-time version.
* It returns the same status codes, but if variable resolution
* succeeds, this procedure returns a Tcl_Var directly via the
* rPtr argument.
*
* Results:
* Nothing.
*
* Side effects:
* Bumps the command epoch counter for the namespace, invalidating
* all command references in that namespace. Also bumps the
* resolver epoch counter for the namespace, forcing all code
* in the namespace to be recompiled.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc)
Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules
* are being modified. */
Tcl_ResolveCmdProc *cmdProc; /* Procedure for command resolution */
Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution
* at runtime */
Tcl_ResolveCompiledVarProc *compiledVarProc;
/* Procedure for variable resolution
* at compile time. */
{
Namespace *nsPtr = (Namespace*)namespacePtr;
/*
* Plug in the new command resolver, and bump the epoch counters
* so that all code will have to be recompiled and all commands
* will have to be resolved again using the new policy.
*/
nsPtr->cmdResProc = cmdProc;
nsPtr->varResProc = varProc;
nsPtr->compiledVarResProc = compiledVarProc;
nsPtr->cmdRefEpoch++;
nsPtr->resolverEpoch++;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetNamespaceResolvers --
*
* Returns the current command/variable resolution procedures
* for a namespace. By default, these procedures are NULL.
* New procedures can be installed by calling
* Tcl_SetNamespaceResolvers, to provide new name resolution
* rules.
*
* Results:
* Returns non-zero if any name resolution procedures have been
* assigned to this namespace; also returns pointers to the
* procedures in the Tcl_ResolverInfo structure. Returns zero
* otherwise.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetNamespaceResolvers(namespacePtr, resInfoPtr)
Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules
* are being modified. */
Tcl_ResolverInfo *resInfoPtr; /* Returns: pointers for all
* name resolution procedures
* assigned to this namespace. */
{
Namespace *nsPtr = (Namespace*)namespacePtr;
resInfoPtr->cmdResProc = nsPtr->cmdResProc;
resInfoPtr->varResProc = nsPtr->varResProc;
resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc;
if (nsPtr->cmdResProc != NULL ||
nsPtr->varResProc != NULL ||
nsPtr->compiledVarResProc != NULL) {
return 1;
}
return 0;
}
tcl8.4.20/generic/tclGetDate.y 0000644 0036047 0045461 00000100516 12052456743 014546 0 ustar dgp 771div /*
* tclGetDate.y --
*
* Contains yacc grammar for parsing date and time strings.
* The output of this file should be the file tclDate.c which
* is used directly in the Tcl sources.
*
* Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
* Copyright (c) 1995-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.
*/
%{
/*
* tclDate.c --
*
* This file is generated from a yacc grammar defined in
* the file tclGetDate.y. It should not be edited directly.
*
* Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
* Copyright (c) 1995-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.
*
* SCCSID
*/
#include "tclInt.h"
#include "tclPort.h"
#define EPOCH 1970
#define START_OF_TIME 1902
#define END_OF_TIME 2037
/*
* The offset of tm_year of struct tm returned by localtime, gmtime, etc.
* I don't know how universal this is; K&R II, the NetBSD manpages, and
* ../compat/strftime.c all agree that tm_year is the year-1900. However,
* some systems may have a different value. This #define should be the
* same as in ../compat/strftime.c.
*/
#define TM_YEAR_BASE 1900
#define HOUR(x) ((int) (60 * x))
#define SECSPERDAY (24L * 60L * 60L)
#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0))
/*
* An entry in the lexical lookup table.
*/
typedef struct _TABLE {
char *name;
int type;
time_t value;
} TABLE;
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
/*
* Meridian: am, pm, or 24-hour style.
*/
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
/*
* Global variables. We could get rid of most of these by using a good
* union as the yacc stack. (This routine was originally written before
* yacc had the %union construct.) Maybe someday; right now we only use
* the %union very rarely.
*/
static char *yyInput;
static DSTMODE yyDSTmode;
static time_t yyDayOrdinal;
static time_t yyDayNumber;
static time_t yyMonthOrdinal;
static int yyHaveDate;
static int yyHaveDay;
static int yyHaveOrdinalMonth;
static int yyHaveRel;
static int yyHaveTime;
static int yyHaveZone;
static time_t yyTimezone;
static time_t yyDay;
static time_t yyHour;
static time_t yyMinutes;
static time_t yyMonth;
static time_t yySeconds;
static time_t yyYear;
static MERIDIAN yyMeridian;
static time_t yyRelMonth;
static time_t yyRelDay;
static time_t yyRelSeconds;
static time_t *yyRelPointer;
/*
* Prototypes of internal functions.
*/
static void yyerror _ANSI_ARGS_((char *s));
static time_t ToSeconds _ANSI_ARGS_((time_t Hours, time_t Minutes,
time_t Seconds, MERIDIAN Meridian));
static int Convert _ANSI_ARGS_((time_t Month, time_t Day, time_t Year,
time_t Hours, time_t Minutes, time_t Seconds,
MERIDIAN Meridia, DSTMODE DSTmode, time_t *TimePtr));
static time_t DSTcorrect _ANSI_ARGS_((time_t Start, time_t Future));
static time_t NamedDay _ANSI_ARGS_((time_t Start, time_t DayOrdinal,
time_t DayNumber));
static time_t NamedMonth _ANSI_ARGS_((time_t Start, time_t MonthOrdinal,
time_t MonthNumber));
static int RelativeMonth _ANSI_ARGS_((time_t Start, time_t RelMonth,
time_t *TimePtr));
static int RelativeDay _ANSI_ARGS_((time_t Start, time_t RelDay,
time_t *TimePtr));
static int LookupWord _ANSI_ARGS_((char *buff));
static int yylex _ANSI_ARGS_((void));
int
yyparse _ANSI_ARGS_((void));
%}
%union {
time_t Number;
enum _MERIDIAN Meridian;
}
%token tAGO tDAY tDAYZONE tID tMERIDIAN tMINUTE_UNIT tMONTH tMONTH_UNIT
%token tSTARDATE tSEC_UNIT tSNUMBER tUNUMBER tZONE tEPOCH tDST tISOBASE
%token tDAY_UNIT tNEXT
%type tDAY tDAYZONE tMINUTE_UNIT tMONTH tMONTH_UNIT tDST
%type tSEC_UNIT tSNUMBER tUNUMBER tZONE tISOBASE tDAY_UNIT
%type unit sign tNEXT tSTARDATE
%type tMERIDIAN o_merid
%%
spec : /* NULL */
| spec item
;
item : time {
yyHaveTime++;
}
| zone {
yyHaveZone++;
}
| date {
yyHaveDate++;
}
| ordMonth {
yyHaveOrdinalMonth++;
}
| day {
yyHaveDay++;
}
| relspec {
yyHaveRel++;
}
| iso {
yyHaveTime++;
yyHaveDate++;
}
| trek {
yyHaveTime++;
yyHaveDate++;
yyHaveRel++;
}
| number
;
time : tUNUMBER tMERIDIAN {
yyHour = $1;
yyMinutes = 0;
yySeconds = 0;
yyMeridian = $2;
}
| tUNUMBER ':' tUNUMBER o_merid {
yyHour = $1;
yyMinutes = $3;
yySeconds = 0;
yyMeridian = $4;
}
| tUNUMBER ':' tUNUMBER '-' tUNUMBER {
yyHour = $1;
yyMinutes = $3;
yyMeridian = MER24;
yyDSTmode = DSToff;
yyTimezone = ($5 % 100 + ($5 / 100) * 60);
}
| tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid {
yyHour = $1;
yyMinutes = $3;
yySeconds = $5;
yyMeridian = $6;
}
| tUNUMBER ':' tUNUMBER ':' tUNUMBER '-' tUNUMBER {
yyHour = $1;
yyMinutes = $3;
yySeconds = $5;
yyMeridian = MER24;
yyDSTmode = DSToff;
yyTimezone = ($7 % 100 + ($7 / 100) * 60);
}
;
zone : tZONE tDST {
yyTimezone = $1;
yyDSTmode = DSTon;
}
| tZONE {
yyTimezone = $1;
yyDSTmode = DSToff;
}
| tDAYZONE {
yyTimezone = $1;
yyDSTmode = DSTon;
}
;
day : tDAY {
yyDayOrdinal = 1;
yyDayNumber = $1;
}
| tDAY ',' {
yyDayOrdinal = 1;
yyDayNumber = $1;
}
| tUNUMBER tDAY {
yyDayOrdinal = $1;
yyDayNumber = $2;
}
| sign tUNUMBER tDAY {
yyDayOrdinal = $1 * $2;
yyDayNumber = $3;
}
| tNEXT tDAY {
yyDayOrdinal = 2;
yyDayNumber = $2;
}
;
date : tUNUMBER '/' tUNUMBER {
yyMonth = $1;
yyDay = $3;
}
| tUNUMBER '/' tUNUMBER '/' tUNUMBER {
yyMonth = $1;
yyDay = $3;
yyYear = $5;
}
| tISOBASE {
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
}
| tUNUMBER '-' tMONTH '-' tUNUMBER {
yyDay = $1;
yyMonth = $3;
yyYear = $5;
}
| tUNUMBER '-' tUNUMBER '-' tUNUMBER {
yyMonth = $3;
yyDay = $5;
yyYear = $1;
}
| tMONTH tUNUMBER {
yyMonth = $1;
yyDay = $2;
}
| tMONTH tUNUMBER ',' tUNUMBER {
yyMonth = $1;
yyDay = $2;
yyYear = $4;
}
| tUNUMBER tMONTH {
yyMonth = $2;
yyDay = $1;
}
| tEPOCH {
yyMonth = 1;
yyDay = 1;
yyYear = EPOCH;
}
| tUNUMBER tMONTH tUNUMBER {
yyMonth = $2;
yyDay = $1;
yyYear = $3;
}
;
ordMonth: tNEXT tMONTH {
yyMonthOrdinal = 1;
yyMonth = $2;
}
| tNEXT tUNUMBER tMONTH {
yyMonthOrdinal = $2;
yyMonth = $3;
}
;
iso : tISOBASE tZONE tISOBASE {
if ($2 != HOUR(- 7)) YYABORT;
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $3 / 10000;
yyMinutes = ($3 % 10000)/100;
yySeconds = $3 % 100;
}
| tISOBASE tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER {
if ($2 != HOUR(- 7)) YYABORT;
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $3;
yyMinutes = $5;
yySeconds = $7;
}
| tISOBASE tISOBASE {
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $2 / 10000;
yyMinutes = ($2 % 10000)/100;
yySeconds = $2 % 100;
}
;
trek : tSTARDATE tUNUMBER '.' tUNUMBER {
/*
* Offset computed year by -377 so that the returned years will
* be in a range accessible with a 32 bit clock seconds value
*/
yyYear = $2/1000 + 2323 - 377;
yyDay = 1;
yyMonth = 1;
yyRelDay += (($2%1000)*(365 + IsLeapYear(yyYear)))/1000;
yyRelSeconds += $4 * 144 * 60;
}
;
relspec : relunits tAGO {
yyRelSeconds *= -1;
yyRelMonth *= -1;
yyRelDay *= -1;
}
| relunits
;
relunits : sign tUNUMBER unit { *yyRelPointer += $1 * $2 * $3; }
| tUNUMBER unit { *yyRelPointer += $1 * $2; }
| tNEXT unit { *yyRelPointer += $2; }
| tNEXT tUNUMBER unit { *yyRelPointer += $2 * $3; }
| unit { *yyRelPointer += $1; }
;
sign : '-' { $$ = -1; }
| '+' { $$ = 1; }
;
unit : tSEC_UNIT { $$ = $1; yyRelPointer = &yyRelSeconds; }
| tDAY_UNIT { $$ = $1; yyRelPointer = &yyRelDay; }
| tMONTH_UNIT { $$ = $1; yyRelPointer = &yyRelMonth; }
;
number : tUNUMBER
{
if (yyHaveTime && yyHaveDate && !yyHaveRel) {
yyYear = $1;
} else {
yyHaveTime++;
if ($1 < 100) {
yyHour = $1;
yyMinutes = 0;
} else {
yyHour = $1 / 100;
yyMinutes = $1 % 100;
}
yySeconds = 0;
yyMeridian = MER24;
}
}
;
o_merid : /* NULL */ {
$$ = MER24;
}
| tMERIDIAN {
$$ = $1;
}
;
%%
/*
* Month and day table.
*/
static CONST TABLE MonthDayTable[] = {
{ "january", tMONTH, 1 },
{ "february", tMONTH, 2 },
{ "march", tMONTH, 3 },
{ "april", tMONTH, 4 },
{ "may", tMONTH, 5 },
{ "june", tMONTH, 6 },
{ "july", tMONTH, 7 },
{ "august", tMONTH, 8 },
{ "september", tMONTH, 9 },
{ "sept", tMONTH, 9 },
{ "october", tMONTH, 10 },
{ "november", tMONTH, 11 },
{ "december", tMONTH, 12 },
{ "sunday", tDAY, 0 },
{ "monday", tDAY, 1 },
{ "tuesday", tDAY, 2 },
{ "tues", tDAY, 2 },
{ "wednesday", tDAY, 3 },
{ "wednes", tDAY, 3 },
{ "thursday", tDAY, 4 },
{ "thur", tDAY, 4 },
{ "thurs", tDAY, 4 },
{ "friday", tDAY, 5 },
{ "saturday", tDAY, 6 },
{ NULL }
};
/*
* Time units table.
*/
static CONST TABLE UnitsTable[] = {
{ "year", tMONTH_UNIT, 12 },
{ "month", tMONTH_UNIT, 1 },
{ "fortnight", tDAY_UNIT, 14 },
{ "week", tDAY_UNIT, 7 },
{ "day", tDAY_UNIT, 1 },
{ "hour", tSEC_UNIT, 60 * 60 },
{ "minute", tSEC_UNIT, 60 },
{ "min", tSEC_UNIT, 60 },
{ "second", tSEC_UNIT, 1 },
{ "sec", tSEC_UNIT, 1 },
{ NULL }
};
/*
* Assorted relative-time words.
*/
static CONST TABLE OtherTable[] = {
{ "tomorrow", tDAY_UNIT, 1 },
{ "yesterday", tDAY_UNIT, -1 },
{ "today", tDAY_UNIT, 0 },
{ "now", tSEC_UNIT, 0 },
{ "last", tUNUMBER, -1 },
{ "this", tSEC_UNIT, 0 },
{ "next", tNEXT, 1 },
#if 0
{ "first", tUNUMBER, 1 },
{ "second", tUNUMBER, 2 },
{ "third", tUNUMBER, 3 },
{ "fourth", tUNUMBER, 4 },
{ "fifth", tUNUMBER, 5 },
{ "sixth", tUNUMBER, 6 },
{ "seventh", tUNUMBER, 7 },
{ "eighth", tUNUMBER, 8 },
{ "ninth", tUNUMBER, 9 },
{ "tenth", tUNUMBER, 10 },
{ "eleventh", tUNUMBER, 11 },
{ "twelfth", tUNUMBER, 12 },
#endif
{ "ago", tAGO, 1 },
{ "epoch", tEPOCH, 0 },
{ "stardate", tSTARDATE, 0},
{ NULL }
};
/*
* The timezone table. (Note: This table was modified to not use any floating
* point constants to work around an SGI compiler bug).
*/
static CONST TABLE TimezoneTable[] = {
{ "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */
{ "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */
{ "utc", tZONE, HOUR( 0) },
{ "uct", tZONE, HOUR( 0) }, /* Universal Coordinated Time */
{ "wet", tZONE, HOUR( 0) }, /* Western European */
{ "bst", tDAYZONE, HOUR( 0) }, /* British Summer */
{ "wat", tZONE, HOUR( 1) }, /* West Africa */
{ "at", tZONE, HOUR( 2) }, /* Azores */
#if 0
/* For completeness. BST is also British Summer, and GST is
* also Guam Standard. */
{ "bst", tZONE, HOUR( 3) }, /* Brazil Standard */
{ "gst", tZONE, HOUR( 3) }, /* Greenland Standard */
#endif
{ "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */
{ "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */
{ "ndt", tDAYZONE, HOUR( 7/2) }, /* Newfoundland Daylight */
{ "ast", tZONE, HOUR( 4) }, /* Atlantic Standard */
{ "adt", tDAYZONE, HOUR( 4) }, /* Atlantic Daylight */
{ "est", tZONE, HOUR( 5) }, /* Eastern Standard */
{ "edt", tDAYZONE, HOUR( 5) }, /* Eastern Daylight */
{ "cst", tZONE, HOUR( 6) }, /* Central Standard */
{ "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */
{ "mst", tZONE, HOUR( 7) }, /* Mountain Standard */
{ "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */
{ "pst", tZONE, HOUR( 8) }, /* Pacific Standard */
{ "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */
{ "yst", tZONE, HOUR( 9) }, /* Yukon Standard */
{ "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */
{ "hst", tZONE, HOUR(10) }, /* Hawaii Standard */
{ "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */
{ "cat", tZONE, HOUR(10) }, /* Central Alaska */
{ "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */
{ "nt", tZONE, HOUR(11) }, /* Nome */
{ "idlw", tZONE, HOUR(12) }, /* International Date Line West */
{ "cet", tZONE, -HOUR( 1) }, /* Central European */
{ "cest", tDAYZONE, -HOUR( 1) }, /* Central European Summer */
{ "met", tZONE, -HOUR( 1) }, /* Middle European */
{ "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */
{ "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */
{ "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */
{ "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */
{ "fwt", tZONE, -HOUR( 1) }, /* French Winter */
{ "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */
{ "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */
{ "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */
{ "it", tZONE, -HOUR( 7/2) }, /* Iran */
{ "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */
{ "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */
{ "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */
{ "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */
#if 0
/* For completeness. NST is also Newfoundland Stanard, nad SST is
* also Swedish Summer. */
{ "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */
{ "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */
#endif /* 0 */
{ "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */
{ "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */
{ "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */
{ "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */
{ "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */
{ "jdt", tDAYZONE, -HOUR( 9) }, /* Japan Daylight */
{ "kst", tZONE, -HOUR( 9) }, /* Korea Standard */
{ "kdt", tDAYZONE, -HOUR( 9) }, /* Korea Daylight */
{ "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */
{ "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */
{ "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */
{ "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */
{ "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */
{ "nzt", tZONE, -HOUR(12) }, /* New Zealand */
{ "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */
{ "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */
{ "idle", tZONE, -HOUR(12) }, /* International Date Line East */
/* ADDED BY Marco Nijdam */
{ "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */
/* End ADDED */
{ NULL }
};
/*
* Military timezone table.
*/
static CONST TABLE MilitaryTable[] = {
{ "a", tZONE, HOUR( 1) },
{ "b", tZONE, HOUR( 2) },
{ "c", tZONE, HOUR( 3) },
{ "d", tZONE, HOUR( 4) },
{ "e", tZONE, HOUR( 5) },
{ "f", tZONE, HOUR( 6) },
{ "g", tZONE, HOUR( 7) },
{ "h", tZONE, HOUR( 8) },
{ "i", tZONE, HOUR( 9) },
{ "k", tZONE, HOUR( 10) },
{ "l", tZONE, HOUR( 11) },
{ "m", tZONE, HOUR( 12) },
{ "n", tZONE, HOUR(- 1) },
{ "o", tZONE, HOUR(- 2) },
{ "p", tZONE, HOUR(- 3) },
{ "q", tZONE, HOUR(- 4) },
{ "r", tZONE, HOUR(- 5) },
{ "s", tZONE, HOUR(- 6) },
{ "t", tZONE, HOUR(- 7) },
{ "u", tZONE, HOUR(- 8) },
{ "v", tZONE, HOUR(- 9) },
{ "w", tZONE, HOUR(-10) },
{ "x", tZONE, HOUR(-11) },
{ "y", tZONE, HOUR(-12) },
{ "z", tZONE, HOUR( 0) },
{ NULL }
};
/*
* Dump error messages in the bit bucket.
*/
static void
yyerror(s)
char *s;
{
}
static time_t
ToSeconds(Hours, Minutes, Seconds, Meridian)
time_t Hours;
time_t Minutes;
time_t Seconds;
MERIDIAN Meridian;
{
if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59)
return -1;
switch (Meridian) {
case MER24:
if (Hours < 0 || Hours > 23)
return -1;
return (Hours * 60L + Minutes) * 60L + Seconds;
case MERam:
if (Hours < 1 || Hours > 12)
return -1;
return ((Hours % 12) * 60L + Minutes) * 60L + Seconds;
case MERpm:
if (Hours < 1 || Hours > 12)
return -1;
return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds;
}
return -1; /* Should never be reached */
}
/*
*-----------------------------------------------------------------------------
*
* Convert --
*
* Convert a {month, day, year, hours, minutes, seconds, meridian, dst}
* tuple into a clock seconds value.
*
* Results:
* 0 or -1 indicating success or failure.
*
* Side effects:
* Fills TimePtr with the computed value.
*
*-----------------------------------------------------------------------------
*/
static int
Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr)
time_t Month;
time_t Day;
time_t Year;
time_t Hours;
time_t Minutes;
time_t Seconds;
MERIDIAN Meridian;
DSTMODE DSTmode;
time_t *TimePtr;
{
static int DaysInMonth[12] = {
31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31
};
time_t tod;
time_t Julian;
int i;
/* Figure out how many days are in February for the given year.
* Every year divisible by 4 is a leap year.
* But, every year divisible by 100 is not a leap year.
* But, every year divisible by 400 is a leap year after all.
*/
DaysInMonth[1] = IsLeapYear(Year) ? 29 : 28;
/* Check the inputs for validity */
if (Month < 1 || Month > 12
|| Year < START_OF_TIME || Year > END_OF_TIME
|| Day < 1 || Day > DaysInMonth[(int)--Month])
return -1;
/* Start computing the value. First determine the number of days
* represented by the date, then multiply by the number of seconds/day.
*/
for (Julian = Day - 1, i = 0; i < Month; i++)
Julian += DaysInMonth[i];
if (Year >= EPOCH) {
for (i = EPOCH; i < Year; i++)
Julian += 365 + IsLeapYear(i);
} else {
for (i = Year; i < EPOCH; i++)
Julian -= 365 + IsLeapYear(i);
}
Julian *= SECSPERDAY;
/* Add the timezone offset ?? */
Julian += yyTimezone * 60L;
/* Add the number of seconds represented by the time component */
if ((tod = ToSeconds(Hours, Minutes, Seconds, Meridian)) < 0)
return -1;
Julian += tod;
/* Perform a preliminary DST compensation ?? */
if (DSTmode == DSTon
|| (DSTmode == DSTmaybe && TclpGetDate((TclpTime_t)&Julian, 0)->tm_isdst))
Julian -= 60 * 60;
*TimePtr = Julian;
return 0;
}
static time_t
DSTcorrect(Start, Future)
time_t Start;
time_t Future;
{
time_t StartDay;
time_t FutureDay;
StartDay = (TclpGetDate((TclpTime_t)&Start, 0)->tm_hour + 1) % 24;
FutureDay = (TclpGetDate((TclpTime_t)&Future, 0)->tm_hour + 1) % 24;
return (Future - Start) + (StartDay - FutureDay) * 60L * 60L;
}
static time_t
NamedDay(Start, DayOrdinal, DayNumber)
time_t Start;
time_t DayOrdinal;
time_t DayNumber;
{
struct tm *tm;
time_t now;
now = Start;
tm = TclpGetDate((TclpTime_t)&now, 0);
now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7);
now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1);
return DSTcorrect(Start, now);
}
static time_t
NamedMonth(Start, MonthOrdinal, MonthNumber)
time_t Start;
time_t MonthOrdinal;
time_t MonthNumber;
{
struct tm *tm;
time_t now;
int result;
now = Start;
tm = TclpGetDate((TclpTime_t)&now, 0);
/* To compute the next n'th month, we use this alg:
* add n to year value
* if currentMonth < requestedMonth decrement year value by 1 (so that
* doing next february from january gives us february of the current year)
* set day to 1, time to 0
*/
tm->tm_year += MonthOrdinal;
if (tm->tm_mon < MonthNumber - 1) {
tm->tm_year--;
}
result = Convert(MonthNumber, (time_t) 1, tm->tm_year + TM_YEAR_BASE,
(time_t) 0, (time_t) 0, (time_t) 0, MER24, DSTmaybe, &now);
if (result < 0) {
return 0;
}
return DSTcorrect(Start, now);
}
static int
RelativeMonth(Start, RelMonth, TimePtr)
time_t Start;
time_t RelMonth;
time_t *TimePtr;
{
struct tm *tm;
time_t Month;
time_t Year;
time_t Julian;
int result;
if (RelMonth == 0) {
*TimePtr = 0;
return 0;
}
tm = TclpGetDate((TclpTime_t)&Start, 0);
Month = 12 * (tm->tm_year + TM_YEAR_BASE) + tm->tm_mon + RelMonth;
Year = Month / 12;
Month = Month % 12 + 1;
result = Convert(Month, (time_t) tm->tm_mday, Year,
(time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec,
MER24, DSTmaybe, &Julian);
/*
* The Julian time returned above is behind by one day, if "month"
* or "year" is used to specify relative time and the GMT flag is true.
* This problem occurs only when the current time is closer to
* midnight, the difference being not more than its time difference
* with GMT. For example, in US/Pacific time zone, the problem occurs
* whenever the current time is between midnight to 8:00am or 7:00amDST.
* See Bug# 413397 for more details and sample script.
* To resolve this bug, we simply add the number of seconds corresponding
* to timezone difference with GMT to Julian time, if GMT flag is true.
*/
if (TclDateTimezone == 0) {
Julian += TclpGetTimeZone((unsigned long) Start) * 60L;
}
/*
* The following iteration takes into account the case were we jump
* into a "short month". Far example, "one month from Jan 31" will
* fail because there is no Feb 31. The code below will reduce the
* day and try converting the date until we succed or the date equals
* 28 (which always works unless the date is bad in another way).
*/
while ((result != 0) && (tm->tm_mday > 28)) {
tm->tm_mday--;
result = Convert(Month, (time_t) tm->tm_mday, Year,
(time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec,
MER24, DSTmaybe, &Julian);
}
if (result != 0) {
return -1;
}
*TimePtr = DSTcorrect(Start, Julian);
return 0;
}
/*
*-----------------------------------------------------------------------------
*
* RelativeDay --
*
* Given a starting time and a number of days before or after, compute the
* DST corrected difference between those dates.
*
* Results:
* 1 or -1 indicating success or failure.
*
* Side effects:
* Fills TimePtr with the computed value.
*
*-----------------------------------------------------------------------------
*/
static int
RelativeDay(Start, RelDay, TimePtr)
time_t Start;
time_t RelDay;
time_t *TimePtr;
{
time_t new;
new = Start + (RelDay * 60 * 60 * 24);
*TimePtr = DSTcorrect(Start, new);
return 1;
}
static int
LookupWord(buff)
char *buff;
{
register char *p;
register char *q;
register CONST TABLE *tp;
int i;
int abbrev;
/*
* Make it lowercase.
*/
Tcl_UtfToLower(buff);
if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) {
yylval.Meridian = MERam;
return tMERIDIAN;
}
if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) {
yylval.Meridian = MERpm;
return tMERIDIAN;
}
/*
* See if we have an abbreviation for a month.
*/
if (strlen(buff) == 3) {
abbrev = 1;
} else if (strlen(buff) == 4 && buff[3] == '.') {
abbrev = 1;
buff[3] = '\0';
} else {
abbrev = 0;
}
for (tp = MonthDayTable; tp->name; tp++) {
if (abbrev) {
if (strncmp(buff, tp->name, 3) == 0) {
yylval.Number = tp->value;
return tp->type;
}
} else if (strcmp(buff, tp->name) == 0) {
yylval.Number = tp->value;
return tp->type;
}
}
for (tp = TimezoneTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylval.Number = tp->value;
return tp->type;
}
}
for (tp = UnitsTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylval.Number = tp->value;
return tp->type;
}
}
/*
* Strip off any plural and try the units table again.
*/
i = strlen(buff) - 1;
if (buff[i] == 's') {
buff[i] = '\0';
for (tp = UnitsTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylval.Number = tp->value;
return tp->type;
}
}
}
for (tp = OtherTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylval.Number = tp->value;
return tp->type;
}
}
/*
* Military timezones.
*/
if (buff[1] == '\0' && !(*buff & 0x80)
&& isalpha(UCHAR(*buff))) { /* INTL: ISO only */
for (tp = MilitaryTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylval.Number = tp->value;
return tp->type;
}
}
}
/*
* Drop out any periods and try the timezone table again.
*/
for (i = 0, p = q = buff; *q; q++)
if (*q != '.') {
*p++ = *q;
} else {
i++;
}
*p = '\0';
if (i) {
for (tp = TimezoneTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylval.Number = tp->value;
return tp->type;
}
}
}
return tID;
}
static int
yylex()
{
register char c;
register char *p;
char buff[20];
int Count;
for ( ; ; ) {
while (isspace(UCHAR(*yyInput))) {
yyInput++;
}
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/* convert the string into a number; count the number of digits */
Count = 0;
for (yylval.Number = 0;
isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */
yylval.Number = 10 * yylval.Number + c - '0';
Count++;
}
yyInput--;
/* A number with 6 or more digits is considered an ISO 8601 base */
if (Count >= 6) {
return tISOBASE;
} else {
return tUNUMBER;
}
}
if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */
for (p = buff; isalpha(UCHAR(c = *yyInput++)) /* INTL: ISO only. */
|| c == '.'; ) {
if (p < &buff[sizeof buff - 1]) {
*p++ = c;
}
}
*p = '\0';
yyInput--;
return LookupWord(buff);
}
if (c != '(') {
return *yyInput++;
}
Count = 0;
do {
c = *yyInput++;
if (c == '\0') {
return c;
} else if (c == '(') {
Count++;
} else if (c == ')') {
Count--;
}
} while (Count > 0);
}
}
/*
* Specify zone is of -50000 to force GMT. (This allows BST to work).
*/
int
TclGetDate(p, now, zone, timePtr)
char *p;
Tcl_WideInt now;
long zone;
Tcl_WideInt *timePtr;
{
struct tm *tm;
time_t Start;
time_t Time;
time_t tod;
int thisyear;
yyInput = p;
/* now has to be cast to a time_t for 64bit compliance */
Start = (time_t) now;
tm = TclpGetDate((TclpTime_t) &Start, (zone == -50000));
thisyear = tm->tm_year + TM_YEAR_BASE;
yyYear = thisyear;
yyMonth = tm->tm_mon + 1;
yyDay = tm->tm_mday;
yyTimezone = zone;
if (zone == -50000) {
yyDSTmode = DSToff; /* assume GMT */
yyTimezone = 0;
} else {
yyDSTmode = DSTmaybe;
}
yyHour = 0;
yyMinutes = 0;
yySeconds = 0;
yyMeridian = MER24;
yyRelSeconds = 0;
yyRelMonth = 0;
yyRelDay = 0;
yyRelPointer = NULL;
yyHaveDate = 0;
yyHaveDay = 0;
yyHaveOrdinalMonth = 0;
yyHaveRel = 0;
yyHaveTime = 0;
yyHaveZone = 0;
if (yyparse() || yyHaveTime > 1 || yyHaveZone > 1 || yyHaveDate > 1 ||
yyHaveDay > 1 || yyHaveOrdinalMonth > 1) {
return -1;
}
if (yyHaveDate || yyHaveTime || yyHaveDay) {
if (TclDateYear < 0) {
TclDateYear = -TclDateYear;
}
/*
* The following line handles years that are specified using
* only two digits. The line of code below implements a policy
* defined by the X/Open workgroup on the millinium rollover.
* Note: some of those dates may not actually be valid on some
* platforms. The POSIX standard startes that the dates 70-99
* shall refer to 1970-1999 and 00-38 shall refer to 2000-2038.
* This later definition should work on all platforms.
*/
if (TclDateYear < 100) {
if (TclDateYear >= 69) {
TclDateYear += 1900;
} else {
TclDateYear += 2000;
}
}
if (Convert(yyMonth, yyDay, yyYear, yyHour, yyMinutes, yySeconds,
yyMeridian, yyDSTmode, &Start) < 0) {
return -1;
}
} else {
Start = (time_t) now;
if (!yyHaveRel) {
Start -= ((tm->tm_hour * 60L * 60L) +
tm->tm_min * 60L) + tm->tm_sec;
}
}
Start += yyRelSeconds;
if (RelativeMonth(Start, yyRelMonth, &Time) < 0) {
return -1;
}
Start += Time;
if (RelativeDay(Start, yyRelDay, &Time) < 0) {
return -1;
}
Start += Time;
if (yyHaveDay && !yyHaveDate) {
tod = NamedDay(Start, yyDayOrdinal, yyDayNumber);
Start += tod;
}
if (yyHaveOrdinalMonth) {
tod = NamedMonth(Start, yyMonthOrdinal, yyMonth);
Start += tod;
}
*timePtr = Start;
return 0;
}
tcl8.4.20/generic/tclAlloc.c 0000644 0036047 0045461 00000042262 12052456743 014240 0 ustar dgp 771div /*
* tclAlloc.c --
*
* This is a very fast storage allocator. It allocates blocks of a
* small number of different sizes, and keeps free lists of each size.
* Blocks that don't exactly fit are passed up to the next larger size.
* Blocks over a certain size are directly allocated from the system.
*
* Copyright (c) 1983 Regents of the University of California.
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* Windows and Unix use an alternative allocator when building with threads
* that has significantly reduced lock contention.
*/
#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) || defined(TCL_MEM_DEBUG)
#include "tclInt.h"
#include "tclPort.h"
#if USE_TCLALLOC
/*
* We should really make use of AC_CHECK_TYPE(caddr_t)
* here, but it can wait until Tcl uses config.h properly.
*/
#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__)
typedef unsigned long caddr_t;
#endif
/*
* Alignment for allocated memory.
*/
#if defined(__APPLE__)
#define ALLOCALIGN 16
#else
#define ALLOCALIGN 8
#endif
/*
* The overhead on a block is at least 8 bytes. When free, this space
* contains a pointer to the next free block, and the bottom two bits must
* be zero. When in use, the first byte is set to MAGIC, and the second
* byte is the size index. The remaining bytes are for alignment.
* If range checking is enabled then a second word holds the size of the
* requested block, less 1, rounded up to a multiple of sizeof(RMAGIC).
* The order of elements is critical: ov_magic must overlay the low order
* bits of ov_next, and ov_magic can not be a valid ov_next bit pattern.
*/
union overhead {
union overhead *ov_next; /* when free */
unsigned char ov_padding[ALLOCALIGN];/* align struct to ALLOCALIGN bytes */
struct {
unsigned char ovu_magic0; /* magic number */
unsigned char ovu_index; /* bucket # */
unsigned char ovu_unused; /* unused */
unsigned char ovu_magic1; /* other magic number */
#ifndef NDEBUG
unsigned short ovu_rmagic; /* range magic number */
unsigned long ovu_size; /* actual block size */
unsigned short ovu_unused2; /* padding to 8-byte align */
#endif
} ovu;
#define ov_magic0 ovu.ovu_magic0
#define ov_magic1 ovu.ovu_magic1
#define ov_index ovu.ovu_index
#define ov_rmagic ovu.ovu_rmagic
#define ov_size ovu.ovu_size
};
#define MAGIC 0xef /* magic # on accounting info */
#define RMAGIC 0x5555 /* magic # on range info */
#ifndef NDEBUG
#define RSLOP sizeof (unsigned short)
#else
#define RSLOP 0
#endif
#define OVERHEAD (sizeof(union overhead) + RSLOP)
/*
* nextf[i] is the pointer to the next free block of size 2^(i+3). The
* smallest allocatable block is MINBLOCK bytes. The overhead information
* precedes the data area returned to the user.
*/
#define MINBLOCK ((sizeof(union overhead) + (ALLOCALIGN-1)) & ~(ALLOCALIGN-1))
#define NBUCKETS (13 - (MINBLOCK >> 4))
#define MAXMALLOC (1<<(NBUCKETS+2))
static union overhead *nextf[NBUCKETS];
/*
* The following structure is used to keep track of all system memory
* currently owned by Tcl. When finalizing, all this memory will
* be returned to the system.
*/
struct block {
struct block *nextPtr; /* Linked list. */
struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte
* alignment for suballocated blocks. */
};
static struct block *blockList; /* Tracks the suballocated blocks. */
static struct block bigBlocks = { /* Big blocks aren't suballocated. */
&bigBlocks, &bigBlocks
};
/*
* The allocator is protected by a special mutex that must be
* explicitly initialized. Futhermore, because Tcl_Alloc may be
* used before anything else in Tcl, we make this module self-initializing
* after all with the allocInit variable.
*/
#ifdef TCL_THREADS
static Tcl_Mutex *allocMutexPtr;
#endif
static int allocInit = 0;
#ifdef MSTATS
/*
* nmalloc[i] is the difference between the number of mallocs and frees
* for a given block size.
*/
static unsigned int nmalloc[NBUCKETS+1];
#include
#endif
#if !defined(NDEBUG)
#define ASSERT(p) if (!(p)) panic(# p)
#define RANGE_ASSERT(p) if (!(p)) panic(# p)
#else
#define ASSERT(p)
#define RANGE_ASSERT(p)
#endif
/*
* Prototypes for functions used only in this file.
*/
static void MoreCore _ANSI_ARGS_((int bucket));
/*
*-------------------------------------------------------------------------
*
* TclInitAlloc --
*
* Initialize the memory system.
*
* Results:
* None.
*
* Side effects:
* Initialize the mutex used to serialize allocations.
*
*-------------------------------------------------------------------------
*/
void
TclInitAlloc()
{
if (!allocInit) {
allocInit = 1;
#ifdef TCL_THREADS
allocMutexPtr = Tcl_GetAllocMutex();
#endif
}
}
/*
*-------------------------------------------------------------------------
*
* TclFinalizeAllocSubsystem --
*
* Release all resources being used by this subsystem, including
* aggressively freeing all memory allocated by TclpAlloc() that
* has not yet been released with TclpFree().
*
* After this function is called, all memory allocated with
* TclpAlloc() should be considered unusable.
*
* Results:
* None.
*
* Side effects:
* This subsystem is self-initializing, since memory can be
* allocated before Tcl is formally initialized. After this call,
* this subsystem has been reset to its initial state and is
* usable again.
*
*-------------------------------------------------------------------------
*/
void
TclFinalizeAllocSubsystem()
{
unsigned int i;
struct block *blockPtr, *nextPtr;
Tcl_MutexLock(allocMutexPtr);
for (blockPtr = blockList; blockPtr != NULL; blockPtr = nextPtr) {
nextPtr = blockPtr->nextPtr;
TclpSysFree(blockPtr);
}
blockList = NULL;
for (blockPtr = bigBlocks.nextPtr; blockPtr != &bigBlocks; ) {
nextPtr = blockPtr->nextPtr;
TclpSysFree(blockPtr);
blockPtr = nextPtr;
}
bigBlocks.nextPtr = &bigBlocks;
bigBlocks.prevPtr = &bigBlocks;
for (i = 0; i < NBUCKETS; i++) {
nextf[i] = NULL;
#ifdef MSTATS
nmalloc[i] = 0;
#endif
}
#ifdef MSTATS
nmalloc[i] = 0;
#endif
Tcl_MutexUnlock(allocMutexPtr);
}
/*
*----------------------------------------------------------------------
*
* TclpAlloc --
*
* Allocate more memory.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
TclpAlloc(nbytes)
unsigned int nbytes; /* Number of bytes to allocate. */
{
register union overhead *op;
register long bucket;
register unsigned amt;
struct block *bigBlockPtr = NULL;
if (!allocInit) {
/*
* We have to make the "self initializing" because Tcl_Alloc
* may be used before any other part of Tcl. E.g., see
* main() for tclsh!
*/
TclInitAlloc();
}
Tcl_MutexLock(allocMutexPtr);
/*
* First the simple case: we simple allocate big blocks directly
*/
if (nbytes >= MAXMALLOC - OVERHEAD) {
if (nbytes <= UINT_MAX - OVERHEAD - sizeof(struct block)) {
bigBlockPtr = (struct block *) TclpSysAlloc((unsigned)
(sizeof(struct block) + OVERHEAD + nbytes), 0);
}
if (bigBlockPtr == NULL) {
Tcl_MutexUnlock(allocMutexPtr);
return NULL;
}
bigBlockPtr->nextPtr = bigBlocks.nextPtr;
bigBlocks.nextPtr = bigBlockPtr;
bigBlockPtr->prevPtr = &bigBlocks;
bigBlockPtr->nextPtr->prevPtr = bigBlockPtr;
op = (union overhead *) (bigBlockPtr + 1);
op->ov_magic0 = op->ov_magic1 = MAGIC;
op->ov_index = 0xff;
#ifdef MSTATS
nmalloc[NBUCKETS]++;
#endif
#ifndef NDEBUG
/*
* Record allocated size of block and
* bound space with magic numbers.
*/
op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
op->ov_rmagic = RMAGIC;
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
Tcl_MutexUnlock(allocMutexPtr);
return (void *)(op+1);
}
/*
* Convert amount of memory requested into closest block size
* stored in hash buckets which satisfies request.
* Account for space used per block for accounting.
*/
amt = MINBLOCK; /* size of first bucket */
bucket = MINBLOCK >> 4;
while (nbytes + OVERHEAD > amt) {
amt <<= 1;
if (amt == 0) {
Tcl_MutexUnlock(allocMutexPtr);
return (NULL);
}
bucket++;
}
ASSERT( bucket < NBUCKETS );
/*
* If nothing in hash bucket right now,
* request more memory from the system.
*/
if ((op = nextf[bucket]) == NULL) {
MoreCore(bucket);
if ((op = nextf[bucket]) == NULL) {
Tcl_MutexUnlock(allocMutexPtr);
return (NULL);
}
}
/*
* Remove from linked list
*/
nextf[bucket] = op->ov_next;
op->ov_magic0 = op->ov_magic1 = MAGIC;
op->ov_index = (unsigned char) bucket;
#ifdef MSTATS
nmalloc[bucket]++;
#endif
#ifndef NDEBUG
/*
* Record allocated size of block and
* bound space with magic numbers.
*/
op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
op->ov_rmagic = RMAGIC;
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
Tcl_MutexUnlock(allocMutexPtr);
return ((char *)(op + 1));
}
/*
*----------------------------------------------------------------------
*
* MoreCore --
*
* Allocate more memory to the indicated bucket.
*
* Assumes Mutex is already held.
*
* Results:
* None.
*
* Side effects:
* Attempts to get more memory from the system.
*
*----------------------------------------------------------------------
*/
static void
MoreCore(bucket)
int bucket; /* What bucket to allocat to. */
{
register union overhead *op;
register long sz; /* size of desired block */
long amt; /* amount to allocate */
int nblks; /* how many blocks we get */
struct block *blockPtr;
/*
* sbrk_size <= 0 only for big, FLUFFY, requests (about
* 2^30 bytes on a VAX, I think) or for a negative arg.
*/
sz = 1 << (bucket + 3);
ASSERT(sz > 0);
amt = MAXMALLOC;
nblks = amt / sz;
ASSERT(nblks*sz == amt);
blockPtr = (struct block *) TclpSysAlloc((unsigned)
(sizeof(struct block) + amt), 1);
/* no more room! */
if (blockPtr == NULL) {
return;
}
blockPtr->nextPtr = blockList;
blockList = blockPtr;
op = (union overhead *) (blockPtr + 1);
/*
* Add new memory allocated to that on
* free list for this hash bucket.
*/
nextf[bucket] = op;
while (--nblks > 0) {
op->ov_next = (union overhead *)((caddr_t)op + sz);
op = (union overhead *)((caddr_t)op + sz);
}
op->ov_next = (union overhead *)NULL;
}
/*
*----------------------------------------------------------------------
*
* TclpFree --
*
* Free memory.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclpFree(cp)
char *cp; /* Pointer to memory to free. */
{
register long size;
register union overhead *op;
struct block *bigBlockPtr;
if (cp == NULL) {
return;
}
Tcl_MutexLock(allocMutexPtr);
op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */
ASSERT(op->ov_magic1 == MAGIC);
if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {
Tcl_MutexUnlock(allocMutexPtr);
return;
}
RANGE_ASSERT(op->ov_rmagic == RMAGIC);
RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC);
size = op->ov_index;
if ( size == 0xff ) {
#ifdef MSTATS
nmalloc[NBUCKETS]--;
#endif
bigBlockPtr = (struct block *) op - 1;
bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr;
bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr;
TclpSysFree(bigBlockPtr);
Tcl_MutexUnlock(allocMutexPtr);
return;
}
ASSERT(size < NBUCKETS);
op->ov_next = nextf[size]; /* also clobbers ov_magic */
nextf[size] = op;
#ifdef MSTATS
nmalloc[size]--;
#endif
Tcl_MutexUnlock(allocMutexPtr);
}
/*
*----------------------------------------------------------------------
*
* TclpRealloc --
*
* Reallocate memory.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
TclpRealloc(cp, nbytes)
char *cp; /* Pointer to alloced block. */
unsigned int nbytes; /* New size of memory. */
{
int i;
union overhead *op;
struct block *bigBlockPtr;
int expensive;
unsigned long maxsize;
if (cp == NULL) {
return (TclpAlloc(nbytes));
}
Tcl_MutexLock(allocMutexPtr);
op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */
ASSERT(op->ov_magic1 == MAGIC);
if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {
Tcl_MutexUnlock(allocMutexPtr);
return NULL;
}
RANGE_ASSERT(op->ov_rmagic == RMAGIC);
RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC);
i = op->ov_index;
/*
* If the block isn't in a bin, just realloc it.
*/
if (i == 0xff) {
struct block *prevPtr, *nextPtr;
bigBlockPtr = (struct block *) op - 1;
prevPtr = bigBlockPtr->prevPtr;
nextPtr = bigBlockPtr->nextPtr;
bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr,
sizeof(struct block) + OVERHEAD + nbytes);
if (bigBlockPtr == NULL) {
Tcl_MutexUnlock(allocMutexPtr);
return NULL;
}
if (prevPtr->nextPtr != bigBlockPtr) {
/*
* If the block has moved, splice the new block into the list where
* the old block used to be.
*/
prevPtr->nextPtr = bigBlockPtr;
nextPtr->prevPtr = bigBlockPtr;
}
op = (union overhead *) (bigBlockPtr + 1);
#ifdef MSTATS
nmalloc[NBUCKETS]++;
#endif
#ifndef NDEBUG
/*
* Record allocated size of block and update magic number bounds.
*/
op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
Tcl_MutexUnlock(allocMutexPtr);
return (char *)(op+1);
}
maxsize = 1 << (i+3);
expensive = 0;
if ( nbytes + OVERHEAD > maxsize ) {
expensive = 1;
} else if ( i > 0 && nbytes + OVERHEAD < (maxsize/2) ) {
expensive = 1;
}
if (expensive) {
void *newp;
Tcl_MutexUnlock(allocMutexPtr);
newp = TclpAlloc(nbytes);
if ( newp == NULL ) {
return NULL;
}
maxsize -= OVERHEAD;
if ( maxsize < nbytes )
nbytes = maxsize;
memcpy((VOID *) newp, (VOID *) cp, (size_t) nbytes);
TclpFree(cp);
return newp;
}
/*
* Ok, we don't have to copy, it fits as-is
*/
#ifndef NDEBUG
op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
Tcl_MutexUnlock(allocMutexPtr);
return(cp);
}
/*
*----------------------------------------------------------------------
*
* mstats --
*
* Prints two lines of numbers, one showing the length of the
* free list for each size category, the second showing the
* number of mallocs - frees for each size category.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef MSTATS
void
mstats(s)
char *s; /* Where to write info. */
{
register int i, j;
register union overhead *p;
int totfree = 0,
totused = 0;
Tcl_MutexLock(allocMutexPtr);
fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
for (i = 0; i < NBUCKETS; i++) {
for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
fprintf(stderr, " %d", j);
totfree += j * (1 << (i + 3));
}
fprintf(stderr, "\nused:\t");
for (i = 0; i < NBUCKETS; i++) {
fprintf(stderr, " %d", nmalloc[i]);
totused += nmalloc[i] * (1 << (i + 3));
}
fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n",
totused, totfree);
fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
MAXMALLOC, nmalloc[NBUCKETS]);
Tcl_MutexUnlock(allocMutexPtr);
}
#endif
#else /* !USE_TCLALLOC */
/*
*----------------------------------------------------------------------
*
* TclpAlloc --
*
* Allocate more memory.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
TclpAlloc(nbytes)
unsigned int nbytes; /* Number of bytes to allocate. */
{
return (char*) malloc(nbytes);
}
/*
*----------------------------------------------------------------------
*
* TclpFree --
*
* Free memory.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclpFree(cp)
char *cp; /* Pointer to memory to free. */
{
free(cp);
return;
}
/*
*----------------------------------------------------------------------
*
* TclpRealloc --
*
* Reallocate memory.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
TclpRealloc(cp, nbytes)
char *cp; /* Pointer to alloced block. */
unsigned int nbytes; /* New size of memory. */
{
return (char*) realloc(cp, nbytes);
}
#endif /* !USE_TCLALLOC */
#endif /* !TCL_THREADS */
tcl8.4.20/generic/tclNamesp.c 0000644 0036047 0045461 00000372752 12133546540 014436 0 ustar dgp 771div /*
* tclNamesp.c --
*
* Contains support for namespaces, which provide a separate context of
* commands and global variables. The global :: namespace is the
* traditional Tcl "global" scope. Other namespaces are created as
* children of the global namespace. These other namespaces contain
* special-purpose commands and variables for packages.
*
* Copyright (c) 1993-1997 Lucent Technologies.
* Copyright (c) 1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* Originally implemented by
* Michael J. McLennan
* Bell Labs Innovations for Lucent Technologies
* mmclennan@lucent.com
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* Flag passed to TclGetNamespaceForQualName to indicate that it should
* search for a namespace rather than a command or variable inside a
* namespace. Note that this flag's value must not conflict with the values
* of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, or CREATE_NS_IF_UNKNOWN.
*/
#define FIND_ONLY_NS 0x1000
/*
* Initial size of stack allocated space for tail list - used when resetting
* shadowed command references in the functin: TclResetShadowedCmdRefs.
*/
#define NUM_TRAIL_ELEMS 5
/*
* Count of the number of namespaces created. This value is used as a
* unique id for each namespace.
*/
static long numNsCreated = 0;
TCL_DECLARE_MUTEX(nsMutex)
/*
* This structure contains a cached pointer to a namespace that is the
* result of resolving the namespace's name in some other namespace. It is
* the internal representation for a nsName object. It contains the
* pointer along with some information that is used to check the cached
* pointer's validity.
*/
typedef struct ResolvedNsName {
Namespace *nsPtr; /* A cached namespace pointer. */
long nsId; /* nsPtr's unique namespace id. Used to
* verify that nsPtr is still valid
* (e.g., it's possible that the namespace
* was deleted and a new one created at
* the same address). */
Namespace *refNsPtr; /* Points to the namespace containing the
* reference (not the namespace that
* contains the referenced namespace). */
int refCount; /* Reference count: 1 for each nsName
* object that has a pointer to this
* ResolvedNsName structure as its internal
* rep. This structure can be freed when
* refCount becomes zero. */
} ResolvedNsName;
/*
* Declarations for procedures local to this file:
*/
static void DeleteImportedCmd _ANSI_ARGS_((
ClientData clientData));
static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
Tcl_Obj *copyPtr));
static void FreeNsNameInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
static int GetNamespaceFromObj _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_Namespace **nsPtrPtr));
static int InvokeImportedCmd _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceChildrenCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceCodeCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceCurrentCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceDeleteCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceEvalCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceExistsCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceExportCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceForgetCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static void NamespaceFree _ANSI_ARGS_((Namespace *nsPtr));
static int NamespaceImportCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceInscopeCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceOriginCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceParentCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceQualifiersCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceTailCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceWhichCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int SetNsNameFromAny _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr));
static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr));
/*
* This structure defines a Tcl object type that contains a
* namespace reference. It is used in commands that take the
* name of a namespace as an argument. The namespace reference
* is resolved, and the result in cached in the object.
*/
Tcl_ObjType tclNsNameType = {
"nsName", /* the type's name */
FreeNsNameInternalRep, /* freeIntRepProc */
DupNsNameInternalRep, /* dupIntRepProc */
UpdateStringOfNsName, /* updateStringProc */
SetNsNameFromAny /* setFromAnyProc */
};
/*
*----------------------------------------------------------------------
*
* TclInitNamespaceSubsystem --
*
* This procedure is called to initialize all the structures that
* are used by namespaces on a per-process basis.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclInitNamespaceSubsystem()
{
/*
* Does nothing for now.
*/
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCurrentNamespace --
*
* Returns a pointer to an interpreter's currently active namespace.
*
* Results:
* Returns a pointer to the interpreter's current namespace.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_GetCurrentNamespace(interp)
register Tcl_Interp *interp; /* Interpreter whose current namespace is
* being queried. */
{
register Interp *iPtr = (Interp *) interp;
register Namespace *nsPtr;
if (iPtr->varFramePtr != NULL) {
nsPtr = iPtr->varFramePtr->nsPtr;
} else {
nsPtr = iPtr->globalNsPtr;
}
return (Tcl_Namespace *) nsPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetGlobalNamespace --
*
* Returns a pointer to an interpreter's global :: namespace.
*
* Results:
* Returns a pointer to the specified interpreter's global namespace.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_GetGlobalNamespace(interp)
register Tcl_Interp *interp; /* Interpreter whose global namespace
* should be returned. */
{
register Interp *iPtr = (Interp *) interp;
return (Tcl_Namespace *) iPtr->globalNsPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PushCallFrame --
*
* Pushes a new call frame onto the interpreter's Tcl call stack.
* Called when executing a Tcl procedure or a "namespace eval" or
* "namespace inscope" command.
*
* Results:
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
* message in the interpreter's result object) if something goes wrong.
*
* Side effects:
* Modifies the interpreter's Tcl call stack.
*
*----------------------------------------------------------------------
*/
int
Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame)
Tcl_Interp *interp; /* Interpreter in which the new call frame
* is to be pushed. */
Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to
* push. Storage for this has already been
* allocated by the caller; typically this
* is the address of a CallFrame structure
* allocated on the caller's C stack. The
* call frame will be initialized by this
* procedure. The caller can pop the frame
* later with Tcl_PopCallFrame, and it is
* responsible for freeing the frame's
* storage. */
Tcl_Namespace *namespacePtr; /* Points to the namespace in which the
* frame will execute. If NULL, the
* interpreter's current namespace will
* be used. */
int isProcCallFrame; /* If nonzero, the frame represents a
* called Tcl procedure and may have local
* vars. Vars will ordinarily be looked up
* in the frame. If new variables are
* created, they will be created in the
* frame. If 0, the frame is for a
* "namespace eval" or "namespace inscope"
* command and var references are treated
* as references to namespace variables. */
{
Interp *iPtr = (Interp *) interp;
register CallFrame *framePtr = (CallFrame *) callFramePtr;
register Namespace *nsPtr;
if (namespacePtr == NULL) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
} else {
nsPtr = (Namespace *) namespacePtr;
if (nsPtr->flags & NS_DEAD) {
panic("Trying to push call frame for dead namespace");
/*NOTREACHED*/
}
}
nsPtr->activationCount++;
framePtr->nsPtr = nsPtr;
framePtr->isProcCallFrame = isProcCallFrame;
framePtr->objc = 0;
framePtr->objv = NULL;
framePtr->callerPtr = iPtr->framePtr;
framePtr->callerVarPtr = iPtr->varFramePtr;
if (iPtr->varFramePtr != NULL) {
framePtr->level = (iPtr->varFramePtr->level + 1);
} else {
framePtr->level = 1;
}
framePtr->procPtr = NULL; /* no called procedure */
framePtr->varTablePtr = NULL; /* and no local variables */
framePtr->numCompiledLocals = 0;
framePtr->compiledLocals = NULL;
/*
* Push the new call frame onto the interpreter's stack of procedure
* call frames making it the current frame.
*/
iPtr->framePtr = framePtr;
iPtr->varFramePtr = framePtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PopCallFrame --
*
* Removes a call frame from the Tcl call stack for the interpreter.
* Called to remove a frame previously pushed by Tcl_PushCallFrame.
*
* Results:
* None.
*
* Side effects:
* Modifies the call stack of the interpreter. Resets various fields of
* the popped call frame. If a namespace has been deleted and
* has no more activations on the call stack, the namespace is
* destroyed.
*
*----------------------------------------------------------------------
*/
void
Tcl_PopCallFrame(interp)
Tcl_Interp* interp; /* Interpreter with call frame to pop. */
{
register Interp *iPtr = (Interp *) interp;
register CallFrame *framePtr = iPtr->framePtr;
Namespace *nsPtr;
/*
* It's important to remove the call frame from the interpreter's stack
* of call frames before deleting local variables, so that traces
* invoked by the variable deletion don't see the partially-deleted
* frame.
*/
iPtr->framePtr = framePtr->callerPtr;
iPtr->varFramePtr = framePtr->callerVarPtr;
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
ckfree((char *) framePtr->varTablePtr);
framePtr->varTablePtr = NULL;
}
if (framePtr->numCompiledLocals > 0) {
TclDeleteCompiledLocalVars(iPtr, framePtr);
}
/*
* Decrement the namespace's count of active call frames. If the
* namespace is "dying" and there are no more active call frames,
* call Tcl_DeleteNamespace to destroy it.
*/
nsPtr = framePtr->nsPtr;
nsPtr->activationCount--;
if ((nsPtr->flags & NS_DYING)
&& (nsPtr->activationCount == 0)) {
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateNamespace --
*
* Creates a new namespace with the given name. If there is no
* active namespace (i.e., the interpreter is being initialized),
* the global :: namespace is created and returned.
*
* Results:
* Returns a pointer to the new namespace if successful. If the
* namespace already exists or if another error occurs, this routine
* returns NULL, along with an error message in the interpreter's
* result object.
*
* Side effects:
* If the name contains "::" qualifiers and a parent namespace does
* not already exist, it is automatically created.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_CreateNamespace(interp, name, clientData, deleteProc)
Tcl_Interp *interp; /* Interpreter in which a new namespace
* is being created. Also used for
* error reporting. */
CONST char *name; /* Name for the new namespace. May be a
* qualified name with names of ancestor
* namespaces separated by "::"s. */
ClientData clientData; /* One-word value to store with
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Procedure called to delete client
* data when the namespace is deleted.
* NULL if no procedure should be
* called. */
{
Interp *iPtr = (Interp *) interp;
register Namespace *nsPtr, *ancestorPtr;
Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
CONST char *simpleName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer1, buffer2;
int newEntry;
/*
* If there is no active namespace, the interpreter is being
* initialized.
*/
if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
/*
* Treat this namespace as the global namespace, and avoid
* looking for a parent.
*/
parentPtr = NULL;
simpleName = "";
} else if (*name == '\0') {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't create namespace \"\": only global namespace can have empty name", (char *) NULL);
return NULL;
} else {
/*
* Find the parent for the new namespace.
*/
TclGetNamespaceForQualName(interp, name, NULL, CREATE_NS_IF_UNKNOWN,
&parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
/*
* If the unqualified name at the end is empty, there were trailing
* "::"s after the namespace's name which we ignore. The new
* namespace was already (recursively) created and is pointed to
* by parentPtr.
*/
if (*simpleName == '\0') {
return (Tcl_Namespace *) parentPtr;
}
/*
* Check for a bad namespace name and make sure that the name
* does not already exist in the parent namespace.
*/
if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't create namespace \"", name,
"\": already exists", (char *) NULL);
return NULL;
}
}
/*
* Create the new namespace and root it in its parent. Increment the
* count of namespaces created.
*/
nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1));
strcpy(nsPtr->name, simpleName);
nsPtr->fullName = NULL; /* set below */
nsPtr->clientData = clientData;
nsPtr->deleteProc = deleteProc;
nsPtr->parentPtr = parentPtr;
Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
Tcl_MutexLock(&nsMutex);
numNsCreated++;
nsPtr->nsId = numNsCreated;
Tcl_MutexUnlock(&nsMutex);
nsPtr->interp = interp;
nsPtr->flags = 0;
nsPtr->activationCount = 0;
nsPtr->refCount = 0;
Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
nsPtr->exportArrayPtr = NULL;
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
nsPtr->cmdRefEpoch = 0;
nsPtr->resolverEpoch = 0;
nsPtr->cmdResProc = NULL;
nsPtr->varResProc = NULL;
nsPtr->compiledVarResProc = NULL;
if (parentPtr != NULL) {
entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
&newEntry);
Tcl_SetHashValue(entryPtr, (ClientData) nsPtr);
}
/*
* Build the fully qualified name for this namespace.
*/
Tcl_DStringInit(&buffer1);
Tcl_DStringInit(&buffer2);
for (ancestorPtr = nsPtr; ancestorPtr != NULL;
ancestorPtr = ancestorPtr->parentPtr) {
if (ancestorPtr != globalNsPtr) {
Tcl_DStringAppend(&buffer1, "::", 2);
Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1);
}
Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1);
Tcl_DStringSetLength(&buffer2, 0);
Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1);
Tcl_DStringSetLength(&buffer1, 0);
}
name = Tcl_DStringValue(&buffer2);
nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1));
strcpy(nsPtr->fullName, name);
Tcl_DStringFree(&buffer1);
Tcl_DStringFree(&buffer2);
/*
* Return a pointer to the new namespace.
*/
return (Tcl_Namespace *) nsPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteNamespace --
*
* Deletes a namespace and all of the commands, variables, and other
* namespaces within it.
*
* Results:
* None.
*
* Side effects:
* When a namespace is deleted, it is automatically removed as a
* child of its parent namespace. Also, all its commands, variables
* and child namespaces are deleted.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteNamespace(namespacePtr)
Tcl_Namespace *namespacePtr; /* Points to the namespace to delete. */
{
register Namespace *nsPtr = (Namespace *) namespacePtr;
Interp *iPtr = (Interp *) nsPtr->interp;
Namespace *globalNsPtr =
(Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr);
Tcl_HashEntry *entryPtr;
/*
* If the namespace is on the call frame stack, it is marked as "dying"
* (NS_DYING is OR'd into its flags): the namespace can't be looked up
* by name but its commands and variables are still usable by those
* active call frames. When all active call frames referring to the
* namespace have been popped from the Tcl stack, Tcl_PopCallFrame will
* call this procedure again to delete everything in the namespace.
* If no nsName objects refer to the namespace (i.e., if its refCount
* is zero), its commands and variables are deleted and the storage for
* its namespace structure is freed. Otherwise, if its refCount is
* nonzero, the namespace's commands and variables are deleted but the
* structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
* flags to allow the namespace resolution code to recognize that the
* namespace is "deleted". The structure's storage is freed by
* FreeNsNameInternalRep when its refCount reaches 0.
*/
if (nsPtr->activationCount > 0) {
nsPtr->flags |= NS_DYING;
if (nsPtr->parentPtr != NULL) {
entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
}
}
nsPtr->parentPtr = NULL;
} else if (!(nsPtr->flags & NS_KILLED)) {
/*
* Delete the namespace and everything in it. If this is the global
* namespace, then clear it but don't free its storage unless the
* interpreter is being torn down. Set the NS_KILLED flag to avoid
* recursive calls here - if the namespace is really in the process of
* being deleted, ignore any second call.
*/
nsPtr->flags |= (NS_DYING|NS_KILLED);
TclTeardownNamespace(nsPtr);
if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
/*
* If this is the global namespace, then it may have residual
* "errorInfo" and "errorCode" variables for errors that
* occurred while it was being torn down. Try to clear the
* variable list one last time.
*/
TclDeleteNamespaceVars(nsPtr);
Tcl_DeleteHashTable(&nsPtr->childTable);
Tcl_DeleteHashTable(&nsPtr->cmdTable);
/*
* If the reference count is 0, then discard the namespace.
* Otherwise, mark it as "dead" so that it can't be used.
*/
if (nsPtr->refCount == 0) {
NamespaceFree(nsPtr);
} else {
nsPtr->flags |= NS_DEAD;
}
} else {
/*
* We didn't really kill it, so remove the KILLED marks, so
* it can get killed later, avoiding mem leaks
*/
nsPtr->flags &= ~(NS_DYING|NS_KILLED);
}
}
}
/*
*----------------------------------------------------------------------
*
* TclTeardownNamespace --
*
* Used internally to dismantle and unlink a namespace when it is
* deleted. Divorces the namespace from its parent, and deletes all
* commands, variables, and child namespaces.
*
* This is kept separate from Tcl_DeleteNamespace so that the global
* namespace can be handled specially. Global variables like
* "errorInfo" and "errorCode" need to remain intact while other
* namespaces and commands are torn down, in case any errors occur.
*
* Results:
* None.
*
* Side effects:
* Removes this namespace from its parent's child namespace hashtable.
* Deletes all commands, variables and namespaces in this namespace.
* If this is the global namespace, the "errorInfo" and "errorCode"
* variables are left alone and deleted later.
*
*----------------------------------------------------------------------
*/
void
TclTeardownNamespace(nsPtr)
register Namespace *nsPtr; /* Points to the namespace to be dismantled
* and unlinked from its parent. */
{
Interp *iPtr = (Interp *) nsPtr->interp;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Tcl_Namespace *childNsPtr;
Tcl_Command cmd;
Namespace *globalNsPtr =
(Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr);
int i;
/*
* Start by destroying the namespace's variable table,
* since variables might trigger traces.
*/
if (nsPtr == globalNsPtr) {
/*
* This is the global namespace. Tearing it down will destroy the
* ::errorInfo and ::errorCode variables. We save and restore them
* in case there are any errors in progress, so the error details
* they contain will not be lost. See test namespace-8.5
*/
Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo",
NULL, TCL_GLOBAL_ONLY);
Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode",
NULL, TCL_GLOBAL_ONLY);
if (errorInfo) {
Tcl_IncrRefCount(errorInfo);
}
if (errorCode) {
Tcl_IncrRefCount(errorCode);
}
TclDeleteNamespaceVars(nsPtr);
Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
if (errorInfo) {
Tcl_SetVar2Ex(nsPtr->interp, "errorInfo", NULL,
errorInfo, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(errorInfo);
}
if (errorCode) {
Tcl_SetVar2Ex(nsPtr->interp, "errorCode", NULL,
errorCode, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(errorCode);
}
} else {
/*
* Variable table should be cleared but not freed! TclDeleteVars
* frees it, so we reinitialize it afterwards.
*/
TclDeleteNamespaceVars(nsPtr);
Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
}
/*
* Delete all commands in this namespace. Be careful when traversing the
* hash table: when each command is deleted, it removes itself from the
* command table.
*/
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd);
}
Tcl_DeleteHashTable(&nsPtr->cmdTable);
Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
/*
* Remove the namespace from its parent's child hashtable.
*/
if (nsPtr->parentPtr != NULL) {
entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
}
}
nsPtr->parentPtr = NULL;
/*
* Delete all the child namespaces.
*
* BE CAREFUL: When each child is deleted, it will divorce
* itself from its parent. You can't traverse a hash table
* properly if its elements are being deleted. We use only
* the Tcl_FirstHashEntry function to be safe.
*/
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entryPtr != NULL;
entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
Tcl_DeleteNamespace(childNsPtr);
}
/*
* Free the namespace's export pattern array.
*/
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
ckfree(nsPtr->exportArrayPtr[i]);
}
ckfree((char *) nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = NULL;
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
}
/*
* Free any client data associated with the namespace.
*/
if (nsPtr->deleteProc != NULL) {
(*nsPtr->deleteProc)(nsPtr->clientData);
}
nsPtr->deleteProc = NULL;
nsPtr->clientData = NULL;
/*
* Reset the namespace's id field to ensure that this namespace won't
* be interpreted as valid by, e.g., the cache validation code for
* cached command references in Tcl_GetCommandFromObj.
*/
nsPtr->nsId = 0;
}
/*
*----------------------------------------------------------------------
*
* NamespaceFree --
*
* Called after a namespace has been deleted, when its
* reference count reaches 0. Frees the data structure
* representing the namespace.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
NamespaceFree(nsPtr)
register Namespace *nsPtr; /* Points to the namespace to free. */
{
/*
* Most of the namespace's contents are freed when the namespace is
* deleted by Tcl_DeleteNamespace. All that remains is to free its names
* (for error messages), and the structure itself.
*/
ckfree(nsPtr->name);
ckfree(nsPtr->fullName);
ckfree((char *) nsPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Export --
*
* Makes all the commands matching a pattern available to later be
* imported from the namespace specified by namespacePtr (or the
* current namespace if namespacePtr is NULL). The specified pattern is
* appended onto the namespace's export pattern list, which is
* optionally cleared beforehand.
*
* Results:
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
* message in the interpreter's result) if something goes wrong.
*
* Side effects:
* Appends the export pattern onto the namespace's export list.
* Optionally reset the namespace's export pattern list.
*
*----------------------------------------------------------------------
*/
int
Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Namespace *namespacePtr; /* Points to the namespace from which
* commands are to be exported. NULL for
* the current namespace. */
CONST char *pattern; /* String pattern indicating which commands
* to export. This pattern may not include
* any namespace qualifiers; only commands
* in the specified namespace may be
* exported. */
int resetListFirst; /* If nonzero, resets the namespace's
* export list before appending. */
{
#define INIT_EXPORT_PATTERNS 5
Namespace *nsPtr, *exportNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
CONST char *simplePattern;
char *patternCpy;
int neededElems, len, i;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
nsPtr = (Namespace *) currNsPtr;
} else {
nsPtr = (Namespace *) namespacePtr;
}
/*
* If resetListFirst is true (nonzero), clear the namespace's export
* pattern list.
*/
if (resetListFirst) {
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
ckfree(nsPtr->exportArrayPtr[i]);
}
ckfree((char *) nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = NULL;
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
}
}
/*
* Check that the pattern doesn't have namespace qualifiers.
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid export pattern \"", pattern,
"\": pattern can't specify a namespace",
(char *) NULL);
return TCL_ERROR;
}
/*
* Make sure that we don't already have the pattern in the array
*/
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) {
/*
* The pattern already exists in the list
*/
return TCL_OK;
}
}
}
/*
* Make sure there is room in the namespace's pattern array for the
* new pattern.
*/
neededElems = nsPtr->numExportPatterns + 1;
if (nsPtr->exportArrayPtr == NULL) {
nsPtr->exportArrayPtr = (char **)
ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *)));
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS;
} else if (neededElems > nsPtr->maxExportPatterns) {
int numNewElems = 2 * nsPtr->maxExportPatterns;
size_t currBytes = nsPtr->numExportPatterns * sizeof(char *);
size_t newBytes = numNewElems * sizeof(char *);
char **newPtr = (char **) ckalloc((unsigned) newBytes);
memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr,
currBytes);
ckfree((char *) nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = (char **) newPtr;
nsPtr->maxExportPatterns = numNewElems;
}
/*
* Add the pattern to the namespace's array of export patterns.
*/
len = strlen(pattern);
patternCpy = (char *) ckalloc((unsigned) (len + 1));
strcpy(patternCpy, pattern);
nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
nsPtr->numExportPatterns++;
return TCL_OK;
#undef INIT_EXPORT_PATTERNS
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendExportList --
*
* Appends onto the argument object the list of export patterns for the
* specified namespace.
*
* Results:
* The return value is normally TCL_OK; in this case the object
* referenced by objPtr has each export pattern appended to it. If an
* error occurs, TCL_ERROR is returned and the interpreter's result
* holds an error message.
*
* Side effects:
* If necessary, the object referenced by objPtr is converted into
* a list object.
*
*----------------------------------------------------------------------
*/
int
Tcl_AppendExportList(interp, namespacePtr, objPtr)
Tcl_Interp *interp; /* Interpreter used for error reporting. */
Tcl_Namespace *namespacePtr; /* Points to the namespace whose export
* pattern list is appended onto objPtr.
* NULL for the current namespace. */
Tcl_Obj *objPtr; /* Points to the Tcl object onto which the
* export pattern list is appended. */
{
Namespace *nsPtr;
int i, result;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
} else {
nsPtr = (Namespace *) namespacePtr;
}
/*
* Append the export pattern list onto objPtr.
*/
for (i = 0; i < nsPtr->numExportPatterns; i++) {
result = Tcl_ListObjAppendElement(interp, objPtr,
Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1));
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Import --
*
* Imports all of the commands matching a pattern into the namespace
* specified by namespacePtr (or the current namespace if contextNsPtr
* is NULL). This is done by creating a new command (the "imported
* command") that points to the real command in its original namespace.
*
* If matching commands are on the autoload path but haven't been
* loaded yet, this command forces them to be loaded, then creates
* the links to them.
*
* Results:
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
* message in the interpreter's result) if something goes wrong.
*
* Side effects:
* Creates new commands in the importing namespace. These indirect
* calls back to the real command and are deleted if the real commands
* are deleted.
*
*----------------------------------------------------------------------
*/
int
Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Namespace *namespacePtr; /* Points to the namespace into which the
* commands are to be imported. NULL for
* the current namespace. */
CONST char *pattern; /* String pattern indicating which commands
* to import. This pattern should be
* qualified by the name of the namespace
* from which to import the command(s). */
int allowOverwrite; /* If nonzero, allow existing commands to
* be overwritten by imported commands.
* If 0, return an error if an imported
* cmd conflicts with an existing one. */
{
Interp *iPtr = (Interp *) interp;
Namespace *nsPtr, *importNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
CONST char *simplePattern;
char *cmdName;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Command *cmdPtr;
ImportRef *refPtr;
Tcl_Command autoCmd, importedCmd;
ImportedCmdData *dataPtr;
int wasExported, i, result;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
nsPtr = (Namespace *) currNsPtr;
} else {
nsPtr = (Namespace *) namespacePtr;
}
/*
* First, invoke the "auto_import" command with the pattern
* being imported. This command is part of the Tcl library.
* It looks for imported commands in autoloaded libraries and
* loads them in. That way, they will be found when we try
* to create links below.
*/
autoCmd = Tcl_FindCommand(interp, "auto_import",
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
if (autoCmd != NULL) {
Tcl_Obj *objv[2];
objv[0] = Tcl_NewStringObj("auto_import", -1);
Tcl_IncrRefCount(objv[0]);
objv[1] = Tcl_NewStringObj(pattern, -1);
Tcl_IncrRefCount(objv[1]);
cmdPtr = (Command *) autoCmd;
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
2, objv);
Tcl_DecrRefCount(objv[0]);
Tcl_DecrRefCount(objv[1]);
if (result != TCL_OK) {
return TCL_ERROR;
}
Tcl_ResetResult(interp);
}
/*
* From the pattern, find the namespace from which we are importing
* and get the simple pattern (no namespace qualifiers or ::'s) at
* the end.
*/
if (strlen(pattern) == 0) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"empty import pattern", -1);
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (importNsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown namespace in import pattern \"",
pattern, "\"", (char *) NULL);
return TCL_ERROR;
}
if (importNsPtr == nsPtr) {
if (pattern == simplePattern) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no namespace specified in import pattern \"", pattern,
"\"", (char *) NULL);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"import pattern \"", pattern,
"\" tries to import from namespace \"",
importNsPtr->name, "\" into itself", (char *) NULL);
}
return TCL_ERROR;
}
/*
* Scan through the command table in the source namespace and look for
* exported commands that match the string pattern. Create an "imported
* command" in the current namespace for each imported command; these
* commands redirect their invocations to the "real" command.
*/
for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
(hPtr != NULL);
hPtr = Tcl_NextHashEntry(&search)) {
cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern)) {
/*
* The command cmdName in the source namespace matches the
* pattern. Check whether it was exported. If it wasn't,
* we ignore it.
*/
Tcl_HashEntry *found;
wasExported = 0;
for (i = 0; i < importNsPtr->numExportPatterns; i++) {
if (Tcl_StringMatch(cmdName,
importNsPtr->exportArrayPtr[i])) {
wasExported = 1;
break;
}
}
if (!wasExported) {
continue;
}
/*
* Unless there is a name clash, create an imported command
* in the current namespace that refers to cmdPtr.
*/
found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName);
if ((found == NULL) || allowOverwrite) {
/*
* Create the imported command and its client data.
* To create the new command in the current namespace,
* generate a fully qualified name for it.
*/
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
if (nsPtr != iPtr->globalNsPtr) {
Tcl_DStringAppend(&ds, "::", 2);
}
Tcl_DStringAppend(&ds, cmdName, -1);
/*
* Check whether creating the new imported command in the
* current namespace would create a cycle of imported
* command references.
*/
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
if ((found != NULL)
&& cmdPtr->deleteProc == DeleteImportedCmd) {
Command *overwrite = (Command *) Tcl_GetHashValue(found);
Command *link = cmdPtr;
while (link->deleteProc == DeleteImportedCmd) {
ImportedCmdData *dataPtr;
dataPtr = (ImportedCmdData *) link->objClientData;
link = dataPtr->realCmdPtr;
if (overwrite == link) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"import pattern \"", pattern,
"\" would create a loop containing ",
"command \"", Tcl_DStringValue(&ds),
"\"", (char *) NULL);
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
}
}
dataPtr = (ImportedCmdData *)
ckalloc(sizeof(ImportedCmdData));
importedCmd = Tcl_CreateObjCommand(interp,
Tcl_DStringValue(&ds), InvokeImportedCmd,
(ClientData) dataPtr, DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
dataPtr->selfPtr = (Command *) importedCmd;
dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
Tcl_DStringFree(&ds);
/*
* Create an ImportRef structure describing this new import
* command and add it to the import ref list in the "real"
* command.
*/
refPtr = (ImportRef *) ckalloc(sizeof(ImportRef));
refPtr->importedCmdPtr = (Command *) importedCmd;
refPtr->nextPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = refPtr;
} else {
Command *overwrite = (Command *) Tcl_GetHashValue(found);
if (overwrite->deleteProc == DeleteImportedCmd) {
ImportedCmdData *dataPtr =
(ImportedCmdData *) overwrite->objClientData;
if (dataPtr->realCmdPtr
== (Command *) Tcl_GetHashValue(hPtr)) {
/* Repeated import of same command -- acceptable */
return TCL_OK;
}
}
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't import command \"", cmdName,
"\": already exists", (char *) NULL);
return TCL_ERROR;
}
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ForgetImport --
*
* Deletes commands previously imported into the namespace indicated. The
* by namespacePtr, or the current namespace of interp, when
* namespacePtr is NULL. The pattern controls which imported commands
* are deleted. A simple pattern, one without namespace separators,
* matches the current command names of imported commands in the
* namespace. Matching imported commands are deleted. A qualified
* pattern is interpreted as deletion selection on the basis of where
* the command is imported from. The original command and "first link"
* command for each imported command are determined, and they are matched
* against the pattern. A match leads to deletion of the imported
* command.
*
* Results:
* Returns TCL_ERROR and records an error message in the interp
* result if a namespace qualified pattern refers to a namespace
* that does not exist. Otherwise, returns TCL_OK.
*
* Side effects:
* May delete commands.
*
*----------------------------------------------------------------------
*/
int
Tcl_ForgetImport(interp, namespacePtr, pattern)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Namespace *namespacePtr; /* Points to the namespace from which
* previously imported commands should be
* removed. NULL for current namespace. */
CONST char *pattern; /* String pattern indicating which imported
* commands to remove. */
{
Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
CONST char *simplePattern;
char *cmdName;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
} else {
nsPtr = (Namespace *) namespacePtr;
}
/*
* Parse the pattern into its namespace-qualification (if any)
* and the simple pattern.
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (sourceNsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown namespace in namespace forget pattern \"",
pattern, "\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(pattern, simplePattern) == 0) {
/*
* The pattern is simple.
* Delete any imported commands that match it.
*/
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
(hPtr != NULL);
hPtr = Tcl_NextHashEntry(&search)) {
Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
if (cmdPtr->deleteProc != DeleteImportedCmd) {
continue;
}
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
}
}
return TCL_OK;
}
/* The pattern was namespace-qualified */
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
hPtr = Tcl_NextHashEntry(&search)) {
Tcl_CmdInfo info;
Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr);
Tcl_Command origin = TclGetOriginalCommand(token);
if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
continue; /* Not an imported command */
}
if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
/*
* Original not in namespace we're matching.
* Check the first link in the import chain.
*/
Command *cmdPtr = (Command *) token;
ImportedCmdData *dataPtr =
(ImportedCmdData *) cmdPtr->objClientData;
Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
if (firstToken == origin) {
continue;
}
Tcl_GetCommandInfoFromToken(firstToken, &info);
if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
continue;
}
origin = firstToken;
}
if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) {
Tcl_DeleteCommandFromToken(interp, token);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclGetOriginalCommand --
*
* An imported command is created in an namespace when a "real" command
* is imported from another namespace. If the specified command is an
* imported command, this procedure returns the original command it
* refers to.
*
* Results:
* If the command was imported into a sequence of namespaces a, b,...,n
* where each successive namespace just imports the command from the
* previous namespace, this procedure returns the Tcl_Command token in
* the first namespace, a. Otherwise, if the specified command is not
* an imported command, the procedure returns NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Command
TclGetOriginalCommand(command)
Tcl_Command command; /* The imported command for which the
* original command should be returned. */
{
register Command *cmdPtr = (Command *) command;
ImportedCmdData *dataPtr;
if (cmdPtr->deleteProc != DeleteImportedCmd) {
return (Tcl_Command) NULL;
}
while (cmdPtr->deleteProc == DeleteImportedCmd) {
dataPtr = (ImportedCmdData *) cmdPtr->objClientData;
cmdPtr = dataPtr->realCmdPtr;
}
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
*
* InvokeImportedCmd --
*
* Invoked by Tcl whenever the user calls an imported command that
* was created by Tcl_Import. Finds the "real" command (in another
* namespace), and passes control to it.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result object is set to an error message.
*
*----------------------------------------------------------------------
*/
static int
InvokeImportedCmd(clientData, interp, objc, objv)
ClientData clientData; /* Points to the imported command's
* ImportedCmdData structure. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
register Command *realCmdPtr = dataPtr->realCmdPtr;
return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp,
objc, objv);
}
/*
*----------------------------------------------------------------------
*
* DeleteImportedCmd --
*
* Invoked by Tcl whenever an imported command is deleted. The "real"
* command keeps a list of all the imported commands that refer to it,
* so those imported commands can be deleted when the real command is
* deleted. This procedure removes the imported command reference from
* the real command's list, and frees up the memory associated with
* the imported command.
*
* Results:
* None.
*
* Side effects:
* Removes the imported command from the real command's import list.
*
*----------------------------------------------------------------------
*/
static void
DeleteImportedCmd(clientData)
ClientData clientData; /* Points to the imported command's
* ImportedCmdData structure. */
{
ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
Command *selfPtr = dataPtr->selfPtr;
register ImportRef *refPtr, *prevPtr;
prevPtr = NULL;
for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL;
refPtr = refPtr->nextPtr) {
if (refPtr->importedCmdPtr == selfPtr) {
/*
* Remove *refPtr from real command's list of imported commands
* that refer to it.
*/
if (prevPtr == NULL) { /* refPtr is first in list */
realCmdPtr->importRefPtr = refPtr->nextPtr;
} else {
prevPtr->nextPtr = refPtr->nextPtr;
}
ckfree((char *) refPtr);
ckfree((char *) dataPtr);
return;
}
prevPtr = refPtr;
}
panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
}
/*
*----------------------------------------------------------------------
*
* TclGetNamespaceForQualName --
*
* Given a qualified name specifying a command, variable, or namespace,
* and a namespace in which to resolve the name, this procedure returns
* a pointer to the namespace that contains the item. A qualified name
* consists of the "simple" name of an item qualified by the names of
* an arbitrary number of containing namespace separated by "::"s. If
* the qualified name starts with "::", it is interpreted absolutely
* from the global namespace. Otherwise, it is interpreted relative to
* the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr
* is NULL, the name is interpreted relative to the current namespace.
*
* A relative name like "foo::bar::x" can be found starting in either
* the current namespace or in the global namespace. So each search
* usually follows two tracks, and two possible namespaces are
* returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to
* NULL, then that path failed.
*
* If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is
* sought only in the global :: namespace. The alternate search
* (also) starting from the global namespace is ignored and
* *altNsPtrPtr is set NULL.
*
* If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified
* name is sought only in the namespace specified by cxtNsPtr. The
* alternate search starting from the global namespace is ignored and
* *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and
* TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and
* the search starts from the namespace specified by cxtNsPtr.
*
* If "flags" contains CREATE_NS_IF_UNKNOWN, all namespace
* components of the qualified name that cannot be found are
* automatically created within their specified parent. This makes sure
* that functions like Tcl_CreateCommand always succeed. There is no
* alternate search path, so *altNsPtrPtr is set NULL.
*
* If "flags" contains FIND_ONLY_NS, the qualified name is treated as a
* reference to a namespace, and the entire qualified name is
* followed. If the name is relative, the namespace is looked up only
* in the current namespace. A pointer to the namespace is stored in
* *nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if
* FIND_ONLY_NS is not specified, only the leading components are
* treated as namespace names, and a pointer to the simple name of the
* final component is stored in *simpleNamePtr.
*
* Results:
* It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible
* namespaces which represent the last (containing) namespace in the
* qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr
* to NULL, then the search along that path failed. The procedure also
* stores a pointer to the simple name of the final component in
* *simpleNamePtr. If the qualified name is "::" or was treated as a
* namespace reference (FIND_ONLY_NS), the procedure stores a pointer
* to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets
* *simpleNamePtr to point to an empty string.
*
* If there is an error, this procedure returns TCL_ERROR. If "flags"
* contains TCL_LEAVE_ERR_MSG, an error message is returned in the
* interpreter's result object. Otherwise, the interpreter's result
* object is left unchanged.
*
* *actualCxtPtrPtr is set to the actual context namespace. It is
* set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr
* is NULL, it is set to the current namespace context.
*
* For backwards compatibility with the TclPro byte code loader,
* this function always returns TCL_OK.
*
* Side effects:
* If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be
* created.
*
*----------------------------------------------------------------------
*/
int
TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr)
Tcl_Interp *interp; /* Interpreter in which to find the
* namespace containing qualName. */
CONST char *qualName; /* A namespace-qualified name of an
* command, variable, or namespace. */
Namespace *cxtNsPtr; /* The namespace in which to start the
* search for qualName's namespace. If NULL
* start from the current namespace.
* Ignored if TCL_GLOBAL_ONLY is set. */
int flags; /* Flags controlling the search: an OR'd
* combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY,
* CREATE_NS_IF_UNKNOWN, and
* FIND_ONLY_NS. */
Namespace **nsPtrPtr; /* Address where procedure stores a pointer
* to containing namespace if qualName is
* found starting from *cxtNsPtr or, if
* TCL_GLOBAL_ONLY is set, if qualName is
* found in the global :: namespace. NULL
* is stored otherwise. */
Namespace **altNsPtrPtr; /* Address where procedure stores a pointer
* to containing namespace if qualName is
* found starting from the global ::
* namespace. NULL is stored if qualName
* isn't found starting from :: or if the
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* CREATE_NS_IF_UNKNOWN, FIND_ONLY_NS flag
* is set. */
Namespace **actualCxtPtrPtr; /* Address where procedure stores a pointer
* to the actual namespace from which the
* search started. This is either cxtNsPtr,
* the :: namespace if TCL_GLOBAL_ONLY was
* specified, or the current namespace if
* cxtNsPtr was NULL. */
CONST char **simpleNamePtr; /* Address where procedure stores the
* simple name at end of the qualName, or
* NULL if qualName is "::" or the flag
* FIND_ONLY_NS was specified. */
{
Interp *iPtr = (Interp *) interp;
Namespace *nsPtr = cxtNsPtr;
Namespace *altNsPtr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
CONST char *start, *end;
CONST char *nsName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer;
int len;
/*
* Determine the context namespace nsPtr in which to start the primary
* search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY
* was specified, search from the global namespace. Otherwise, use the
* namespace given in cxtNsPtr, or if that is NULL, use the current
* namespace context. Note that we always treat two or more
* adjacent ":"s as a namespace separator.
*/
if (flags & TCL_GLOBAL_ONLY) {
nsPtr = globalNsPtr;
} else if (nsPtr == NULL) {
if (iPtr->varFramePtr != NULL) {
nsPtr = iPtr->varFramePtr->nsPtr;
} else {
nsPtr = iPtr->globalNsPtr;
}
}
start = qualName; /* pts to start of qualifying namespace */
if ((*qualName == ':') && (*(qualName+1) == ':')) {
start = qualName+2; /* skip over the initial :: */
while (*start == ':') {
start++; /* skip over a subsequent : */
}
nsPtr = globalNsPtr;
if (*start == '\0') { /* qualName is just two or more ":"s */
*nsPtrPtr = globalNsPtr;
*altNsPtrPtr = NULL;
*actualCxtPtrPtr = globalNsPtr;
*simpleNamePtr = start; /* points to empty string */
return TCL_OK;
}
}
*actualCxtPtrPtr = nsPtr;
/*
* Start an alternate search path starting with the global namespace.
* However, if the starting context is the global namespace, or if the
* flag is set to search only the namespace *cxtNsPtr, ignore the
* alternate search path.
*/
altNsPtr = globalNsPtr;
if ((nsPtr == globalNsPtr)
|| (flags & (TCL_NAMESPACE_ONLY | FIND_ONLY_NS))) {
altNsPtr = NULL;
}
/*
* Loop to resolve each namespace qualifier in qualName.
*/
Tcl_DStringInit(&buffer);
end = start;
while (*start != '\0') {
/*
* Find the next namespace qualifier (i.e., a name ending in "::")
* or the end of the qualified name (i.e., a name ending in "\0").
* Set len to the number of characters, starting from start,
* in the name; set end to point after the "::"s or at the "\0".
*/
len = 0;
for (end = start; *end != '\0'; end++) {
if ((*end == ':') && (*(end+1) == ':')) {
end += 2; /* skip over the initial :: */
while (*end == ':') {
end++; /* skip over the subsequent : */
}
break; /* exit for loop; end is after ::'s */
}
len++;
}
if ((*end == '\0')
&& !((end-start >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) {
/*
* qualName ended with a simple name at start. If FIND_ONLY_NS
* was specified, look this up as a namespace. Otherwise,
* start is the name of a cmd or var and we are done.
*/
if (flags & FIND_ONLY_NS) {
nsName = start;
} else {
*nsPtrPtr = nsPtr;
*altNsPtrPtr = altNsPtr;
*simpleNamePtr = start;
Tcl_DStringFree(&buffer);
return TCL_OK;
}
} else {
/*
* start points to the beginning of a namespace qualifier ending
* in "::". end points to the start of a name in that namespace
* that might be empty. Copy the namespace qualifier to a
* buffer so it can be null terminated. We can't modify the
* incoming qualName since it may be a string constant.
*/
Tcl_DStringSetLength(&buffer, 0);
Tcl_DStringAppend(&buffer, start, len);
nsName = Tcl_DStringValue(&buffer);
}
/*
* Look up the namespace qualifier nsName in the current namespace
* context. If it isn't found but CREATE_NS_IF_UNKNOWN is set,
* create that qualifying namespace. This is needed for procedures
* like Tcl_CreateCommand that cannot fail.
*/
if (nsPtr != NULL) {
entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName);
if (entryPtr != NULL) {
nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
} else if (flags & CREATE_NS_IF_UNKNOWN) {
Tcl_CallFrame frame;
(void) Tcl_PushCallFrame(interp, &frame,
(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
(ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
Tcl_PopCallFrame(interp);
if (nsPtr == NULL) {
panic("Could not create namespace '%s'", nsName);
}
} else { /* namespace not found and wasn't created */
nsPtr = NULL;
}
}
/*
* Look up the namespace qualifier in the alternate search path too.
*/
if (altNsPtr != NULL) {
entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName);
if (entryPtr != NULL) {
altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
} else {
altNsPtr = NULL;
}
}
/*
* If both search paths have failed, return NULL results.
*/
if ((nsPtr == NULL) && (altNsPtr == NULL)) {
*nsPtrPtr = NULL;
*altNsPtrPtr = NULL;
*simpleNamePtr = NULL;
Tcl_DStringFree(&buffer);
return TCL_OK;
}
start = end;
}
/*
* We ignore trailing "::"s in a namespace name, but in a command or
* variable name, trailing "::"s refer to the cmd or var named {}.
*/
if ((flags & FIND_ONLY_NS)
|| ((end > start ) && (*(end-1) != ':'))) {
*simpleNamePtr = NULL; /* found namespace name */
} else {
*simpleNamePtr = end; /* found cmd/var: points to empty string */
}
/*
* As a special case, if we are looking for a namespace and qualName
* is "" and the current active namespace (nsPtr) is not the global
* namespace, return NULL (no namespace was found). This is because
* namespaces can not have empty names except for the global namespace.
*/
if ((flags & FIND_ONLY_NS) && (*qualName == '\0')
&& (nsPtr != globalNsPtr)) {
nsPtr = NULL;
}
*nsPtrPtr = nsPtr;
*altNsPtrPtr = altNsPtr;
Tcl_DStringFree(&buffer);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindNamespace --
*
* Searches for a namespace.
*
* Results:
* Returns a pointer to the namespace if it is found. Otherwise,
* returns NULL and leaves an error message in the interpreter's
* result object if "flags" contains TCL_LEAVE_ERR_MSG.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_FindNamespace(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* namespace. */
CONST char *name; /* Namespace name. If it starts with "::",
* will be looked up in global namespace.
* Else, looked up first in contextNsPtr
* (current namespace if contextNsPtr is
* NULL), then in global namespace. */
Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set
* or if the name starts with "::".
* Otherwise, points to namespace in which
* to resolve name; if NULL, look up name
* in the current namespace. */
register int flags; /* Flags controlling namespace lookup: an
* OR'd combination of TCL_GLOBAL_ONLY and
* TCL_LEAVE_ERR_MSG flags. */
{
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
CONST char *dummy;
/*
* Find the namespace(s) that contain the specified namespace name.
* Add the FIND_ONLY_NS flag to resolve the name all the way down
* to its last component, a namespace.
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
(flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
if (nsPtr != NULL) {
return (Tcl_Namespace *) nsPtr;
} else if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown namespace \"", name, "\"", (char *) NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindCommand --
*
* Searches for a command.
*
* Results:
* Returns a token for the command if it is found. Otherwise, if it
* can't be found or there is an error, returns NULL and leaves an
* error message in the interpreter's result object if "flags"
* contains TCL_LEAVE_ERR_MSG.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_FindCommand(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* command and to report errors. */
CONST char *name; /* Command's name. If it starts with "::",
* will be looked up in global namespace.
* Else, looked up first in contextNsPtr
* (current namespace if contextNsPtr is
* NULL), then in global namespace. */
Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set.
* Otherwise, points to namespace in which
* to resolve name. If NULL, look up name
* in the current namespace. */
int flags; /* An OR'd combination of flags:
* TCL_GLOBAL_ONLY (look up name only in
* global namespace), TCL_NAMESPACE_ONLY
* (look up only in contextNsPtr, or the
* current namespace if contextNsPtr is
* NULL), and TCL_LEAVE_ERR_MSG. If both
* TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY
* are given, TCL_GLOBAL_ONLY is
* ignored. */
{
Interp *iPtr = (Interp*)interp;
ResolverScheme *resPtr;
Namespace *nsPtr[2], *cxtNsPtr;
CONST char *simpleName;
register Tcl_HashEntry *entryPtr;
register Command *cmdPtr;
register int search;
int result;
Tcl_Command cmd;
/*
* If this namespace has a command resolver, then give it first
* crack at the command resolution. If the interpreter has any
* command resolvers, consult them next. The command resolver
* procedures may return a Tcl_Command value, they may signal
* to continue onward, or they may signal an error.
*/
if ((flags & TCL_GLOBAL_ONLY) != 0) {
cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
}
else if (contextNsPtr != NULL) {
cxtNsPtr = (Namespace *) contextNsPtr;
}
else {
cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
}
if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) {
resPtr = iPtr->resolverPtr;
if (cxtNsPtr->cmdResProc) {
result = (*cxtNsPtr->cmdResProc)(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
} else {
result = TCL_CONTINUE;
}
while (result == TCL_CONTINUE && resPtr) {
if (resPtr->cmdResProc) {
result = (*resPtr->cmdResProc)(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
}
resPtr = resPtr->nextPtr;
}
if (result == TCL_OK) {
return cmd;
}
else if (result != TCL_CONTINUE) {
return (Tcl_Command) NULL;
}
}
/*
* Find the namespace(s) that contain the command.
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
* Look for the command in the command table of its namespace.
* Be sure to check both possible search paths: from the specified
* namespace context and from the global namespace.
*/
cmdPtr = NULL;
for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
}
}
}
if (cmdPtr != NULL) {
return (Tcl_Command) cmdPtr;
} else if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown command \"", name, "\"", (char *) NULL);
}
return (Tcl_Command) NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindNamespaceVar --
*
* Searches for a namespace variable, a variable not local to a
* procedure. The variable can be either a scalar or an array, but
* may not be an element of an array.
*
* Results:
* Returns a token for the variable if it is found. Otherwise, if it
* can't be found or there is an error, returns NULL and leaves an
* error message in the interpreter's result object if "flags"
* contains TCL_LEAVE_ERR_MSG.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Var
Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* variable. */
CONST char *name; /* Variable's name. If it starts with "::",
* will be looked up in global namespace.
* Else, looked up first in contextNsPtr
* (current namespace if contextNsPtr is
* NULL), then in global namespace. */
Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set.
* Otherwise, points to namespace in which
* to resolve name. If NULL, look up name
* in the current namespace. */
int flags; /* An OR'd combination of flags:
* TCL_GLOBAL_ONLY (look up name only in
* global namespace), TCL_NAMESPACE_ONLY
* (look up only in contextNsPtr, or the
* current namespace if contextNsPtr is
* NULL), and TCL_LEAVE_ERR_MSG. If both
* TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY
* are given, TCL_GLOBAL_ONLY is
* ignored. */
{
Interp *iPtr = (Interp*)interp;
ResolverScheme *resPtr;
Namespace *nsPtr[2], *cxtNsPtr;
CONST char *simpleName;
Tcl_HashEntry *entryPtr;
Var *varPtr;
register int search;
int result;
Tcl_Var var;
/*
* If this namespace has a variable resolver, then give it first
* crack at the variable resolution. It may return a Tcl_Var
* value, it may signal to continue onward, or it may signal
* an error.
*/
if ((flags & TCL_GLOBAL_ONLY) != 0) {
cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
}
else if (contextNsPtr != NULL) {
cxtNsPtr = (Namespace *) contextNsPtr;
}
else {
cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
}
if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
resPtr = iPtr->resolverPtr;
if (cxtNsPtr->varResProc) {
result = (*cxtNsPtr->varResProc)(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
} else {
result = TCL_CONTINUE;
}
while (result == TCL_CONTINUE && resPtr) {
if (resPtr->varResProc) {
result = (*resPtr->varResProc)(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
}
resPtr = resPtr->nextPtr;
}
if (result == TCL_OK) {
return var;
}
else if (result != TCL_CONTINUE) {
return (Tcl_Var) NULL;
}
}
/*
* Find the namespace(s) that contain the variable.
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
* Look for the variable in the variable table of its namespace.
* Be sure to check both possible search paths: from the specified
* namespace context and from the global namespace.
*/
varPtr = NULL;
for (search = 0; (search < 2) && (varPtr == NULL); search++) {
if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable,
simpleName);
if (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
}
}
}
if (varPtr != NULL) {
return (Tcl_Var) varPtr;
} else if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown variable \"", name, "\"", (char *) NULL);
}
return (Tcl_Var) NULL;
}
/*
*----------------------------------------------------------------------
*
* TclResetShadowedCmdRefs --
*
* Called when a command is added to a namespace to check for existing
* command references that the new command may invalidate. Consider the
* following cases that could happen when you add a command "foo" to a
* namespace "b":
* 1. It could shadow a command named "foo" at the global scope.
* If it does, all command references in the namespace "b" are
* suspect.
* 2. Suppose the namespace "b" resides in a namespace "a".
* Then to "a" the new command "b::foo" could shadow another
* command "b::foo" in the global namespace. If so, then all
* command references in "a" are suspect.
* The same checks are applied to all parent namespaces, until we
* reach the global :: namespace.
*
* Results:
* None.
*
* Side effects:
* If the new command shadows an existing command, the cmdRefEpoch
* counter is incremented in each namespace that sees the shadow.
* This invalidates all command references that were previously cached
* in that namespace. The next time the commands are used, they are
* resolved from scratch.
*
*----------------------------------------------------------------------
*/
void
TclResetShadowedCmdRefs(interp, newCmdPtr)
Tcl_Interp *interp; /* Interpreter containing the new command. */
Command *newCmdPtr; /* Points to the new command. */
{
char *cmdName;
Tcl_HashEntry *hPtr;
register Namespace *nsPtr;
Namespace *trailNsPtr, *shadowNsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
int found, i;
/*
* This procedure generates an array used to hold the trail list. This
* starts out with stack-allocated space but uses dynamically-allocated
* storage if needed.
*/
Namespace *(trailStorage[NUM_TRAIL_ELEMS]);
Namespace **trailPtr = trailStorage;
int trailFront = -1;
int trailSize = NUM_TRAIL_ELEMS;
/*
* Start at the namespace containing the new command, and work up
* through the list of parents. Stop just before the global namespace,
* since the global namespace can't "shadow" its own entries.
*
* The namespace "trail" list we build consists of the names of each
* namespace that encloses the new command, in order from outermost to
* innermost: for example, "a" then "b". Each iteration of this loop
* eventually extends the trail upwards by one namespace, nsPtr. We use
* this trail list to see if nsPtr (e.g. "a" in 2. above) could have
* now-invalid cached command references. This will happen if nsPtr
* (e.g. "a") contains a sequence of child namespaces (e.g. "b")
* such that there is a identically-named sequence of child namespaces
* starting from :: (e.g. "::b") whose tail namespace contains a command
* also named cmdName.
*/
cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
for (nsPtr = newCmdPtr->nsPtr;
(nsPtr != NULL) && (nsPtr != globalNsPtr);
nsPtr = nsPtr->parentPtr) {
/*
* Find the maximal sequence of child namespaces contained in nsPtr
* such that there is a identically-named sequence of child
* namespaces starting from ::. shadowNsPtr will be the tail of this
* sequence, or the deepest namespace under :: that might contain a
* command now shadowed by cmdName. We check below if shadowNsPtr
* actually contains a command cmdName.
*/
found = 1;
shadowNsPtr = globalNsPtr;
for (i = trailFront; i >= 0; i--) {
trailNsPtr = trailPtr[i];
hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
trailNsPtr->name);
if (hPtr != NULL) {
shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr);
} else {
found = 0;
break;
}
}
/*
* If shadowNsPtr contains a command named cmdName, we invalidate
* all of the command refs cached in nsPtr. As a boundary case,
* shadowNsPtr is initially :: and we check for case 1. above.
*/
if (found) {
hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
if (hPtr != NULL) {
nsPtr->cmdRefEpoch++;
/*
* If the shadowed command was compiled to bytecodes, we
* invalidate all the bytecodes in nsPtr, to force a new
* compilation. We use the resolverEpoch to signal the need
* for a fresh compilation of every bytecode.
*/
if ((((Command *) Tcl_GetHashValue(hPtr))->compileProc) != NULL) {
nsPtr->resolverEpoch++;
}
}
}
/*
* Insert nsPtr at the front of the trail list: i.e., at the end
* of the trailPtr array.
*/
trailFront++;
if (trailFront == trailSize) {
size_t currBytes = trailSize * sizeof(Namespace *);
int newSize = 2*trailSize;
size_t newBytes = newSize * sizeof(Namespace *);
Namespace **newPtr =
(Namespace **) ckalloc((unsigned) newBytes);
memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes);
if (trailPtr != trailStorage) {
ckfree((char *) trailPtr);
}
trailPtr = newPtr;
trailSize = newSize;
}
trailPtr[trailFront] = nsPtr;
}
/*
* Free any allocated storage.
*/
if (trailPtr != trailStorage) {
ckfree((char *) trailPtr);
}
}
/*
*----------------------------------------------------------------------
*
* GetNamespaceFromObj --
*
* Gets the namespace specified by the name in a Tcl_Obj.
*
* Results:
* Returns TCL_OK if the namespace was resolved successfully, and
* stores a pointer to the namespace in the location specified by
* nsPtrPtr. If the namespace can't be found, the procedure stores
* NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong,
* this procedure returns TCL_ERROR.
*
* Side effects:
* May update the internal representation for the object, caching the
* namespace reference. The next time this procedure is called, the
* namespace value can be found quickly.
*
* If anything goes wrong, an error message is left in the
* interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
GetNamespaceFromObj(interp, objPtr, nsPtrPtr)
Tcl_Interp *interp; /* The current interpreter. */
Tcl_Obj *objPtr; /* The object to be resolved as the name
* of a namespace. */
Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */
{
Interp *iPtr = (Interp *) interp;
register ResolvedNsName *resNamePtr;
register Namespace *nsPtr;
Namespace *currNsPtr;
CallFrame *savedFramePtr;
int result = TCL_OK;
char *name;
/*
* If the namespace name is fully qualified, do as if the lookup were
* done from the global namespace; this helps avoid repeated lookups
* of fully qualified names.
*/
savedFramePtr = iPtr->varFramePtr;
name = Tcl_GetString(objPtr);
if ((*name++ == ':') && (*name == ':')) {
iPtr->varFramePtr = NULL;
}
currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
/*
* Get the internal representation, converting to a namespace type if
* needed. The internal representation is a ResolvedNsName that points
* to the actual namespace.
*/
if (objPtr->typePtr != &tclNsNameType) {
result = tclNsNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
goto done;
}
}
resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
/*
* Check the context namespace of the resolved symbol to make sure that
* it is fresh. If not, then force another conversion to the namespace
* type, to discard the old rep and create a new one. Note that we
* verify that the namespace id of the cached namespace is the same as
* the id when we cached it; this insures that the namespace wasn't
* deleted and a new one created at the same address.
*/
nsPtr = NULL;
if ((resNamePtr != NULL)
&& (resNamePtr->refNsPtr == currNsPtr)
&& (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) {
nsPtr = resNamePtr->nsPtr;
if (nsPtr->flags & NS_DEAD) {
nsPtr = NULL;
}
}
if (nsPtr == NULL) { /* try again */
result = tclNsNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
goto done;
}
resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
if (resNamePtr != NULL) {
nsPtr = resNamePtr->nsPtr;
if (nsPtr->flags & NS_DEAD) {
nsPtr = NULL;
}
}
}
*nsPtrPtr = (Tcl_Namespace *) nsPtr;
done:
iPtr->varFramePtr = savedFramePtr;
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_NamespaceObjCmd --
*
* Invoked to implement the "namespace" command that creates, deletes,
* or manipulates Tcl namespaces. Handles the following syntax:
*
* namespace children ?name? ?pattern?
* namespace code arg
* namespace current
* namespace delete ?name name...?
* namespace eval name arg ?arg...?
* namespace exists name
* namespace export ?-clear? ?pattern pattern...?
* namespace forget ?pattern pattern...?
* namespace import ?-force? ?pattern pattern...?
* namespace inscope name arg ?arg...?
* namespace origin name
* namespace parent ?name?
* namespace qualifiers string
* namespace tail string
* namespace which ?-command? ?-variable? name
*
* Results:
* Returns TCL_OK if the command is successful. Returns TCL_ERROR if
* anything goes wrong.
*
* Side effects:
* Based on the subcommand name (e.g., "import"), this procedure
* dispatches to a corresponding procedure NamespaceXXXCmd defined
* statically in this file. This procedure's side effects depend on
* whatever that subcommand procedure does. If there is an error, this
* procedure returns an error message in the interpreter's result
* object. Otherwise it may return a result in the interpreter's result
* object.
*
*----------------------------------------------------------------------
*/
int
Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Arbitrary value passed to cmd. */
Tcl_Interp *interp; /* Current interpreter. */
register int objc; /* Number of arguments. */
register Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *subCmds[] = {
"children", "code", "current", "delete",
"eval", "exists", "export", "forget", "import",
"inscope", "origin", "parent", "qualifiers",
"tail", "which", (char *) NULL
};
enum NSSubCmdIdx {
NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx,
NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
NSTailIdx, NSWhichIdx
};
int index, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
return TCL_ERROR;
}
/*
* Return an index reflecting the particular subcommand.
*/
result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds,
"option", /*flags*/ 0, (int *) &index);
if (result != TCL_OK) {
return result;
}
switch (index) {
case NSChildrenIdx:
result = NamespaceChildrenCmd(clientData, interp, objc, objv);
break;
case NSCodeIdx:
result = NamespaceCodeCmd(clientData, interp, objc, objv);
break;
case NSCurrentIdx:
result = NamespaceCurrentCmd(clientData, interp, objc, objv);
break;
case NSDeleteIdx:
result = NamespaceDeleteCmd(clientData, interp, objc, objv);
break;
case NSEvalIdx:
result = NamespaceEvalCmd(clientData, interp, objc, objv);
break;
case NSExistsIdx:
result = NamespaceExistsCmd(clientData, interp, objc, objv);
break;
case NSExportIdx:
result = NamespaceExportCmd(clientData, interp, objc, objv);
break;
case NSForgetIdx:
result = NamespaceForgetCmd(clientData, interp, objc, objv);
break;
case NSImportIdx:
result = NamespaceImportCmd(clientData, interp, objc, objv);
break;
case NSInscopeIdx:
result = NamespaceInscopeCmd(clientData, interp, objc, objv);
break;
case NSOriginIdx:
result = NamespaceOriginCmd(clientData, interp, objc, objv);
break;
case NSParentIdx:
result = NamespaceParentCmd(clientData, interp, objc, objv);
break;
case NSQualifiersIdx:
result = NamespaceQualifiersCmd(clientData, interp, objc, objv);
break;
case NSTailIdx:
result = NamespaceTailCmd(clientData, interp, objc, objv);
break;
case NSWhichIdx:
result = NamespaceWhichCmd(clientData, interp, objc, objv);
break;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* NamespaceChildrenCmd --
*
* Invoked to implement the "namespace children" command that returns a
* list containing the fully-qualified names of the child namespaces of
* a given namespace. Handles the following syntax:
*
* namespace children ?name? ?pattern?
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceChildrenCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
Namespace *nsPtr, *childNsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
char *pattern = NULL;
Tcl_DString buffer;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Tcl_Obj *listPtr, *elemPtr;
/*
* Get a pointer to the specified namespace, or the current namespace.
*/
if (objc == 2) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
} else if ((objc == 3) || (objc == 4)) {
if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
return TCL_ERROR;
}
if (namespacePtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown namespace \"", Tcl_GetString(objv[2]),
"\" in namespace children command", (char *) NULL);
return TCL_ERROR;
}
nsPtr = (Namespace *) namespacePtr;
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?");
return TCL_ERROR;
}
/*
* Get the glob-style pattern, if any, used to narrow the search.
*/
Tcl_DStringInit(&buffer);
if (objc == 4) {
char *name = Tcl_GetString(objv[3]);
if ((*name == ':') && (*(name+1) == ':')) {
pattern = name;
} else {
Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
if (nsPtr != globalNsPtr) {
Tcl_DStringAppend(&buffer, "::", 2);
}
Tcl_DStringAppend(&buffer, name, -1);
pattern = Tcl_DStringValue(&buffer);
}
}
/*
* Create a list containing the full names of all child namespaces
* whose names match the specified pattern, if any.
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
while (entryPtr != NULL) {
childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
if ((pattern == NULL)
|| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
}
entryPtr = Tcl_NextHashEntry(&search);
}
Tcl_SetObjResult(interp, listPtr);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceCodeCmd --
*
* Invoked to implement the "namespace code" command to capture the
* namespace context of a command. Handles the following syntax:
*
* namespace code arg
*
* Here "arg" can be a list. "namespace code arg" produces a result
* equivalent to that produced by the command
*
* list ::namespace inscope [namespace current] $arg
*
* However, if "arg" is itself a scoped value starting with
* "::namespace inscope", then the result is just "arg".
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* If anything goes wrong, this procedure returns an error
* message as the result in the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceCodeCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Namespace *currNsPtr;
Tcl_Obj *listPtr, *objPtr;
register char *arg, *p;
int length;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arg");
return TCL_ERROR;
}
/*
* If "arg" is already a scoped value, then return it directly.
*/
arg = Tcl_GetStringFromObj(objv[2], &length);
while (*arg == ':') {
arg++;
length--;
}
if ((*arg == 'n') && (length > 17)
&& (strncmp(arg, "namespace", 9) == 0)) {
for (p = (arg + 9); (*p == ' '); p++) {
/* empty body: skip over spaces */
}
if ((*p == 'i') && ((p + 7) <= (arg + length))
&& (strncmp(p, "inscope", 7) == 0)) {
Tcl_SetObjResult(interp, objv[2]);
return TCL_OK;
}
}
/*
* Otherwise, construct a scoped command by building a list with
* "namespace inscope", the full name of the current namespace, and
* the argument "arg". By constructing a list, we ensure that scoped
* commands are interpreted properly when they are executed later,
* by the "namespace inscope" command.
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj("::namespace", -1));
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj("inscope", -1));
currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
objPtr = Tcl_NewStringObj("::", -1);
} else {
objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
Tcl_ListObjAppendElement(interp, listPtr, objv[2]);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceCurrentCmd --
*
* Invoked to implement the "namespace current" command which returns
* the fully-qualified name of the current namespace. Handles the
* following syntax:
*
* namespace current
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceCurrentCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Namespace *currNsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
/*
* The "real" name of the global namespace ("::") is the null string,
* but we return "::" for it as a convenience to programmers. Note that
* "" and "::" are treated as synonyms by the namespace code so that it
* is still easy to do things like:
*
* namespace [namespace current]::bar { ... }
*/
currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
Tcl_AppendToObj(Tcl_GetObjResult(interp), "::", -1);
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp), currNsPtr->fullName, -1);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceDeleteCmd --
*
* Invoked to implement the "namespace delete" command to delete
* namespace(s). Handles the following syntax:
*
* namespace delete ?name name...?
*
* Each name identifies a namespace. It may include a sequence of
* namespace qualifiers separated by "::"s. If a namespace is found, it
* is deleted: all variables and procedures contained in that namespace
* are deleted. If that namespace is being used on the call stack, it
* is kept alive (but logically deleted) until it is removed from the
* call stack: that is, it can no longer be referenced by name but any
* currently executing procedure that refers to it is allowed to do so
* until the procedure returns. If the namespace can't be found, this
* procedure returns an error. If no namespaces are specified, this
* command does nothing.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Deletes the specified namespaces. If anything goes wrong, this
* procedure returns an error message in the interpreter's
* result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceDeleteCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
char *name;
register int i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
return TCL_ERROR;
}
/*
* Destroying one namespace may cause another to be destroyed. Break
* this into two passes: first check to make sure that all namespaces on
* the command line are valid, and report any errors.
*/
for (i = 2; i < objc; i++) {
name = Tcl_GetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name,
(Tcl_Namespace *) NULL, /*flags*/ 0);
if (namespacePtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown namespace \"", Tcl_GetString(objv[i]),
"\" in namespace delete command", (char *) NULL);
return TCL_ERROR;
}
}
/*
* Okay, now delete each namespace.
*/
for (i = 2; i < objc; i++) {
name = Tcl_GetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name,
(Tcl_Namespace *) NULL, /* flags */ 0);
if (namespacePtr) {
Tcl_DeleteNamespace(namespacePtr);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceEvalCmd --
*
* Invoked to implement the "namespace eval" command. Executes
* commands in a namespace. If the namespace does not already exist,
* it is created. Handles the following syntax:
*
* namespace eval name arg ?arg...?
*
* If more than one arg argument is specified, the command that is
* executed is the result of concatenating the arguments together with
* a space between each argument.
*
* Results:
* Returns TCL_OK if the namespace is found and the commands are
* executed successfully. Returns TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns the result of the command in the interpreter's result
* object. If anything goes wrong, this procedure returns an error
* message as the result.
*
*----------------------------------------------------------------------
*/
static int
NamespaceEvalCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
CallFrame frame;
Tcl_Obj *objPtr;
char *name;
int length, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
return TCL_ERROR;
}
/*
* Try to resolve the namespace reference, caching the result in the
* namespace object along the way.
*/
result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
if (result != TCL_OK) {
return result;
}
/*
* If the namespace wasn't found, try to create it.
*/
if (namespacePtr == NULL) {
name = Tcl_GetStringFromObj(objv[2], &length);
namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL,
(Tcl_NamespaceDeleteProc *) NULL);
if (namespacePtr == NULL) {
return TCL_ERROR;
}
}
/*
* Make the specified namespace the current namespace and evaluate
* the command(s).
*/
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame,
namespacePtr, /*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return TCL_ERROR;
}
frame.objc = objc;
frame.objv = objv; /* ref counts do not need to be incremented here */
if (objc == 4) {
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[3], 0);
#else
/* TIP #280 : Make actual argument location available to eval'd script */
Interp* iPtr = (Interp*) interp;
CmdFrame* invoker = iPtr->cmdFramePtr;
int word = 3;
TclArgumentGet (interp, objv[3], &invoker, &word);
result = TclEvalObjEx(interp, objv[3], 0, invoker, word);
#endif
} else {
/*
* More than one argument: concatenate them together with spaces
* between, then evaluate the result. Tcl_EvalObjEx will delete
* the object when it decrements its refcount after eval'ing it.
*/
objPtr = Tcl_ConcatObj(objc-3, objv+3);
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
#else
/* TIP #280. Make invoking context available to eval'd script */
result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
#endif
}
if (result == TCL_ERROR) {
char msg[256 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)",
namespacePtr->fullName, interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
/*
* Restore the previous "current" namespace.
*/
Tcl_PopCallFrame(interp);
return result;
}
/*
*----------------------------------------------------------------------
*
* NamespaceExistsCmd --
*
* Invoked to implement the "namespace exists" command that returns
* true if the given namespace currently exists, and false otherwise.
* Handles the following syntax:
*
* namespace exists name
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceExistsCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
/*
* Check whether the given namespace exists
*/
if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (namespacePtr != NULL));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceExportCmd --
*
* Invoked to implement the "namespace export" command that specifies
* which commands are exported from a namespace. The exported commands
* are those that can be imported into another namespace using
* "namespace import". Both commands defined in a namespace and
* commands the namespace has imported can be exported by a
* namespace. This command has the following syntax:
*
* namespace export ?-clear? ?pattern pattern...?
*
* Each pattern may contain "string match"-style pattern matching
* special characters, but the pattern may not include any namespace
* qualifiers: that is, the pattern must specify commands in the
* current (exporting) namespace. The specified patterns are appended
* onto the namespace's list of export patterns.
*
* To reset the namespace's export pattern list, specify the "-clear"
* flag.
*
* If there are no export patterns and the "-clear" flag isn't given,
* this command returns the namespace's current export list.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceExportCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int firstArg, i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-clear? ?pattern pattern...?");
return TCL_ERROR;
}
/*
* If no pattern arguments are given, and "-clear" isn't specified,
* return the namespace's current export pattern list.
*/
if (objc == 2) {
Tcl_Obj *listPtr = Tcl_NewObj();
(void) Tcl_AppendExportList(interp, NULL, listPtr);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
* Process the optional "-clear" argument.
*/
firstArg = 2;
if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) {
Tcl_Export(interp, NULL, "::", 1);
Tcl_ResetResult(interp);
firstArg++;
}
/*
* Add each pattern to the namespace's export pattern list.
*/
for (i = firstArg; i < objc; i++) {
int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0);
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceForgetCmd --
*
* Invoked to implement the "namespace forget" command to remove
* imported commands from a namespace. Handles the following syntax:
*
* namespace forget ?pattern pattern...?
*
* Each pattern is a name like "foo::*" or "a::b::x*". That is, the
* pattern may include the special pattern matching characters
* recognized by the "string match" command, but only in the command
* name at the end of the qualified name; the special pattern
* characters may not appear in a namespace name. All of the commands
* that match that pattern are checked to see if they have an imported
* command in the current namespace that refers to the matched
* command. If there is an alias, it is removed.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Imported commands are removed from the current namespace. If
* anything goes wrong, this procedure returns an error message in the
* interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceForgetCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *pattern;
register int i, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?");
return TCL_ERROR;
}
for (i = 2; i < objc; i++) {
pattern = Tcl_GetString(objv[i]);
result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern);
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceImportCmd --
*
* Invoked to implement the "namespace import" command that imports
* commands into a namespace. Handles the following syntax:
*
* namespace import ?-force? ?pattern pattern...?
*
* Each pattern is a namespace-qualified name like "foo::*",
* "a::b::x*", or "bar::p". That is, the pattern may include the
* special pattern matching characters recognized by the "string match"
* command, but only in the command name at the end of the qualified
* name; the special pattern characters may not appear in a namespace
* name. All of the commands that match the pattern and which are
* exported from their namespace are made accessible from the current
* namespace context. This is done by creating a new "imported command"
* in the current namespace that points to the real command in its
* original namespace; when the imported command is called, it invokes
* the real command.
*
* If an imported command conflicts with an existing command, it is
* treated as an error. But if the "-force" option is included, then
* existing commands are overwritten by the imported commands.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Adds imported commands to the current namespace. If anything goes
* wrong, this procedure returns an error message in the interpreter's
* result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceImportCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int allowOverwrite = 0;
char *string, *pattern;
register int i, result;
int firstArg;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-force? ?pattern pattern...?");
return TCL_ERROR;
}
/*
* Skip over the optional "-force" as the first argument.
*/
firstArg = 2;
if (firstArg < objc) {
string = Tcl_GetString(objv[firstArg]);
if ((*string == '-') && (strcmp(string, "-force") == 0)) {
allowOverwrite = 1;
firstArg++;
}
}
/*
* Handle the imports for each of the patterns.
*/
for (i = firstArg; i < objc; i++) {
pattern = Tcl_GetString(objv[i]);
result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern,
allowOverwrite);
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceInscopeCmd --
*
* Invoked to implement the "namespace inscope" command that executes a
* script in the context of a particular namespace. This command is not
* expected to be used directly by programmers; calls to it are
* generated implicitly when programs use "namespace code" commands
* to register callback scripts. Handles the following syntax:
*
* namespace inscope name arg ?arg...?
*
* The "namespace inscope" command is much like the "namespace eval"
* command except that it has lappend semantics and the namespace must
* already exist. It treats the first argument as a list, and appends
* any arguments after the first onto the end as proper list elements.
* For example,
*
* namespace inscope ::foo a b c d
*
* is equivalent to
*
* namespace eval ::foo [concat a [list b c d]]
*
* This lappend semantics is important because many callback scripts
* are actually prefixes.
*
* Results:
* Returns TCL_OK to indicate success, or TCL_ERROR to indicate
* failure.
*
* Side effects:
* Returns a result in the Tcl interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceInscopeCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
Tcl_CallFrame frame;
int i, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
return TCL_ERROR;
}
/*
* Resolve the namespace reference.
*/
result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
if (result != TCL_OK) {
return result;
}
if (namespacePtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown namespace \"", Tcl_GetString(objv[2]),
"\" in inscope namespace command", (char *) NULL);
return TCL_ERROR;
}
/*
* Make the specified namespace the current namespace.
*/
result = Tcl_PushCallFrame(interp, &frame, namespacePtr,
/*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return result;
}
/*
* Execute the command. If there is just one argument, just treat it as
* a script and evaluate it. Otherwise, create a list from the arguments
* after the first one, then concatenate the first argument and the list
* of extra arguments to form the command to evaluate.
*/
if (objc == 4) {
result = Tcl_EvalObjEx(interp, objv[3], 0);
} else {
Tcl_Obj *concatObjv[2];
register Tcl_Obj *listPtr, *cmdObjPtr;
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
for (i = 4; i < objc; i++) {
result = Tcl_ListObjAppendElement(interp, listPtr, objv[i]);
if (result != TCL_OK) {
Tcl_DecrRefCount(listPtr); /* free unneeded obj */
return result;
}
}
concatObjv[0] = objv[3];
concatObjv[1] = listPtr;
cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
Tcl_DecrRefCount(listPtr); /* we're done with the list object */
}
if (result == TCL_ERROR) {
char msg[256 + TCL_INTEGER_SPACE];
sprintf(msg,
"\n (in namespace inscope \"%.200s\" script line %d)",
namespacePtr->fullName, interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
/*
* Restore the previous "current" namespace.
*/
Tcl_PopCallFrame(interp);
return result;
}
/*
*----------------------------------------------------------------------
*
* NamespaceOriginCmd --
*
* Invoked to implement the "namespace origin" command to return the
* fully-qualified name of the "real" command to which the specified
* "imported command" refers. Handles the following syntax:
*
* namespace origin name
*
* Results:
* An imported command is created in an namespace when that namespace
* imports a command from another namespace. If a command is imported
* into a sequence of namespaces a, b,...,n where each successive
* namespace just imports the command from the previous namespace, this
* command returns the fully-qualified name of the original command in
* the first namespace, a. If "name" does not refer to an alias, its
* fully-qualified name is returned. The returned name is stored in the
* interpreter's result object. This procedure returns TCL_OK if
* successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* If anything goes wrong, this procedure returns an error message in
* the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceOriginCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Command command, origCommand;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
command = Tcl_GetCommandFromObj(interp, objv[2]);
if (command == (Tcl_Command) NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid command name \"", Tcl_GetString(objv[2]),
"\"", (char *) NULL);
return TCL_ERROR;
}
origCommand = TclGetOriginalCommand(command);
if (origCommand == (Tcl_Command) NULL) {
/*
* The specified command isn't an imported command. Return the
* command's name qualified by the full name of the namespace it
* was defined in.
*/
Tcl_GetCommandFullName(interp, command, Tcl_GetObjResult(interp));
} else {
Tcl_GetCommandFullName(interp, origCommand, Tcl_GetObjResult(interp));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceParentCmd --
*
* Invoked to implement the "namespace parent" command that returns the
* fully-qualified name of the parent namespace for a specified
* namespace. Handles the following syntax:
*
* namespace parent ?name?
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceParentCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *nsPtr;
int result;
if (objc == 2) {
nsPtr = Tcl_GetCurrentNamespace(interp);
} else if (objc == 3) {
result = GetNamespaceFromObj(interp, objv[2], &nsPtr);
if (result != TCL_OK) {
return result;
}
if (nsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown namespace \"", Tcl_GetString(objv[2]),
"\" in namespace parent command", (char *) NULL);
return TCL_ERROR;
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?name?");
return TCL_ERROR;
}
/*
* Report the parent of the specified namespace.
*/
if (nsPtr->parentPtr != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
nsPtr->parentPtr->fullName, -1);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceQualifiersCmd --
*
* Invoked to implement the "namespace qualifiers" command that returns
* any leading namespace qualifiers in a string. These qualifiers are
* namespace names separated by "::"s. For example, for "::foo::p" this
* command returns "::foo", and for "::" it returns "". This command
* is the complement of the "namespace tail" command. Note that this
* command does not check whether the "namespace" names are, in fact,
* the names of currently defined namespaces. Handles the following
* syntax:
*
* namespace qualifiers string
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceQualifiersCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register char *name, *p;
int length;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
}
/*
* Find the end of the string, then work backward and find
* the start of the last "::" qualifier.
*/
name = Tcl_GetString(objv[2]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
while (--p >= name) {
if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
p -= 2; /* back up over the :: */
while ((p >= name) && (*p == ':')) {
p--; /* back up over the preceeding : */
}
break;
}
}
if (p >= name) {
length = p-name+1;
Tcl_AppendToObj(Tcl_GetObjResult(interp), name, length);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceTailCmd --
*
* Invoked to implement the "namespace tail" command that returns the
* trailing name at the end of a string with "::" namespace
* qualifiers. These qualifiers are namespace names separated by
* "::"s. For example, for "::foo::p" this command returns "p", and for
* "::" it returns "". This command is the complement of the "namespace
* qualifiers" command. Note that this command does not check whether
* the "namespace" names are, in fact, the names of currently defined
* namespaces. Handles the following syntax:
*
* namespace tail string
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceTailCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register char *name, *p;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
}
/*
* Find the end of the string, then work backward and find the
* last "::" qualifier.
*/
name = Tcl_GetString(objv[2]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
while (--p > name) {
if ((*p == ':') && (*(p-1) == ':')) {
p++; /* just after the last "::" */
break;
}
}
if (p >= name) {
Tcl_AppendToObj(Tcl_GetObjResult(interp), p, -1);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceWhichCmd --
*
* Invoked to implement the "namespace which" command that returns the
* fully-qualified name of a command or variable. If the specified
* command or variable does not exist, it returns "". Handles the
* following syntax:
*
* namespace which ?-command? ?-variable? name
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceWhichCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register char *arg;
Tcl_Command cmd;
Tcl_Var variable;
int argIndex, lookup;
if (objc < 3) {
badArgs:
Tcl_WrongNumArgs(interp, 2, objv,
"?-command? ?-variable? name");
return TCL_ERROR;
}
/*
* Look for a flag controlling the lookup.
*/
argIndex = 2;
lookup = 0; /* assume command lookup by default */
arg = Tcl_GetString(objv[2]);
if (*arg == '-') {
if (strncmp(arg, "-command", 8) == 0) {
lookup = 0;
} else if (strncmp(arg, "-variable", 9) == 0) {
lookup = 1;
} else {
goto badArgs;
}
argIndex = 3;
}
if (objc != (argIndex + 1)) {
goto badArgs;
}
switch (lookup) {
case 0: /* -command */
cmd = Tcl_GetCommandFromObj(interp, objv[argIndex]);
if (cmd == (Tcl_Command) NULL) {
return TCL_OK; /* cmd not found, just return (no error) */
}
Tcl_GetCommandFullName(interp, cmd, Tcl_GetObjResult(interp));
break;
case 1: /* -variable */
arg = Tcl_GetString(objv[argIndex]);
variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL,
/*flags*/ 0);
if (variable != (Tcl_Var) NULL) {
Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
}
break;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeNsNameInternalRep --
*
* Frees the resources associated with a nsName object's internal
* representation.
*
* Results:
* None.
*
* Side effects:
* Decrements the ref count of any Namespace structure pointed
* to by the nsName's internal representation. If there are no more
* references to the namespace, it's structure will be freed.
*
*----------------------------------------------------------------------
*/
static void
FreeNsNameInternalRep(objPtr)
register Tcl_Obj *objPtr; /* nsName object with internal
* representation to free */
{
register ResolvedNsName *resNamePtr =
(ResolvedNsName *) objPtr->internalRep.otherValuePtr;
Namespace *nsPtr;
/*
* Decrement the reference count of the namespace. If there are no
* more references, free it up.
*/
if (resNamePtr != NULL) {
resNamePtr->refCount--;
if (resNamePtr->refCount == 0) {
/*
* Decrement the reference count for the cached namespace. If
* the namespace is dead, and there are no more references to
* it, free it.
*/
nsPtr = resNamePtr->nsPtr;
nsPtr->refCount--;
if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
NamespaceFree(nsPtr);
}
ckfree((char *) resNamePtr);
}
}
}
/*
*----------------------------------------------------------------------
*
* DupNsNameInternalRep --
*
* Initializes the internal representation of a nsName object to a copy
* of the internal representation of another nsName object.
*
* Results:
* None.
*
* Side effects:
* copyPtr's internal rep is set to refer to the same namespace
* referenced by srcPtr's internal rep. Increments the ref count of
* the ResolvedNsName structure used to hold the namespace reference.
*
*----------------------------------------------------------------------
*/
static void
DupNsNameInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
register ResolvedNsName *resNamePtr =
(ResolvedNsName *) srcPtr->internalRep.otherValuePtr;
copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
if (resNamePtr != NULL) {
resNamePtr->refCount++;
}
copyPtr->typePtr = &tclNsNameType;
}
/*
*----------------------------------------------------------------------
*
* SetNsNameFromAny --
*
* Attempt to generate a nsName internal representation for a
* Tcl object.
*
* Results:
* Returns TCL_OK if the value could be converted to a proper
* namespace reference. Otherwise, it returns TCL_ERROR, along
* with an error message in the interpreter's result object.
*
* Side effects:
* If successful, the object is made a nsName object. Its internal rep
* is set to point to a ResolvedNsName, which contains a cached pointer
* to the Namespace. Reference counts are kept on both the
* ResolvedNsName and the Namespace, so we can keep track of their
* usage and free them when appropriate.
*
*----------------------------------------------------------------------
*/
static int
SetNsNameFromAny(interp, objPtr)
Tcl_Interp *interp; /* Points to the namespace in which to
* resolve name. Also used for error
* reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
char *name;
CONST char *dummy;
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
register ResolvedNsName *resNamePtr;
if (interp == NULL) {
return TCL_ERROR;
}
/*
* Get the string representation. Make it up-to-date if necessary.
*/
name = objPtr->bytes;
if (name == NULL) {
name = Tcl_GetString(objPtr);
}
/*
* Look for the namespace "name" in the current namespace. If there is
* an error parsing the (possibly qualified) name, return an error.
* If the namespace isn't found, we convert the object to an nsName
* object with a NULL ResolvedNsName* internal rep.
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
if (nsPtr != NULL) {
Namespace *currNsPtr =
(Namespace *) Tcl_GetCurrentNamespace(interp);
nsPtr->refCount++;
resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName));
resNamePtr->nsPtr = nsPtr;
resNamePtr->nsId = nsPtr->nsId;
resNamePtr->refNsPtr = currNsPtr;
resNamePtr->refCount = 1;
} else {
resNamePtr = NULL;
}
/*
* Free the old internalRep before setting the new one.
* We do this as late as possible to allow the conversion code
* (in particular, Tcl_GetStringFromObj) to use that old internalRep.
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
objPtr->typePtr = &tclNsNameType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfNsName --
*
* Updates the string representation for a nsName object.
* Note: This procedure does not free an existing old string rep
* so storage will be lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a copy of the fully qualified
* namespace name.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfNsName(objPtr)
register Tcl_Obj *objPtr; /* nsName object with string rep to update. */
{
ResolvedNsName *resNamePtr =
(ResolvedNsName *) objPtr->internalRep.otherValuePtr;
register Namespace *nsPtr;
char *name = "";
int length;
if ((resNamePtr != NULL)
&& (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) {
nsPtr = resNamePtr->nsPtr;
if (nsPtr->flags & NS_DEAD) {
nsPtr = NULL;
}
if (nsPtr != NULL) {
name = nsPtr->fullName;
}
}
/*
* The following sets the string rep to an empty string on the heap
* if the internal rep is NULL.
*/
length = strlen(name);
if (length == 0) {
objPtr->bytes = tclEmptyStringRep;
} else {
objPtr->bytes = (char *) ckalloc((unsigned) (length + 1));
memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length);
objPtr->bytes[length] = '\0';
}
objPtr->length = length;
}
tcl8.4.20/generic/tclPipe.c 0000644 0036047 0045461 00000076453 12052456744 014115 0 ustar dgp 771div /*
* tclPipe.c --
*
* This file contains the generic portion of the command channel
* driver as well as various utility routines used in managing
* subprocesses.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* A linked list of the following structures is used to keep track
* of child processes that have been detached but haven't exited
* yet, so we can make sure that they're properly "reaped" (officially
* waited for) and don't lie around as zombies cluttering the
* system.
*/
typedef struct Detached {
Tcl_Pid pid; /* Id of process that's been detached
* but isn't known to have exited. */
struct Detached *nextPtr; /* Next in list of all detached
* processes. */
} Detached;
static Detached *detList = NULL; /* List of all detached proceses. */
TCL_DECLARE_MUTEX(pipeMutex) /* Guard access to detList. */
/*
* Declarations for local procedures defined in this file:
*/
static TclFile FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *spec, int atOk, CONST char *arg,
CONST char *nextArg, int flags, int *skipPtr,
int *closePtr, int *releasePtr));
/*
*----------------------------------------------------------------------
*
* FileForRedirect --
*
* This procedure does much of the work of parsing redirection
* operators. It handles "@" if specified and allowed, and a file
* name, and opens the file if necessary.
*
* Results:
* The return value is the descriptor number for the file. If an
* error occurs then NULL is returned and an error message is left
* in the interp's result. Several arguments are side-effected; see
* the argument list below for details.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static TclFile
FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr,
releasePtr)
Tcl_Interp *interp; /* Intepreter to use for error reporting. */
CONST char *spec; /* Points to character just after
* redirection character. */
int atOK; /* Non-zero means that '@' notation can be
* used to specify a channel, zero means that
* it isn't. */
CONST char *arg; /* Pointer to entire argument containing
* spec: used for error reporting. */
CONST char *nextArg; /* Next argument in argc/argv array, if needed
* for file name or channel name. May be
* NULL. */
int flags; /* Flags to use for opening file or to
* specify mode for channel. */
int *skipPtr; /* Filled with 1 if redirection target was
* in spec, 2 if it was in nextArg. */
int *closePtr; /* Filled with one if the caller should
* close the file when done with it, zero
* otherwise. */
int *releasePtr;
{
int writing = (flags & O_WRONLY);
Tcl_Channel chan;
TclFile file;
*skipPtr = 1;
if ((atOK != 0) && (*spec == '@')) {
spec++;
if (*spec == '\0') {
spec = nextArg;
if (spec == NULL) {
goto badLastArg;
}
*skipPtr = 2;
}
chan = Tcl_GetChannel(interp, spec, NULL);
if (chan == (Tcl_Channel) NULL) {
return NULL;
}
file = TclpMakeFile(chan, writing ? TCL_WRITABLE : TCL_READABLE);
if (file == NULL) {
Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan),
"\" wasn't opened for ",
((writing) ? "writing" : "reading"), (char *) NULL);
return NULL;
}
*releasePtr = 1;
if (writing) {
/*
* Be sure to flush output to the file, so that anything
* written by the child appears after stuff we've already
* written.
*/
Tcl_Flush(chan);
}
} else {
CONST char *name;
Tcl_DString nameString;
if (*spec == '\0') {
spec = nextArg;
if (spec == NULL) {
goto badLastArg;
}
*skipPtr = 2;
}
name = Tcl_TranslateFileName(interp, spec, &nameString);
if (name == NULL) {
return NULL;
}
file = TclpOpenFile(name, flags);
Tcl_DStringFree(&nameString);
if (file == NULL) {
Tcl_AppendResult(interp, "couldn't ",
((writing) ? "write" : "read"), " file \"", spec, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return NULL;
}
*closePtr = 1;
}
return file;
badLastArg:
Tcl_AppendResult(interp, "can't specify \"", arg,
"\" as last word in command", (char *) NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DetachPids --
*
* This procedure is called to indicate that one or more child
* processes have been placed in background and will never be
* waited for; they should eventually be reaped by
* Tcl_ReapDetachedProcs.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_DetachPids(numPids, pidPtr)
int numPids; /* Number of pids to detach: gives size
* of array pointed to by pidPtr. */
Tcl_Pid *pidPtr; /* Array of pids to detach. */
{
register Detached *detPtr;
int i;
Tcl_MutexLock(&pipeMutex);
for (i = 0; i < numPids; i++) {
detPtr = (Detached *) ckalloc(sizeof(Detached));
detPtr->pid = pidPtr[i];
detPtr->nextPtr = detList;
detList = detPtr;
}
Tcl_MutexUnlock(&pipeMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ReapDetachedProcs --
*
* This procedure checks to see if any detached processes have
* exited and, if so, it "reaps" them by officially waiting on
* them. It should be called "occasionally" to make sure that
* all detached processes are eventually reaped.
*
* Results:
* None.
*
* Side effects:
* Processes are waited on, so that they can be reaped by the
* system.
*
*----------------------------------------------------------------------
*/
void
Tcl_ReapDetachedProcs()
{
register Detached *detPtr;
Detached *nextPtr, *prevPtr;
int status;
Tcl_Pid pid;
Tcl_MutexLock(&pipeMutex);
for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) {
prevPtr = detPtr;
detPtr = detPtr->nextPtr;
continue;
}
nextPtr = detPtr->nextPtr;
if (prevPtr == NULL) {
detList = detPtr->nextPtr;
} else {
prevPtr->nextPtr = detPtr->nextPtr;
}
ckfree((char *) detPtr);
detPtr = nextPtr;
}
Tcl_MutexUnlock(&pipeMutex);
}
/*
*----------------------------------------------------------------------
*
* TclCleanupChildren --
*
* This is a utility procedure used to wait for child processes
* to exit, record information about abnormal exits, and then
* collect any stderr output generated by them.
*
* Results:
* The return value is a standard Tcl result. If anything at
* weird happened with the child processes, TCL_ERROR is returned
* and a message is left in the interp's result.
*
* Side effects:
* If the last character of the interp's result is a newline, then it
* is removed unless keepNewline is non-zero. File errorId gets
* closed, and pidPtr is freed back to the storage allocator.
*
*----------------------------------------------------------------------
*/
int
TclCleanupChildren(interp, numPids, pidPtr, errorChan)
Tcl_Interp *interp; /* Used for error messages. */
int numPids; /* Number of entries in pidPtr array. */
Tcl_Pid *pidPtr; /* Array of process ids of children. */
Tcl_Channel errorChan; /* Channel for file containing stderr output
* from pipeline. NULL means there isn't any
* stderr output. */
{
int result = TCL_OK;
int i, abnormalExit, anyErrorInfo;
Tcl_Pid pid;
WAIT_STATUS_TYPE waitStatus;
CONST char *msg;
unsigned long resolvedPid;
abnormalExit = 0;
for (i = 0; i < numPids; i++) {
/*
* We need to get the resolved pid before we wait on it as
* the windows implementation of Tcl_WaitPid deletes the
* information such that any following calls to TclpGetPid
* fail.
*/
resolvedPid = TclpGetPid(pidPtr[i]);
pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0);
if (pid == (Tcl_Pid) -1) {
result = TCL_ERROR;
if (interp != (Tcl_Interp *) NULL) {
msg = Tcl_PosixError(interp);
if (errno == ECHILD) {
/*
* This changeup in message suggested by Mark Diekhans
* to remind people that ECHILD errors can occur on
* some systems if SIGCHLD isn't in its default state.
*/
msg =
"child process lost (is SIGCHLD ignored or trapped?)";
}
Tcl_AppendResult(interp, "error waiting for process to exit: ",
msg, (char *) NULL);
}
continue;
}
/*
* Create error messages for unusual process exits. An
* extra newline gets appended to each error message, but
* it gets removed below (in the same fashion that an
* extra newline in the command's output is removed).
*/
if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE];
result = TCL_ERROR;
TclFormatInt(msg1, (long) resolvedPid);
if (WIFEXITED(waitStatus)) {
if (interp != (Tcl_Interp *) NULL) {
TclFormatInt(msg2, WEXITSTATUS(waitStatus));
Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2,
(char *) NULL);
}
abnormalExit = 1;
} else if (WIFSIGNALED(waitStatus)) {
if (interp != (Tcl_Interp *) NULL) {
CONST char *p;
p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus)));
Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
Tcl_SignalId((int) (WTERMSIG(waitStatus))), p,
(char *) NULL);
Tcl_AppendResult(interp, "child killed: ", p, "\n",
(char *) NULL);
}
} else if (WIFSTOPPED(waitStatus)) {
if (interp != (Tcl_Interp *) NULL) {
CONST char *p;
p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus)));
Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
Tcl_SignalId((int) (WSTOPSIG(waitStatus))),
p, (char *) NULL);
Tcl_AppendResult(interp, "child suspended: ", p, "\n",
(char *) NULL);
}
} else {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp,
"child wait status didn't make sense\n",
(char *) NULL);
}
}
}
}
/*
* Read the standard error file. If there's anything there,
* then return an error and add the file's contents to the result
* string.
*/
anyErrorInfo = 0;
if (errorChan != NULL) {
/*
* Make sure we start at the beginning of the file.
*/
if (interp != NULL) {
int count;
Tcl_Obj *objPtr;
Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET);
objPtr = Tcl_NewObj();
count = Tcl_ReadChars(errorChan, objPtr, -1, 0);
if (count < 0) {
result = TCL_ERROR;
Tcl_DecrRefCount(objPtr);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading stderr output file: ",
Tcl_PosixError(interp), NULL);
} else if (count > 0) {
anyErrorInfo = 1;
Tcl_SetObjResult(interp, objPtr);
result = TCL_ERROR;
} else {
Tcl_DecrRefCount(objPtr);
}
}
Tcl_Close(NULL, errorChan);
}
/*
* If a child exited abnormally but didn't output any error information
* at all, generate an error message here.
*/
if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) {
Tcl_AppendResult(interp, "child process exited abnormally",
(char *) NULL);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclCreatePipeline --
*
* Given an argc/argv array, instantiate a pipeline of processes
* as described by the argv.
*
* This procedure is unofficially exported for use by BLT.
*
* Results:
* The return value is a count of the number of new processes
* created, or -1 if an error occurred while creating the pipeline.
* *pidArrayPtr is filled in with the address of a dynamically
* allocated array giving the ids of all of the processes. It
* is up to the caller to free this array when it isn't needed
* anymore. If inPipePtr is non-NULL, *inPipePtr is filled in
* with the file id for the input pipe for the pipeline (if any):
* the caller must eventually close this file. If outPipePtr
* isn't NULL, then *outPipePtr is filled in with the file id
* for the output pipe from the pipeline: the caller must close
* this file. If errFilePtr isn't NULL, then *errFilePtr is filled
* with a file id that may be used to read error output after the
* pipeline completes.
*
* Side effects:
* Processes and pipes are created.
*
*----------------------------------------------------------------------
*/
int
TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr,
outPipePtr, errFilePtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting. */
int argc; /* Number of entries in argv. */
CONST char **argv; /* Array of strings describing commands in
* pipeline plus I/O redirection with <,
* <<, >, etc. Argv[argc] must be NULL. */
Tcl_Pid **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with
* address of array of pids for processes
* in pipeline (first pid is first process
* in pipeline). */
TclFile *inPipePtr; /* If non-NULL, input to the pipeline comes
* from a pipe (unless overridden by
* redirection in the command). The file
* id with which to write to this pipe is
* stored at *inPipePtr. NULL means command
* specified its own input source. */
TclFile *outPipePtr; /* If non-NULL, output to the pipeline goes
* to a pipe, unless overriden by redirection
* in the command. The file id with which to
* read frome this pipe is stored at
* *outPipePtr. NULL means command specified
* its own output sink. */
TclFile *errFilePtr; /* If non-NULL, all stderr output from the
* pipeline will go to a temporary file
* created here, and a descriptor to read
* the file will be left at *errFilePtr.
* The file will be removed already, so
* closing this descriptor will be the end
* of the file. If this is NULL, then
* all stderr output goes to our stderr.
* If the pipeline specifies redirection
* then the file will still be created
* but it will never get any data. */
{
Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all
* the pids of child processes. */
int numPids; /* Actual number of processes that exist
* at *pidPtr right now. */
int cmdCount; /* Count of number of distinct commands
* found in argc/argv. */
CONST char *inputLiteral = NULL; /* If non-null, then this points to a
* string containing input data (specified
* via <<) to be piped to the first process
* in the pipeline. */
TclFile inputFile = NULL; /* If != NULL, gives file to use as input for
* first process in pipeline (specified via <
* or <@). */
int inputClose = 0; /* If non-zero, then inputFile should be
* closed when cleaning up. */
int inputRelease = 0;
TclFile outputFile = NULL; /* Writable file for output from last command
* in pipeline (could be file or pipe). NULL
* means use stdout. */
int outputClose = 0; /* If non-zero, then outputFile should be
* closed when cleaning up. */
int outputRelease = 0;
TclFile errorFile = NULL; /* Writable file for error output from all
* commands in pipeline. NULL means use
* stderr. */
int errorClose = 0; /* If non-zero, then errorFile should be
* closed when cleaning up. */
int errorRelease = 0;
CONST char *p;
CONST char *nextArg;
int skip, lastBar, lastArg, i, j, atOK, flags, needCmd, errorToOutput = 0;
Tcl_DString execBuffer;
TclFile pipeIn;
TclFile curInFile, curOutFile, curErrFile;
Tcl_Channel channel;
if (inPipePtr != NULL) {
*inPipePtr = NULL;
}
if (outPipePtr != NULL) {
*outPipePtr = NULL;
}
if (errFilePtr != NULL) {
*errFilePtr = NULL;
}
Tcl_DStringInit(&execBuffer);
pipeIn = NULL;
curInFile = NULL;
curOutFile = NULL;
numPids = 0;
/*
* First, scan through all the arguments to figure out the structure
* of the pipeline. Process all of the input and output redirection
* arguments and remove them from the argument list in the pipeline.
* Count the number of distinct processes (it's the number of "|"
* arguments plus one) but don't remove the "|" arguments because
* they'll be used in the second pass to seperate the individual
* child processes. Cannot start the child processes in this pass
* because the redirection symbols may appear anywhere in the
* command line -- e.g., the '<' that specifies the input to the
* entire pipe may appear at the very end of the argument list.
*/
lastBar = -1;
cmdCount = 1;
needCmd = 1;
for (i = 0; i < argc; i++) {
errorToOutput = 0;
skip = 0;
p = argv[i];
switch (*p++) {
case '|':
if (*p == '&') {
p++;
}
if (*p == '\0') {
if ((i == (lastBar + 1)) || (i == (argc - 1))) {
Tcl_SetResult(interp,
"illegal use of | or |& in command",
TCL_STATIC);
goto error;
}
}
lastBar = i;
cmdCount++;
needCmd = 1;
break;
case '<':
if (inputClose != 0) {
inputClose = 0;
TclpCloseFile(inputFile);
}
if (inputRelease != 0) {
inputRelease = 0;
TclpReleaseFile(inputFile);
}
if (*p == '<') {
inputFile = NULL;
inputLiteral = p + 1;
skip = 1;
if (*inputLiteral == '\0') {
inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1];
if (inputLiteral == NULL) {
Tcl_AppendResult(interp, "can't specify \"", argv[i],
"\" as last word in command", (char *) NULL);
goto error;
}
skip = 2;
}
} else {
nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
inputLiteral = NULL;
inputFile = FileForRedirect(interp, p, 1, argv[i],
nextArg, O_RDONLY, &skip, &inputClose, &inputRelease);
if (inputFile == NULL) {
goto error;
}
}
break;
case '>':
atOK = 1;
flags = O_WRONLY | O_CREAT | O_TRUNC;
if (*p == '>') {
p++;
atOK = 0;
/*
* Note that the O_APPEND flag only has an effect on POSIX
* platforms. On Windows, we just have to carry on regardless.
*/
flags = O_WRONLY | O_CREAT | O_APPEND;
}
if (*p == '&') {
if (errorClose != 0) {
errorClose = 0;
TclpCloseFile(errorFile);
}
errorToOutput = 1;
p++;
}
/*
* Close the old output file, but only if the error file is
* not also using it.
*/
if (outputClose != 0) {
outputClose = 0;
if (errorFile == outputFile) {
errorClose = 1;
} else {
TclpCloseFile(outputFile);
}
}
if (outputRelease != 0) {
outputRelease = 0;
if (errorFile == outputFile) {
errorRelease = 1;
} else {
TclpReleaseFile(outputFile);
}
}
nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
outputFile = FileForRedirect(interp, p, atOK, argv[i],
nextArg, flags, &skip, &outputClose, &outputRelease);
if (outputFile == NULL) {
goto error;
}
if (errorToOutput) {
if (errorClose != 0) {
errorClose = 0;
TclpCloseFile(errorFile);
}
if (errorRelease != 0) {
errorRelease = 0;
TclpReleaseFile(errorFile);
}
errorFile = outputFile;
}
break;
case '2':
if (*p != '>') {
break;
}
p++;
atOK = 1;
flags = O_WRONLY | O_CREAT | O_TRUNC;
if (*p == '>') {
p++;
atOK = 0;
flags = O_WRONLY | O_CREAT;
}
if (errorClose != 0) {
errorClose = 0;
TclpCloseFile(errorFile);
}
if (errorRelease != 0) {
errorRelease = 0;
TclpReleaseFile(errorFile);
}
if (atOK && p[0] == '@' && p[1] == '1' && p[2] == '\0') {
/*
* Special case handling of 2>@1 to redirect stderr to the
* exec/open output pipe as well. This is meant for the end
* of the command string, otherwise use |& between commands.
*/
if (i != argc - 1) {
Tcl_AppendResult(interp, "must specify \"", argv[i],
"\" as last word in command", (char *) NULL);
goto error;
}
errorFile = outputFile;
errorToOutput = 2;
skip = 1;
} else {
nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
errorFile = FileForRedirect(interp, p, atOK, argv[i],
nextArg, flags, &skip, &errorClose, &errorRelease);
if (errorFile == NULL) {
goto error;
}
}
break;
default:
/* Got a command word, not a redirection */
needCmd = 0;
break;
}
if (skip != 0) {
for (j = i + skip; j < argc; j++) {
argv[j - skip] = argv[j];
}
argc -= skip;
i -= 1;
}
}
if (needCmd) {
/* We had a bar followed only by redirections. */
Tcl_SetResult(interp,
"illegal use of | or |& in command",
TCL_STATIC);
goto error;
}
if (inputFile == NULL) {
if (inputLiteral != NULL) {
/*
* The input for the first process is immediate data coming from
* Tcl. Create a temporary file for it and put the data into the
* file.
*/
inputFile = TclpCreateTempFile(inputLiteral);
if (inputFile == NULL) {
Tcl_AppendResult(interp,
"couldn't create input file for command: ",
Tcl_PosixError(interp), (char *) NULL);
goto error;
}
inputClose = 1;
} else if (inPipePtr != NULL) {
/*
* The input for the first process in the pipeline is to
* come from a pipe that can be written from by the caller.
*/
if (TclpCreatePipe(&inputFile, inPipePtr) == 0) {
Tcl_AppendResult(interp,
"couldn't create input pipe for command: ",
Tcl_PosixError(interp), (char *) NULL);
goto error;
}
inputClose = 1;
} else {
/*
* The input for the first process comes from stdin.
*/
channel = Tcl_GetStdChannel(TCL_STDIN);
if (channel != NULL) {
inputFile = TclpMakeFile(channel, TCL_READABLE);
if (inputFile != NULL) {
inputRelease = 1;
}
}
}
}
if (outputFile == NULL) {
if (outPipePtr != NULL) {
/*
* Output from the last process in the pipeline is to go to a
* pipe that can be read by the caller.
*/
if (TclpCreatePipe(outPipePtr, &outputFile) == 0) {
Tcl_AppendResult(interp,
"couldn't create output pipe for command: ",
Tcl_PosixError(interp), (char *) NULL);
goto error;
}
outputClose = 1;
} else {
/*
* The output for the last process goes to stdout.
*/
channel = Tcl_GetStdChannel(TCL_STDOUT);
if (channel) {
outputFile = TclpMakeFile(channel, TCL_WRITABLE);
if (outputFile != NULL) {
outputRelease = 1;
}
}
}
}
if (errorFile == NULL) {
if (errorToOutput == 2) {
/*
* Handle 2>@1 special case at end of cmd line
*/
errorFile = outputFile;
} else if (errFilePtr != NULL) {
/*
* Set up the standard error output sink for the pipeline, if
* requested. Use a temporary file which is opened, then deleted.
* Could potentially just use pipe, but if it filled up it could
* cause the pipeline to deadlock: we'd be waiting for processes
* to complete before reading stderr, and processes couldn't
* complete because stderr was backed up.
*/
errorFile = TclpCreateTempFile(NULL);
if (errorFile == NULL) {
Tcl_AppendResult(interp,
"couldn't create error file for command: ",
Tcl_PosixError(interp), (char *) NULL);
goto error;
}
*errFilePtr = errorFile;
} else {
/*
* Errors from the pipeline go to stderr.
*/
channel = Tcl_GetStdChannel(TCL_STDERR);
if (channel) {
errorFile = TclpMakeFile(channel, TCL_WRITABLE);
if (errorFile != NULL) {
errorRelease = 1;
}
}
}
}
/*
* Scan through the argc array, creating a process for each
* group of arguments between the "|" characters.
*/
Tcl_ReapDetachedProcs();
pidPtr = (Tcl_Pid *) ckalloc((unsigned) (cmdCount * sizeof(Tcl_Pid)));
curInFile = inputFile;
for (i = 0; i < argc; i = lastArg + 1) {
int result, joinThisError;
Tcl_Pid pid;
CONST char *oldName;
/*
* Convert the program name into native form.
*/
if (Tcl_TranslateFileName(interp, argv[i], &execBuffer) == NULL) {
goto error;
}
/*
* Find the end of the current segment of the pipeline.
*/
joinThisError = 0;
for (lastArg = i; lastArg < argc; lastArg++) {
if (argv[lastArg][0] == '|') {
if (argv[lastArg][1] == '\0') {
break;
}
if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == '\0')) {
joinThisError = 1;
break;
}
}
}
/*
* If this is the last segment, use the specified outputFile.
* Otherwise create an intermediate pipe. pipeIn will become the
* curInFile for the next segment of the pipe.
*/
if (lastArg == argc) {
curOutFile = outputFile;
} else {
argv[lastArg] = NULL;
if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) {
Tcl_AppendResult(interp, "couldn't create pipe: ",
Tcl_PosixError(interp), (char *) NULL);
goto error;
}
}
if (joinThisError != 0) {
curErrFile = curOutFile;
} else {
curErrFile = errorFile;
}
/*
* Restore argv[i], since a caller wouldn't expect the contents of
* argv to be modified.
*/
oldName = argv[i];
argv[i] = Tcl_DStringValue(&execBuffer);
result = TclpCreateProcess(interp, lastArg - i, argv + i,
curInFile, curOutFile, curErrFile, &pid);
argv[i] = oldName;
if (result != TCL_OK) {
goto error;
}
Tcl_DStringFree(&execBuffer);
pidPtr[numPids] = pid;
numPids++;
/*
* Close off our copies of file descriptors that were set up for
* this child, then set up the input for the next child.
*/
if ((curInFile != NULL) && (curInFile != inputFile)) {
TclpCloseFile(curInFile);
}
curInFile = pipeIn;
pipeIn = NULL;
if ((curOutFile != NULL) && (curOutFile != outputFile)) {
TclpCloseFile(curOutFile);
}
curOutFile = NULL;
}
*pidArrayPtr = pidPtr;
/*
* All done. Cleanup open files lying around and then return.
*/
cleanup:
Tcl_DStringFree(&execBuffer);
if (inputClose) {
TclpCloseFile(inputFile);
} else if (inputRelease) {
TclpReleaseFile(inputFile);
}
if (outputClose) {
TclpCloseFile(outputFile);
} else if (outputRelease) {
TclpReleaseFile(outputFile);
}
if (errorClose) {
TclpCloseFile(errorFile);
} else if (errorRelease) {
TclpReleaseFile(errorFile);
}
return numPids;
/*
* An error occurred. There could have been extra files open, such
* as pipes between children. Clean them all up. Detach any child
* processes that have been created.
*/
error:
if (pipeIn != NULL) {
TclpCloseFile(pipeIn);
}
if ((curOutFile != NULL) && (curOutFile != outputFile)) {
TclpCloseFile(curOutFile);
}
if ((curInFile != NULL) && (curInFile != inputFile)) {
TclpCloseFile(curInFile);
}
if ((inPipePtr != NULL) && (*inPipePtr != NULL)) {
TclpCloseFile(*inPipePtr);
*inPipePtr = NULL;
}
if ((outPipePtr != NULL) && (*outPipePtr != NULL)) {
TclpCloseFile(*outPipePtr);
*outPipePtr = NULL;
}
if ((errFilePtr != NULL) && (*errFilePtr != NULL)) {
TclpCloseFile(*errFilePtr);
*errFilePtr = NULL;
}
if (pidPtr != NULL) {
for (i = 0; i < numPids; i++) {
if (pidPtr[i] != (Tcl_Pid) -1) {
Tcl_DetachPids(1, &pidPtr[i]);
}
}
ckfree((char *) pidPtr);
}
numPids = -1;
goto cleanup;
}
/*
*----------------------------------------------------------------------
*
* Tcl_OpenCommandChannel --
*
* Opens an I/O channel to one or more subprocesses specified
* by argc and argv. The flags argument determines the
* disposition of the stdio handles. If the TCL_STDIN flag is
* set then the standard input for the first subprocess will
* be tied to the channel: writing to the channel will provide
* input to the subprocess. If TCL_STDIN is not set, then
* standard input for the first subprocess will be the same as
* this application's standard input. If TCL_STDOUT is set then
* standard output from the last subprocess can be read from the
* channel; otherwise it goes to this application's standard
* output. If TCL_STDERR is set, standard error output for all
* subprocesses is returned to the channel and results in an error
* when the channel is closed; otherwise it goes to this
* application's standard error. If TCL_ENFORCE_MODE is not set,
* then argc and argv can redirect the stdio handles to override
* TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it
* is an error for argc and argv to override stdio channels for
* which TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set.
*
* Results:
* A new command channel, or NULL on failure with an error
* message left in interp.
*
* Side effects:
* Creates processes, opens pipes.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_OpenCommandChannel(interp, argc, argv, flags)
Tcl_Interp *interp; /* Interpreter for error reporting. Can
* NOT be NULL. */
int argc; /* How many arguments. */
CONST char **argv; /* Array of arguments for command pipe. */
int flags; /* Or'ed combination of TCL_STDIN, TCL_STDOUT,
* TCL_STDERR, and TCL_ENFORCE_MODE. */
{
TclFile *inPipePtr, *outPipePtr, *errFilePtr;
TclFile inPipe, outPipe, errFile;
int numPids;
Tcl_Pid *pidPtr;
Tcl_Channel channel;
inPipe = outPipe = errFile = NULL;
inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL;
outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL;
errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL;
numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr,
outPipePtr, errFilePtr);
if (numPids < 0) {
goto error;
}
/*
* Verify that the pipes that were created satisfy the
* readable/writable constraints.
*/
if (flags & TCL_ENFORCE_MODE) {
if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
Tcl_AppendResult(interp, "can't read output from command:",
" standard output was redirected", (char *) NULL);
goto error;
}
if ((flags & TCL_STDIN) && (inPipe == NULL)) {
Tcl_AppendResult(interp, "can't write input to command:",
" standard input was redirected", (char *) NULL);
goto error;
}
}
channel = TclpCreateCommandChannel(outPipe, inPipe, errFile,
numPids, pidPtr);
if (channel == (Tcl_Channel) NULL) {
Tcl_AppendResult(interp, "pipe for command could not be created",
(char *) NULL);
goto error;
}
return channel;
error:
if (numPids > 0) {
Tcl_DetachPids(numPids, pidPtr);
ckfree((char *) pidPtr);
}
if (inPipe != NULL) {
TclpCloseFile(inPipe);
}
if (outPipe != NULL) {
TclpCloseFile(outPipe);
}
if (errFile != NULL) {
TclpCloseFile(errFile);
}
return NULL;
}
tcl8.4.20/generic/tclMain.c 0000644 0036047 0045461 00000046224 12052456744 014075 0 ustar dgp 771div /*
* tclMain.c --
*
* Main program for Tcl shells and other Tcl-based applications.
*
* Copyright (c) 1988-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 2000 Ajuba Solutions.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tcl.h"
#include "tclInt.h"
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLEXPORT
/*
* Declarations for various library procedures and variables (don't want
* to include tclPort.h here, because people might copy this file out of
* the Tcl source directory to make their own modified versions).
*/
extern int isatty _ANSI_ARGS_((int fd));
static Tcl_Obj *tclStartupScriptPath = NULL;
static Tcl_MainLoopProc *mainLoopProc = NULL;
/*
* Structure definition for information used to keep the state of
* an interactive command processor that reads lines from standard
* input and writes prompts and results to standard output.
*/
typedef enum {
PROMPT_NONE, /* Print no prompt */
PROMPT_START, /* Print prompt for command start */
PROMPT_CONTINUE /* Print prompt for command continuation */
} PromptType;
typedef struct InteractiveState {
Tcl_Channel input; /* The standard input channel from which
* lines are read. */
int tty; /* Non-zero means standard input is a
* terminal-like device. Zero means it's
* a file. */
Tcl_Obj *commandPtr; /* Used to assemble lines of input into
* Tcl commands. */
PromptType prompt; /* Next prompt to print */
Tcl_Interp *interp; /* Interpreter that evaluates interactive
* commands. */
} InteractiveState;
/*
* Forward declarations for procedures defined later in this file.
*/
static void Prompt _ANSI_ARGS_((Tcl_Interp *interp,
PromptType *promptPtr));
static void StdinProc _ANSI_ARGS_((ClientData clientData,
int mask));
/*
*----------------------------------------------------------------------
*
* TclSetStartupScriptPath --
*
* Primes the startup script VFS path, used to override the
* command line processing.
*
* Results:
* None.
*
* Side effects:
* This procedure initializes the VFS path of the Tcl script to
* run at startup.
*
*----------------------------------------------------------------------
*/
void TclSetStartupScriptPath(pathPtr)
Tcl_Obj *pathPtr;
{
if (tclStartupScriptPath != NULL) {
Tcl_DecrRefCount(tclStartupScriptPath);
}
tclStartupScriptPath = pathPtr;
if (tclStartupScriptPath != NULL) {
Tcl_IncrRefCount(tclStartupScriptPath);
}
}
/*
*----------------------------------------------------------------------
*
* TclGetStartupScriptPath --
*
* Gets the startup script VFS path, used to override the
* command line processing.
*
* Results:
* The startup script VFS path, NULL if none has been set.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *TclGetStartupScriptPath()
{
return tclStartupScriptPath;
}
/*
*----------------------------------------------------------------------
*
* TclSetStartupScriptFileName --
*
* Primes the startup script file name, used to override the
* command line processing.
*
* Results:
* None.
*
* Side effects:
* This procedure initializes the file name of the Tcl script to
* run at startup.
*
*----------------------------------------------------------------------
*/
void TclSetStartupScriptFileName(fileName)
CONST char *fileName;
{
Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
TclSetStartupScriptPath(pathPtr);
}
/*
*----------------------------------------------------------------------
*
* TclGetStartupScriptFileName --
*
* Gets the startup script file name, used to override the
* command line processing.
*
* Results:
* The startup script file name, NULL if none has been set.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char *TclGetStartupScriptFileName()
{
Tcl_Obj *pathPtr = TclGetStartupScriptPath();
if (pathPtr == NULL) {
return NULL;
}
return Tcl_GetString(pathPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Main --
*
* Main program for tclsh and most other Tcl-based applications.
*
* Results:
* None. This procedure never returns (it exits the process when
* it's done).
*
* Side effects:
* This procedure initializes the Tcl world and then starts
* interpreting commands; almost anything could happen, depending
* on the script being interpreted.
*
*----------------------------------------------------------------------
*/
void
Tcl_Main(argc, argv, appInitProc)
int argc; /* Number of arguments. */
char **argv; /* Array of argument strings. */
Tcl_AppInitProc *appInitProc;
/* Application-specific initialization
* procedure to call after most
* initialization but before starting to
* execute commands. */
{
Tcl_Obj *resultPtr, *argvPtr, *commandPtr = NULL;
PromptType prompt = PROMPT_START;
int code, length, tty, exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
Tcl_Interp *interp;
Tcl_DString appName;
Tcl_Obj *objPtr;
Tcl_FindExecutable(argv[0]);
interp = Tcl_CreateInterp();
Tcl_InitMemory(interp);
/*
* Make command-line arguments available in the Tcl variables "argc"
* and "argv". If the first argument doesn't start with a "-" then
* strip it off and use it as the name of a script file to process.
*/
if (TclGetStartupScriptPath() == NULL) {
if ((argc > 1) && (argv[1][0] != '-')) {
TclSetStartupScriptFileName(argv[1]);
argc--;
argv++;
}
}
if (TclGetStartupScriptPath() == NULL) {
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName);
} else {
TclSetStartupScriptFileName(Tcl_ExternalToUtfDString(NULL,
TclGetStartupScriptFileName(), -1, &appName));
}
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&appName);
argc--;
argv++;
objPtr = Tcl_NewIntObj(argc);
Tcl_IncrRefCount(objPtr);
Tcl_SetVar2Ex(interp, "argc", NULL, objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_DString ds;
Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj(
Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
}
Tcl_IncrRefCount(argvPtr);
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(argvPtr);
/*
* Set the "tcl_interactive" variable.
*/
tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive",
((TclGetStartupScriptPath() == NULL) && tty) ? "1" : "0",
TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve((ClientData) interp);
if ((*appInitProc)(interp) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_WriteChars(errChannel,
"application-specific initialization failed: ", -1);
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
}
if (Tcl_InterpDeleted(interp)) {
goto done;
}
/*
* If a script file was specified then just source that file
* and quit.
*/
if (TclGetStartupScriptPath() != NULL) {
code = Tcl_FSEvalFile(interp, TclGetStartupScriptPath());
if (code != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
/*
* The following statement guarantees that the errorInfo
* variable is set properly.
*/
Tcl_AddErrorInfo(interp, "");
Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo",
NULL, TCL_GLOBAL_ONLY));
Tcl_WriteChars(errChannel, "\n", 1);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup
* file if the application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
/*
* Process commands from stdin until there's an end-of-file. Note
* that we need to fetch the standard channels again after every
* eval, since they may have been changed.
*/
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) {
if (mainLoopProc == NULL) {
if (tty) {
Prompt(interp, &prompt);
if (Tcl_InterpDeleted(interp)) {
break;
}
inChannel = Tcl_GetStdChannel(TCL_STDIN);
if (inChannel == (Tcl_Channel) NULL) {
break;
}
}
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(inChannel)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try
* again. This sets up a tight polling loop (since
* we have no event loop running). If this causes
* bad CPU hogging, we might try toggling the blocking
* on stdin instead.
*/
continue;
}
/*
* Either EOF, or an error on stdin; we're done
*/
break;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string.
*/
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
prompt = PROMPT_CONTINUE;
continue;
}
prompt = PROMPT_START;
code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
if (code != TCL_OK) {
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
} else if (tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
} else { /* (mainLoopProc != NULL) */
/*
* If a main loop has been defined while running interactively,
* we want to start a fileevent based prompt by establishing a
* channel handler for stdin.
*/
InteractiveState *isPtr = NULL;
if (inChannel) {
if (tty) {
Prompt(interp, &prompt);
}
isPtr = (InteractiveState *)
ckalloc((int) sizeof(InteractiveState));
isPtr->input = inChannel;
isPtr->tty = tty;
isPtr->commandPtr = commandPtr;
isPtr->prompt = prompt;
isPtr->interp = interp;
Tcl_UnlinkVar(interp, "tcl_interactive");
Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty),
TCL_LINK_BOOLEAN);
Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
(ClientData) isPtr);
}
(*mainLoopProc)();
mainLoopProc = NULL;
if (inChannel) {
tty = isPtr->tty;
Tcl_UnlinkVar(interp, "tcl_interactive");
Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty,
TCL_LINK_BOOLEAN);
prompt = isPtr->prompt;
commandPtr = isPtr->commandPtr;
if (isPtr->input != (Tcl_Channel) NULL) {
Tcl_DeleteChannelHandler(isPtr->input, StdinProc,
(ClientData) isPtr);
}
ckfree((char *)isPtr);
}
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
}
#ifdef TCL_MEM_DEBUG
/*
* This code here only for the (unsupported and deprecated)
* [checkmem] command.
*/
if (tclMemDumpFileName != NULL) {
mainLoopProc = NULL;
Tcl_DeleteInterp(interp);
}
#endif
}
done:
if ((exitCode == 0) && (mainLoopProc != NULL)) {
/*
* If everything has gone OK so far, call the main loop proc,
* if it exists. Packages (like Tk) can set it to start processing
* events at this point.
*/
(*mainLoopProc)();
mainLoopProc = NULL;
}
if (commandPtr != NULL) {
Tcl_DecrRefCount(commandPtr);
}
/*
* Rather than calling exit, invoke the "exit" command so that
* users can replace "exit" with some other command to do additional
* cleanup on exit. The Tcl_Eval call should never return.
*/
if (!Tcl_InterpDeleted(interp)) {
char buffer[TCL_INTEGER_SPACE + 5];
sprintf(buffer, "exit %d", exitCode);
Tcl_Eval(interp, buffer);
/*
* If Tcl_Eval returns, trying to eval [exit], something
* unusual is happening. Maybe interp has been deleted;
* maybe [exit] was redefined. We still want to cleanup
* and exit.
*/
if (!Tcl_InterpDeleted(interp)) {
Tcl_DeleteInterp(interp);
}
}
TclSetStartupScriptPath(NULL);
/*
* If we get here, the master interp has been deleted. Allow
* its destruction with the last matching Tcl_Release.
*/
Tcl_Release((ClientData) interp);
Tcl_Exit(exitCode);
}
/*
*---------------------------------------------------------------
*
* Tcl_SetMainLoop --
*
* Sets an alternative main loop procedure.
*
* Results:
* Returns the previously defined main loop procedure.
*
* Side effects:
* This procedure will be called before Tcl exits, allowing for
* the creation of an event loop.
*
*---------------------------------------------------------------
*/
void
Tcl_SetMainLoop(proc)
Tcl_MainLoopProc *proc;
{
mainLoopProc = proc;
}
/*
*----------------------------------------------------------------------
*
* StdinProc --
*
* This procedure is invoked by the event dispatcher whenever
* standard input becomes readable. It grabs the next line of
* input characters, adds them to a command being assembled, and
* executes the command if it's complete.
*
* Results:
* None.
*
* Side effects:
* Could be almost arbitrary, depending on the command that's
* typed.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static void
StdinProc(clientData, mask)
ClientData clientData; /* The state of interactive cmd line */
int mask; /* Not used. */
{
InteractiveState *isPtr = (InteractiveState *) clientData;
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
Tcl_Interp *interp = isPtr->interp;
int code, length;
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(chan, commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(chan)) {
return;
}
if (isPtr->tty) {
/*
* Would be better to find a way to exit the mainLoop?
* Or perhaps evaluate [exit]? Leaving as is for now due
* to compatibility concerns.
*/
Tcl_Exit(0);
}
Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr);
return;
}
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
isPtr->prompt = PROMPT_CONTINUE;
goto prompt;
}
isPtr->prompt = PROMPT_START;
/*
* Disable the stdin channel handler while evaluating the command;
* otherwise if the command re-enters the event loop we might
* process commands from stdin before the current command is
* finished. Among other things, this will trash the text of the
* command being evaluated.
*/
Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr);
code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(commandPtr);
isPtr->commandPtr = commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
if (chan != (Tcl_Channel) NULL) {
Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc,
(ClientData) isPtr);
}
if (code != TCL_OK) {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
} else if (isPtr->tty) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length >0) && (outChannel != (Tcl_Channel) NULL)) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
/*
* If a tty stdin is still around, output a prompt.
*/
prompt:
if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) {
Prompt(interp, &(isPtr->prompt));
isPtr->input = Tcl_GetStdChannel(TCL_STDIN);
}
}
/*
*----------------------------------------------------------------------
*
* Prompt --
*
* Issue a prompt on standard output, or invoke a script
* to issue the prompt.
*
* Results:
* None.
*
* Side effects:
* A prompt gets output, and a Tcl script may be evaluated
* in interp.
*
*----------------------------------------------------------------------
*/
static void
Prompt(interp, promptPtr)
Tcl_Interp *interp; /* Interpreter to use for prompting. */
PromptType *promptPtr; /* Points to type of prompt to print.
* Filled with PROMPT_NONE after a
* prompt is printed. */
{
Tcl_Obj *promptCmdPtr;
int code;
Tcl_Channel outChannel, errChannel;
if (*promptPtr == PROMPT_NONE) {
return;
}
promptCmdPtr = Tcl_GetVar2Ex(interp,
((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
NULL, TCL_GLOBAL_ONLY);
if (Tcl_InterpDeleted(interp)) {
return;
}
if (promptCmdPtr == NULL) {
defaultPrompt:
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
if ((*promptPtr == PROMPT_START)
&& (outChannel != (Tcl_Channel) NULL)) {
Tcl_WriteChars(outChannel, "% ", 2);
}
} else {
code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
goto defaultPrompt;
}
}
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_Flush(outChannel);
}
*promptPtr = PROMPT_NONE;
}
tcl8.4.20/generic/tclMath.h 0000644 0036047 0045461 00000001154 12052456744 014100 0 ustar dgp 771div /*
* tclMath.h --
*
* This file is necessary because of Metrowerks CodeWarrior Pro 1
* on the Macintosh. With 8-byte doubles turned on, the definitions of
* sin, cos, acos, etc., are screwed up. They are fine as long as
* they are used as function calls, but if the function pointers
* are passed around and used, they will crash hard on the 68K.
*
* 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.
*/
#ifndef _TCLMATH
#define _TCLMATH
#include
#endif /* _TCLMATH */
tcl8.4.20/generic/tclDTrace.d 0000644 0036047 0045461 00000012765 11737050674 014360 0 ustar dgp 771div /*
* tclDTrace.d --
*
* Tcl DTrace provider.
*
* Copyright (c) 2007 Daniel A. Steffen
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
typedef struct Tcl_Obj Tcl_Obj;
/*
* Tcl DTrace probes
*/
provider tcl {
/***************************** proc probes *****************************/
/*
* tcl*:::proc-entry probe
* triggered immediately before proc bytecode execution
* arg0: proc name (string)
* arg1: number of arguments (int)
* arg2: array of proc argument objects (Tcl_Obj**)
*/
probe proc__entry(char* name, int objc, struct Tcl_Obj **objv);
/*
* tcl*:::proc-return probe
* triggered immediately after proc bytecode execution
* arg0: proc name (string)
* arg1: return code (int)
*/
probe proc__return(char* name, int code);
/*
* tcl*:::proc-result probe
* triggered after proc-return probe and result processing
* arg0: proc name (string)
* arg1: return code (int)
* arg2: proc result (string)
* arg3: proc result object (Tcl_Obj*)
*/
probe proc__result(char* name, int code, char* result, struct Tcl_Obj *resultobj);
/*
* tcl*:::proc-args probe
* triggered before proc-entry probe, gives access to string
* representation of proc arguments
* arg0: proc name (string)
* arg1-arg9: proc arguments or NULL (strings)
*/
probe proc__args(char* name, char* arg1, char* arg2, char* arg3,
char* arg4, char* arg5, char* arg6, char* arg7, char* arg8,
char* arg9);
/***************************** cmd probes ******************************/
/*
* tcl*:::cmd-entry probe
* triggered immediately before commmand execution
* arg0: command name (string)
* arg1: number of arguments (int)
* arg2: array of command argument objects (Tcl_Obj**)
*/
probe cmd__entry(char* name, int objc, struct Tcl_Obj **objv);
/*
* tcl*:::cmd-return probe
* triggered immediately after commmand execution
* arg0: command name (string)
* arg1: return code (int)
*/
probe cmd__return(char* name, int code);
/*
* tcl*:::cmd-result probe
* triggered after cmd-return probe and result processing
* arg0: command name (string)
* arg1: return code (int)
* arg2: command result (string)
* arg3: command result object (Tcl_Obj*)
*/
probe cmd__result(char* name, int code, char* result, struct Tcl_Obj *resultobj);
/*
* tcl*:::cmd-args probe
* triggered before cmd-entry probe, gives access to string
* representation of command arguments
* arg0: command name (string)
* arg1-arg9: command arguments or NULL (strings)
*/
probe cmd__args(char* name, char* arg1, char* arg2, char* arg3,
char* arg4, char* arg5, char* arg6, char* arg7, char* arg8,
char* arg9);
/***************************** inst probes *****************************/
/*
* tcl*:::inst-start probe
* triggered immediately before execution of a bytecode
* arg0: bytecode name (string)
* arg1: depth of stack (int)
* arg2: top of stack (Tcl_Obj**)
*/
probe inst__start(char* name, int depth, struct Tcl_Obj **stack);
/*
* tcl*:::inst-done probe
* triggered immediately after execution of a bytecode
* arg0: bytecode name (string)
* arg1: depth of stack (int)
* arg2: top of stack (Tcl_Obj**)
*/
probe inst__done(char* name, int depth, struct Tcl_Obj **stack);
/***************************** obj probes ******************************/
/*
* tcl*:::obj-create probe
* triggered immediately after a new Tcl_Obj has been created
* arg0: object created (Tcl_Obj*)
*/
probe obj__create(struct Tcl_Obj* obj);
/*
* tcl*:::obj-free probe
* triggered immediately before a Tcl_Obj is freed
* arg0: object to be freed (Tcl_Obj*)
*/
probe obj__free(struct Tcl_Obj* obj);
/***************************** tcl probes ******************************/
/*
* tcl*:::tcl-probe probe
* triggered when the ::tcl::dtrace command is called
* arg0-arg9: command arguments (strings)
*/
probe tcl__probe(char* arg0, char* arg1, char* arg2, char* arg3,
char* arg4, char* arg5, char* arg6, char* arg7, char* arg8,
char* arg9);
};
/*
* Tcl types and constants for use in DTrace scripts
*/
typedef struct Tcl_ObjType {
char *name;
void *freeIntRepProc;
void *dupIntRepProc;
void *updateStringProc;
void *setFromAnyProc;
} Tcl_ObjType;
struct Tcl_Obj {
int refCount;
char *bytes;
int length;
Tcl_ObjType *typePtr;
union {
long longValue;
double doubleValue;
void *otherValuePtr;
int64_t wideValue;
struct {
void *ptr1;
void *ptr2;
} twoPtrValue;
} internalRep;
};
enum return_codes {
TCL_OK = 0,
TCL_ERROR,
TCL_RETURN,
TCL_BREAK,
TCL_CONTINUE
};
#pragma D attributes Evolving/Evolving/Common provider tcl provider
#pragma D attributes Private/Private/Common provider tcl module
#pragma D attributes Private/Private/Common provider tcl function
#pragma D attributes Evolving/Evolving/Common provider tcl name
#pragma D attributes Evolving/Evolving/Common provider tcl args
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/regex.h 0000644 0036047 0045461 00000026036 12133546537 013624 0 ustar dgp 771div #ifndef _REGEX_H_
#define _REGEX_H_ /* never again */
/*
* regular expressions
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*
*
* Prototypes etc. marked with "^" within comments get gathered up (and
* possibly edited) by the regfwd program and inserted near the bottom of
* this file.
*
* We offer the option of declaring one wide-character version of the
* RE functions as well as the char versions. To do that, define
* __REG_WIDE_T to the type of wide characters (unfortunately, there
* is no consensus that wchar_t is suitable) and __REG_WIDE_COMPILE and
* __REG_WIDE_EXEC to the names to be used for the compile and execute
* functions (suggestion: re_Xcomp and re_Xexec, where X is a letter
* suggestive of the wide type, e.g. re_ucomp and re_uexec for Unicode).
* For cranky old compilers, it may be necessary to do something like:
* #define __REG_WIDE_COMPILE(a,b,c,d) re_Xcomp(a,b,c,d)
* #define __REG_WIDE_EXEC(a,b,c,d,e,f,g) re_Xexec(a,b,c,d,e,f,g)
* rather than just #defining the names as parameterless macros.
*
* For some specialized purposes, it may be desirable to suppress the
* declarations of the "front end" functions, regcomp() and regexec(),
* or of the char versions of the compile and execute functions. To
* suppress the front-end functions, define __REG_NOFRONT. To suppress
* the char versions, define __REG_NOCHAR.
*
* The right place to do those defines (and some others you may want, see
* below) would be . If you don't have control of that file,
* the right place to add your own defines to this file is marked below.
* This is normally done automatically, by the makefile and regmkhdr, based
* on the contents of regcustom.h.
*/
/*
* voodoo for C++
*/
#ifdef __cplusplus
extern "C" {
#endif
/*
* Add your own defines, if needed, here.
*/
/*
* Location where a chunk of regcustom.h is automatically spliced into
* this file (working from its prototype, regproto.h).
*/
/* --- begin --- */
/* ensure certain things don't sneak in from system headers */
#ifdef __REG_WIDE_T
#undef __REG_WIDE_T
#endif
#ifdef __REG_WIDE_COMPILE
#undef __REG_WIDE_COMPILE
#endif
#ifdef __REG_WIDE_EXEC
#undef __REG_WIDE_EXEC
#endif
#ifdef __REG_REGOFF_T
#undef __REG_REGOFF_T
#endif
#ifdef __REG_VOID_T
#undef __REG_VOID_T
#endif
#ifdef __REG_CONST
#undef __REG_CONST
#endif
#ifdef __REG_NOFRONT
#undef __REG_NOFRONT
#endif
#ifdef __REG_NOCHAR
#undef __REG_NOCHAR
#endif
/* interface types */
#define __REG_WIDE_T Tcl_UniChar
#define __REG_REGOFF_T long /* not really right, but good enough... */
#define __REG_VOID_T VOID
#define __REG_CONST CONST
/* names and declarations */
#define __REG_WIDE_COMPILE TclReComp
#define __REG_WIDE_EXEC TclReExec
#define __REG_NOFRONT /* don't want regcomp() and regexec() */
#define __REG_NOCHAR /* or the char versions */
#define regfree TclReFree
#define regerror TclReError
/* --- end --- */
/*
* interface types etc.
*/
/*
* regoff_t has to be large enough to hold either off_t or ssize_t,
* and must be signed; it's only a guess that long is suitable, so we
* offer an override.
*/
#ifdef __REG_REGOFF_T
typedef __REG_REGOFF_T regoff_t;
#else
typedef long regoff_t;
#endif
/*
* For benefit of old compilers, we offer the option of
* overriding the `void' type used to declare nonexistent return types.
*/
#ifdef __REG_VOID_T
typedef __REG_VOID_T re_void;
#else
typedef void re_void;
#endif
/*
* Also for benefit of old compilers, can supply a macro
* which expands to a substitute for `const'.
*/
#ifndef __REG_CONST
#define __REG_CONST const
#endif
/*
* other interface types
*/
/* the biggie, a compiled RE (or rather, a front end to same) */
typedef struct {
int re_magic; /* magic number */
size_t re_nsub; /* number of subexpressions */
long re_info; /* information about RE */
# define REG_UBACKREF 000001
# define REG_ULOOKAHEAD 000002
# define REG_UBOUNDS 000004
# define REG_UBRACES 000010
# define REG_UBSALNUM 000020
# define REG_UPBOTCH 000040
# define REG_UBBS 000100
# define REG_UNONPOSIX 000200
# define REG_UUNSPEC 000400
# define REG_UUNPORT 001000
# define REG_ULOCALE 002000
# define REG_UEMPTYMATCH 004000
# define REG_UIMPOSSIBLE 010000
# define REG_USHORTEST 020000
int re_csize; /* sizeof(character) */
char *re_endp; /* backward compatibility kludge */
/* the rest is opaque pointers to hidden innards */
char *re_guts; /* `char *' is more portable than `void *' */
char *re_fns;
} regex_t;
/* result reporting (may acquire more fields later) */
typedef struct {
regoff_t rm_so; /* start of substring */
regoff_t rm_eo; /* end of substring */
} regmatch_t;
/* supplementary control and reporting */
typedef struct {
regmatch_t rm_extend; /* see REG_EXPECT */
} rm_detail_t;
/*
* compilation
^ #ifndef __REG_NOCHAR
^ int re_comp(regex_t *, __REG_CONST char *, size_t, int);
^ #endif
^ #ifndef __REG_NOFRONT
^ int regcomp(regex_t *, __REG_CONST char *, int);
^ #endif
^ #ifdef __REG_WIDE_T
^ int __REG_WIDE_COMPILE(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int);
^ #endif
*/
#define REG_BASIC 000000 /* BREs (convenience) */
#define REG_EXTENDED 000001 /* EREs */
#define REG_ADVF 000002 /* advanced features in EREs */
#define REG_ADVANCED 000003 /* AREs (which are also EREs) */
#define REG_QUOTE 000004 /* no special characters, none */
#define REG_NOSPEC REG_QUOTE /* historical synonym */
#define REG_ICASE 000010 /* ignore case */
#define REG_NOSUB 000020 /* don't care about subexpressions */
#define REG_EXPANDED 000040 /* expanded format, white space & comments */
#define REG_NLSTOP 000100 /* \n doesn't match . or [^ ] */
#define REG_NLANCH 000200 /* ^ matches after \n, $ before */
#define REG_NEWLINE 000300 /* newlines are line terminators */
#define REG_PEND 000400 /* ugh -- backward-compatibility hack */
#define REG_EXPECT 001000 /* report details on partial/limited matches */
#define REG_BOSONLY 002000 /* temporary kludge for BOS-only matches */
#define REG_DUMP 004000 /* none of your business :-) */
#define REG_FAKE 010000 /* none of your business :-) */
#define REG_PROGRESS 020000 /* none of your business :-) */
/*
* execution
^ #ifndef __REG_NOCHAR
^ int re_exec(regex_t *, __REG_CONST char *, size_t,
^ rm_detail_t *, size_t, regmatch_t [], int);
^ #endif
^ #ifndef __REG_NOFRONT
^ int regexec(regex_t *, __REG_CONST char *, size_t, regmatch_t [], int);
^ #endif
^ #ifdef __REG_WIDE_T
^ int __REG_WIDE_EXEC(regex_t *, __REG_CONST __REG_WIDE_T *, size_t,
^ rm_detail_t *, size_t, regmatch_t [], int);
^ #endif
*/
#define REG_NOTBOL 0001 /* BOS is not BOL */
#define REG_NOTEOL 0002 /* EOS is not EOL */
#define REG_STARTEND 0004 /* backward compatibility kludge */
#define REG_FTRACE 0010 /* none of your business */
#define REG_MTRACE 0020 /* none of your business */
#define REG_SMALL 0040 /* none of your business */
/*
* misc generics (may be more functions here eventually)
^ re_void regfree(regex_t *);
*/
/*
* error reporting
* Be careful if modifying the list of error codes -- the table used by
* regerror() is generated automatically from this file!
*
* Note that there is no wide-char variant of regerror at this time; what
* kind of character is used for error reports is independent of what kind
* is used in matching.
*
^ extern size_t regerror(int, __REG_CONST regex_t *, char *, size_t);
*/
#define REG_OKAY 0 /* no errors detected */
#define REG_NOMATCH 1 /* failed to match */
#define REG_BADPAT 2 /* invalid regexp */
#define REG_ECOLLATE 3 /* invalid collating element */
#define REG_ECTYPE 4 /* invalid character class */
#define REG_EESCAPE 5 /* invalid escape \ sequence */
#define REG_ESUBREG 6 /* invalid backreference number */
#define REG_EBRACK 7 /* brackets [] not balanced */
#define REG_EPAREN 8 /* parentheses () not balanced */
#define REG_EBRACE 9 /* braces {} not balanced */
#define REG_BADBR 10 /* invalid repetition count(s) */
#define REG_ERANGE 11 /* invalid character range */
#define REG_ESPACE 12 /* out of memory */
#define REG_BADRPT 13 /* quantifier operand invalid */
#define REG_ASSERT 15 /* "can't happen" -- you found a bug */
#define REG_INVARG 16 /* invalid argument to regex function */
#define REG_MIXED 17 /* character widths of regex and string differ */
#define REG_BADOPT 18 /* invalid embedded option */
#define REG_ETOOBIG 19 /* nfa has too many states */
#define REG_ECOLORS 20 /* too many colors */
/* two specials for debugging and testing */
#define REG_ATOI 101 /* convert error-code name to number */
#define REG_ITOA 102 /* convert error-code number to name */
/*
* the prototypes, as possibly munched by regfwd
*/
/* =====^!^===== begin forwards =====^!^===== */
/* automatically gathered by fwd; do not hand-edit */
/* === regproto.h === */
#ifndef __REG_NOCHAR
int re_comp _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, int));
#endif
#ifndef __REG_NOFRONT
int regcomp _ANSI_ARGS_((regex_t *, __REG_CONST char *, int));
#endif
#ifdef __REG_WIDE_T
int __REG_WIDE_COMPILE _ANSI_ARGS_((regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int));
#endif
#ifndef __REG_NOCHAR
int re_exec _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, rm_detail_t *, size_t, regmatch_t [], int));
#endif
#ifndef __REG_NOFRONT
int regexec _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, regmatch_t [], int));
#endif
#ifdef __REG_WIDE_T
int __REG_WIDE_EXEC _ANSI_ARGS_((regex_t *, __REG_CONST __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int));
#endif
re_void regfree _ANSI_ARGS_((regex_t *));
extern size_t regerror _ANSI_ARGS_((int, __REG_CONST regex_t *, char *, size_t));
/* automatically gathered by fwd; do not hand-edit */
/* =====^!^===== end forwards =====^!^===== */
/*
* more C++ voodoo
*/
#ifdef __cplusplus
}
#endif
#endif
tcl8.4.20/generic/tclClock.c 0000644 0036047 0045461 00000023434 11737050674 014243 0 ustar dgp 771div /*
* tclClock.c --
*
* Contains the time and date related commands. This code
* is derived from the time and date facilities of TclX,
* by Mark Diekhans and Karl Lehenbauer.
*
* Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tcl.h"
#include "tclInt.h"
#include "tclPort.h"
/*
* The date parsing stuff uses lexx and has tons o statics.
*/
TCL_DECLARE_MUTEX(clockMutex)
/*
* Function prototypes for local procedures in this file:
*/
static int FormatClock _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_WideInt clockVal, int useGMT,
char *format));
/*
*-------------------------------------------------------------------------
*
* Tcl_ClockObjCmd --
*
* This procedure is invoked to process the "clock" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-------------------------------------------------------------------------
*/
int
Tcl_ClockObjCmd (client, interp, objc, objv)
ClientData client; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument values. */
{
Tcl_Obj *resultPtr;
int index;
Tcl_Obj *CONST *objPtr;
int useGMT = 0;
char *format = "%a %b %d %X %Z %Y";
int dummy;
Tcl_WideInt baseClock, clockVal;
long zone;
Tcl_Obj *baseObjPtr = NULL;
char *scanStr;
int n;
static CONST char *switches[] =
{"clicks", "format", "scan", "seconds", (char *) NULL};
enum command { COMMAND_CLICKS, COMMAND_FORMAT, COMMAND_SCAN,
COMMAND_SECONDS
};
static CONST char *formatSwitches[] = {"-format", "-gmt", (char *) NULL};
static CONST char *scanSwitches[] = {"-base", "-gmt", (char *) NULL};
resultPtr = Tcl_GetObjResult(interp);
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], switches, "option", 0, &index)
!= TCL_OK) {
return TCL_ERROR;
}
switch ((enum command) index) {
case COMMAND_CLICKS: { /* clicks */
int forceMilli = 0;
if (objc == 3) {
format = Tcl_GetStringFromObj(objv[2], &n);
if ( ( n >= 2 )
&& ( strncmp( format, "-milliseconds",
(unsigned int) n) == 0 ) ) {
forceMilli = 1;
} else {
Tcl_AppendStringsToObj(resultPtr,
"bad switch \"", format,
"\": must be -milliseconds", (char *) NULL);
return TCL_ERROR;
}
} else if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?-milliseconds?");
return TCL_ERROR;
}
if (forceMilli) {
/*
* We can enforce at least millisecond granularity
*/
Tcl_Time time;
Tcl_GetTime(&time);
Tcl_SetLongObj(resultPtr,
(long) (time.sec*1000 + time.usec/1000));
} else {
Tcl_SetLongObj(resultPtr, (long) TclpGetClicks());
}
return TCL_OK;
}
case COMMAND_FORMAT: /* format */
if ((objc < 3) || (objc > 7)) {
wrongFmtArgs:
Tcl_WrongNumArgs(interp, 2, objv,
"clockval ?-format string? ?-gmt boolean?");
return TCL_ERROR;
}
if (Tcl_GetWideIntFromObj(interp, objv[2], &clockVal)
!= TCL_OK) {
return TCL_ERROR;
}
objPtr = objv+3;
objc -= 3;
while (objc > 1) {
if (Tcl_GetIndexFromObj(interp, objPtr[0], formatSwitches,
"switch", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case 0: /* -format */
format = Tcl_GetStringFromObj(objPtr[1], &dummy);
break;
case 1: /* -gmt */
if (Tcl_GetBooleanFromObj(interp, objPtr[1],
&useGMT) != TCL_OK) {
return TCL_ERROR;
}
break;
}
objPtr += 2;
objc -= 2;
}
if (objc != 0) {
goto wrongFmtArgs;
}
return FormatClock(interp, clockVal, useGMT,
format);
case COMMAND_SCAN: /* scan */
if ((objc < 3) || (objc > 7)) {
wrongScanArgs:
Tcl_WrongNumArgs(interp, 2, objv,
"dateString ?-base clockValue? ?-gmt boolean?");
return TCL_ERROR;
}
objPtr = objv+3;
objc -= 3;
while (objc > 1) {
if (Tcl_GetIndexFromObj(interp, objPtr[0], scanSwitches,
"switch", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case 0: /* -base */
baseObjPtr = objPtr[1];
break;
case 1: /* -gmt */
if (Tcl_GetBooleanFromObj(interp, objPtr[1],
&useGMT) != TCL_OK) {
return TCL_ERROR;
}
break;
}
objPtr += 2;
objc -= 2;
}
if (objc != 0) {
goto wrongScanArgs;
}
if (baseObjPtr != NULL) {
if (Tcl_GetWideIntFromObj(interp, baseObjPtr,
&baseClock) != TCL_OK) {
return TCL_ERROR;
}
} else {
baseClock = TclpGetSeconds();
}
if (useGMT) {
zone = -50000; /* Force GMT */
} else {
zone = TclpGetTimeZone(baseClock);
}
scanStr = Tcl_GetStringFromObj(objv[2], &dummy);
Tcl_MutexLock(&clockMutex);
if (TclGetDate(scanStr, baseClock, zone,
&clockVal) < 0) {
Tcl_MutexUnlock(&clockMutex);
Tcl_AppendStringsToObj(resultPtr,
"unable to convert date-time string \"",
scanStr, "\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_MutexUnlock(&clockMutex);
Tcl_SetWideIntObj(resultPtr, clockVal);
return TCL_OK;
case COMMAND_SECONDS: /* seconds */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetLongObj(resultPtr, (long) TclpGetSeconds());
return TCL_OK;
default:
return TCL_ERROR; /* Should never be reached. */
}
}
/*
*-----------------------------------------------------------------------------
*
* FormatClock --
*
* Formats a time value based on seconds into a human readable
* string.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
static int
FormatClock(interp, clockVal, useGMT, format)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_WideInt clockVal; /* Time in seconds. */
int useGMT; /* Boolean */
char *format; /* Format string */
{
struct tm *timeDataPtr;
Tcl_DString buffer, uniBuffer;
int bufSize;
char *p;
int result;
time_t tclockVal;
#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
TIMEZONE_t savedTimeZone = 0; /* lint. */
char *savedTZEnv = NULL; /* lint. */
#endif
#ifdef HAVE_TZSET
/*
* Some systems forgot to call tzset in localtime, make sure its done.
*/
static int calledTzset = 0;
Tcl_MutexLock(&clockMutex);
if (!calledTzset) {
tzset();
calledTzset = 1;
}
Tcl_MutexUnlock(&clockMutex);
#endif
/*
* If the user gave us -format "", just return now
*/
if (*format == '\0') {
return TCL_OK;
}
#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
/*
* This is a kludge for systems not having the timezone string in
* struct tm. No matter what was specified, they use the local
* timezone string. Since this kludge requires fiddling with the
* TZ environment variable, it will mess up if done on multiple
* threads at once. Protect it with a the clock mutex.
*/
Tcl_MutexLock( &clockMutex );
if (useGMT) {
CONST char *varValue;
varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
if (varValue != NULL) {
savedTZEnv = strcpy(ckalloc(strlen(varValue) + 1), varValue);
} else {
savedTZEnv = NULL;
}
Tcl_SetVar2(interp, "env", "TZ", "GMT0", TCL_GLOBAL_ONLY);
savedTimeZone = timezone;
timezone = 0;
tzset();
}
#endif
tclockVal = (time_t) clockVal;
timeDataPtr = TclpGetDate((TclpTime_t) &tclockVal, useGMT);
/*
* Make a guess at the upper limit on the substituted string size
* based on the number of percents in the string.
*/
for (bufSize = 1, p = format; *p != '\0'; p++) {
if (*p == '%') {
bufSize += 40;
if (p[1] == 'c') {
bufSize += 226;
}
} else {
bufSize++;
}
}
Tcl_DStringInit(&uniBuffer);
Tcl_UtfToExternalDString(NULL, format, -1, &uniBuffer);
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, bufSize);
/* If we haven't locked the clock mutex up above, lock it now. */
#if defined(HAVE_TM_ZONE) || defined(WIN32)
Tcl_MutexLock(&clockMutex);
#endif
result = TclpStrftime(buffer.string, (unsigned int) bufSize,
Tcl_DStringValue(&uniBuffer), timeDataPtr, useGMT);
#if defined(HAVE_TM_ZONE) || defined(WIN32)
Tcl_MutexUnlock(&clockMutex);
#endif
Tcl_DStringFree(&uniBuffer);
#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
if (useGMT) {
if (savedTZEnv != NULL) {
Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY);
ckfree(savedTZEnv);
} else {
Tcl_UnsetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
}
timezone = savedTimeZone;
tzset();
}
Tcl_MutexUnlock( &clockMutex );
#endif
if (result == 0) {
/*
* A zero return is the error case (can also mean the strftime
* didn't get enough space to write into). We know it doesn't
* mean that we wrote zero chars because the check for an empty
* format string is above.
*/
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad format string \"", format, "\"", (char *) NULL);
return TCL_ERROR;
}
/*
* Convert the time to UTF from external encoding [Bug: 3345]
*/
Tcl_DStringInit(&uniBuffer);
Tcl_ExternalToUtfDString(NULL, buffer.string, -1, &uniBuffer);
Tcl_SetStringObj(Tcl_GetObjResult(interp), uniBuffer.string, -1);
Tcl_DStringFree(&uniBuffer);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
tcl8.4.20/generic/regguts.h 0000644 0036047 0045461 00000030672 12151137515 014163 0 ustar dgp 771div /*
* Internal interface definitions, etc., for the reg package
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
/*
* Environmental customization. It should not (I hope) be necessary to
* alter the file you are now reading -- regcustom.h should handle it all,
* given care here and elsewhere.
*/
#include "regcustom.h"
/*
* Things that regcustom.h might override.
*/
/* standard header files (NULL is a reasonable indicator for them) */
#ifndef NULL
#include
#include
#include
#include
#include
#endif
/* assertions */
#ifndef assert
# ifndef REG_DEBUG
# ifndef NDEBUG
# define NDEBUG /* no assertions */
# endif
# endif
#include
#endif
/* voids */
#ifndef VOID
#define VOID void /* for function return values */
#endif
#ifndef DISCARD
#define DISCARD VOID /* for throwing values away */
#endif
#ifndef PVOID
#define PVOID VOID * /* generic pointer */
#endif
#ifndef VS
#define VS(x) ((PVOID)(x)) /* cast something to generic ptr */
#endif
#ifndef NOPARMS
#define NOPARMS VOID /* for empty parm lists */
#endif
/* const */
#ifndef CONST
#define CONST const /* for old compilers, might be empty */
#endif
/* function-pointer declarator */
#ifndef FUNCPTR
#if __STDC__ >= 1
#define FUNCPTR(name, args) (*name)args
#else
#define FUNCPTR(name, args) (*name)()
#endif
#endif
/* memory allocation */
#ifndef MALLOC
#define MALLOC(n) malloc(n)
#endif
#ifndef REALLOC
#define REALLOC(p, n) realloc(VS(p), n)
#endif
#ifndef FREE
#define FREE(p) free(VS(p))
#endif
/* want size of a char in bits, and max value in bounded quantifiers */
#ifndef CHAR_BIT
#include
#endif
#ifndef _POSIX2_RE_DUP_MAX
#define _POSIX2_RE_DUP_MAX 255 /* normally from */
#endif
/*
* misc
*/
#define NOTREACHED 0
#define xxx 1
#define DUPMAX _POSIX2_RE_DUP_MAX
#define INFINITY (DUPMAX+1)
#define REMAGIC 0xfed7 /* magic number for main struct */
/*
* debugging facilities
*/
#ifdef REG_DEBUG
/* FDEBUG does finite-state tracing */
#define FDEBUG(arglist) { if (v->eflags®_FTRACE) printf arglist; }
/* MDEBUG does higher-level tracing */
#define MDEBUG(arglist) { if (v->eflags®_MTRACE) printf arglist; }
#else
#define FDEBUG(arglist) {}
#define MDEBUG(arglist) {}
#endif
/*
* bitmap manipulation
*/
#define UBITS (CHAR_BIT * sizeof(unsigned))
#define BSET(uv, sn) ((uv)[(sn)/UBITS] |= (unsigned)1 << ((sn)%UBITS))
#define ISBSET(uv, sn) ((uv)[(sn)/UBITS] & ((unsigned)1 << ((sn)%UBITS)))
/*
* We dissect a chr into byts for colormap table indexing. Here we define
* a byt, which will be the same as a byte on most machines... The exact
* size of a byt is not critical, but about 8 bits is good, and extraction
* of 8-bit chunks is sometimes especially fast.
*/
#ifndef BYTBITS
#define BYTBITS 8 /* bits in a byt */
#endif
#define BYTTAB (1<flags&FREECOL)
union tree *block; /* block of solid color, if any */
};
/* the color map itself */
struct colormap {
int magic;
# define CMMAGIC 0x876
struct vars *v; /* for compile error reporting */
size_t ncds; /* number of colordescs */
size_t max; /* highest in use */
color free; /* beginning of free chain (if non-0) */
struct colordesc *cd;
# define CDEND(cm) (&(cm)->cd[(cm)->max + 1])
# define NINLINECDS ((size_t)10)
struct colordesc cdspace[NINLINECDS];
union tree tree[NBYTS]; /* tree top, plus fill blocks */
};
/* optimization magic to do fast chr->color mapping */
#define B0(c) ((c) & BYTMASK)
#define B1(c) (((c)>>BYTBITS) & BYTMASK)
#define B2(c) (((c)>>(2*BYTBITS)) & BYTMASK)
#define B3(c) (((c)>>(3*BYTBITS)) & BYTMASK)
#if NBYTS == 1
#define GETCOLOR(cm, c) ((cm)->tree->tcolor[B0(c)])
#endif
/* beware, for NBYTS>1, GETCOLOR() is unsafe -- 2nd arg used repeatedly */
#if NBYTS == 2
#define GETCOLOR(cm, c) ((cm)->tree->tptr[B1(c)]->tcolor[B0(c)])
#endif
#if NBYTS == 4
#define GETCOLOR(cm, c) ((cm)->tree->tptr[B3(c)]->tptr[B2(c)]->tptr[B1(c)]->tcolor[B0(c)])
#endif
/*
* Interface definitions for locale-interface functions in locale.c.
* Multi-character collating elements (MCCEs) cause most of the trouble.
*/
struct cvec {
int nchrs; /* number of chrs */
int chrspace; /* number of chrs possible */
chr *chrs; /* pointer to vector of chrs */
int nranges; /* number of ranges (chr pairs) */
int rangespace; /* number of chrs possible */
chr *ranges; /* pointer to vector of chr pairs */
int nmcces; /* number of MCCEs */
int mccespace; /* number of MCCEs possible */
int nmccechrs; /* number of chrs used for MCCEs */
chr *mcces[1]; /* pointers to 0-terminated MCCEs */
/* and both batches of chrs are on the end */
};
/* caution: this value cannot be changed easily */
#define MAXMCCE 2 /* length of longest MCCE */
/*
* definitions for NFA internal representation
*
* Having a "from" pointer within each arc may seem redundant, but it
* saves a lot of hassle.
*/
struct state;
struct arc {
int type;
# define ARCFREE '\0'
color co;
struct state *from; /* where it's from (and contained within) */
struct state *to; /* where it's to */
struct arc *outchain; /* *from's outs chain or free chain */
# define freechain outchain
struct arc *inchain; /* *to's ins chain */
struct arc *colorchain; /* color's arc chain */
struct arc *colorchain_rev; /* back-link in color's arc chain */
};
struct arcbatch { /* for bulk allocation of arcs */
struct arcbatch *next;
# define ABSIZE 10
struct arc a[ABSIZE];
};
struct state {
int no;
# define FREESTATE (-1)
char flag; /* marks special states */
int nins; /* number of inarcs */
struct arc *ins; /* chain of inarcs */
int nouts; /* number of outarcs */
struct arc *outs; /* chain of outarcs */
struct arc *free; /* chain of free arcs */
struct state *tmp; /* temporary for traversal algorithms */
struct state *next; /* chain for traversing all */
struct state *prev; /* back chain */
struct arcbatch oas; /* first arcbatch, avoid malloc in easy case */
int noas; /* number of arcs used in first arcbatch */
};
struct nfa {
struct state *pre; /* pre-initial state */
struct state *init; /* initial state */
struct state *final; /* final state */
struct state *post; /* post-final state */
int nstates; /* for numbering states */
struct state *states; /* state-chain header */
struct state *slast; /* tail of the chain */
struct state *free; /* free list */
struct colormap *cm; /* the color map */
color bos[2]; /* colors, if any, assigned to BOS and BOL */
color eos[2]; /* colors, if any, assigned to EOS and EOL */
size_t size; /* current NFA size; differs from nstates as
* it will be incremented by its children */
struct vars *v; /* simplifies compile error reporting */
struct nfa *parent; /* parent NFA, if any */
};
/*
* definitions for compacted NFA
*/
struct carc {
color co; /* COLORLESS is list terminator */
int to; /* state number */
};
struct cnfa {
int nstates; /* number of states */
int ncolors; /* number of colors */
int flags;
# define HASLACONS 01 /* uses lookahead constraints */
int pre; /* setup state number */
int post; /* teardown state number */
color bos[2]; /* colors, if any, assigned to BOS and BOL */
color eos[2]; /* colors, if any, assigned to EOS and EOL */
struct carc **states; /* vector of pointers to outarc lists */
struct carc *arcs; /* the area for the lists */
};
#define ZAPCNFA(cnfa) ((cnfa).nstates = 0)
#define NULLCNFA(cnfa) ((cnfa).nstates == 0)
/* Used to limit the maximum NFA size */
#ifndef REG_MAX_STATES
#define REG_MAX_STATES 100000
#endif
/*
* subexpression tree
*/
struct subre {
char op; /* '|', '.' (concat), 'b' (backref), '(', '=' */
char flags;
# define LONGER 01 /* prefers longer match */
# define SHORTER 02 /* prefers shorter match */
# define MIXED 04 /* mixed preference below */
# define CAP 010 /* capturing parens below */
# define BACKR 020 /* back reference below */
# define INUSE 0100 /* in use in final tree */
# define NOPROP 03 /* bits which may not propagate up */
# define LMIX(f) ((f)<<2) /* LONGER -> MIXED */
# define SMIX(f) ((f)<<1) /* SHORTER -> MIXED */
# define UP(f) (((f)&~NOPROP) | (LMIX(f) & SMIX(f) & MIXED))
# define MESSY(f) ((f)&(MIXED|CAP|BACKR))
# define PREF(f) ((f)&NOPROP)
# define PREF2(f1, f2) ((PREF(f1) != 0) ? PREF(f1) : PREF(f2))
# define COMBINE(f1, f2) (UP((f1)|(f2)) | PREF2(f1, f2))
short retry; /* index into retry memory */
int subno; /* subexpression number (for 'b' and '(') */
short min; /* min repetitions, for backref only */
short max; /* max repetitions, for backref only */
struct subre *left; /* left child, if any (also freelist chain) */
struct subre *right; /* right child, if any */
struct state *begin; /* outarcs from here... */
struct state *end; /* ...ending in inarcs here */
struct cnfa cnfa; /* compacted NFA, if any */
struct subre *chain; /* for bookkeeping and error cleanup */
};
/*
* table of function pointers for generic manipulation functions
* A regex_t's re_fns points to one of these.
*/
struct fns {
VOID FUNCPTR(free, (regex_t *));
};
/*
* the insides of a regex_t, hidden behind a void *
*/
struct guts {
int magic;
# define GUTSMAGIC 0xfed9
int cflags; /* copy of compile flags */
long info; /* copy of re_info */
size_t nsub; /* copy of re_nsub */
struct subre *tree;
struct cnfa search; /* for fast preliminary search */
int ntree;
struct colormap cmap;
int FUNCPTR(compare, (CONST chr *, CONST chr *, size_t));
struct subre *lacons; /* lookahead-constraint vector */
int nlacons; /* size of lacons */
};
tcl8.4.20/generic/tclHash.c 0000644 0036047 0045461 00000077716 11737050674 014107 0 ustar dgp 771div /*
* tclHash.c --
*
* Implementation of in-memory hash tables for Tcl and Tcl-based
* applications.
*
* 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.
*/
#include "tclInt.h"
/*
* Prevent macros from clashing with function definitions.
*/
#if TCL_PRESERVE_BINARY_COMPATABILITY
# undef Tcl_FindHashEntry
# undef Tcl_CreateHashEntry
#endif
/*
* When there are this many entries per bucket, on average, rebuild
* the hash table to make it larger.
*/
#define REBUILD_MULTIPLIER 3
/*
* The following macro takes a preliminary integer hash value and
* produces an index into a hash tables bucket list. The idea is
* to make it so that preliminary values that are arbitrarily similar
* will end up in different buckets. The hash function was taken
* from a random-number generator.
*/
#define RANDOM_INDEX(tablePtr, i) \
(((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask)
/*
* Prototypes for the array hash key methods.
*/
static Tcl_HashEntry * AllocArrayEntry _ANSI_ARGS_((
Tcl_HashTable *tablePtr,
VOID *keyPtr));
static int CompareArrayKeys _ANSI_ARGS_((
VOID *keyPtr, Tcl_HashEntry *hPtr));
static unsigned int HashArrayKey _ANSI_ARGS_((
Tcl_HashTable *tablePtr,
VOID *keyPtr));
/*
* Prototypes for the one word hash key methods.
*/
#if 0
static Tcl_HashEntry * AllocOneWordEntry _ANSI_ARGS_((
Tcl_HashTable *tablePtr,
VOID *keyPtr));
static int CompareOneWordKeys _ANSI_ARGS_((
VOID *keyPtr, Tcl_HashEntry *hPtr));
static unsigned int HashOneWordKey _ANSI_ARGS_((
Tcl_HashTable *tablePtr,
VOID *keyPtr));
#endif
/*
* Prototypes for the string hash key methods.
*/
static Tcl_HashEntry * AllocStringEntry _ANSI_ARGS_((
Tcl_HashTable *tablePtr,
VOID *keyPtr));
static int CompareStringKeys _ANSI_ARGS_((
VOID *keyPtr, Tcl_HashEntry *hPtr));
static unsigned int HashStringKey _ANSI_ARGS_((
Tcl_HashTable *tablePtr,
VOID *keyPtr));
/*
* Procedure prototypes for static procedures in this file:
*/
#if TCL_PRESERVE_BINARY_COMPATABILITY
static Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
CONST char *key));
static Tcl_HashEntry * BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
CONST char *key, int *newPtr));
static Tcl_HashEntry * FindHashEntry _ANSI_ARGS_((Tcl_HashTable *tablePtr,
CONST char *key));
static Tcl_HashEntry * CreateHashEntry _ANSI_ARGS_((Tcl_HashTable *tablePtr,
CONST char *key, int *newPtr));
#endif
static void RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr));
Tcl_HashKeyType tclArrayHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
TCL_HASH_KEY_RANDOMIZE_HASH, /* flags */
HashArrayKey, /* hashKeyProc */
CompareArrayKeys, /* compareKeysProc */
AllocArrayEntry, /* allocEntryProc */
NULL /* freeEntryProc */
};
Tcl_HashKeyType tclOneWordHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
NULL, /* HashOneWordKey, */ /* hashProc */
NULL, /* CompareOneWordKey, */ /* compareProc */
NULL, /* AllocOneWordKey, */ /* allocEntryProc */
NULL /* FreeOneWordKey, */ /* freeEntryProc */
};
Tcl_HashKeyType tclStringHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
HashStringKey, /* hashKeyProc */
CompareStringKeys, /* compareKeysProc */
AllocStringEntry, /* allocEntryProc */
NULL /* freeEntryProc */
};
/*
*----------------------------------------------------------------------
*
* Tcl_InitHashTable --
*
* Given storage for a hash table, set up the fields to prepare
* the hash table for use.
*
* Results:
* None.
*
* Side effects:
* TablePtr is now ready to be passed to Tcl_FindHashEntry and
* Tcl_CreateHashEntry.
*
*----------------------------------------------------------------------
*/
#undef Tcl_InitHashTable
void
Tcl_InitHashTable(tablePtr, keyType)
register Tcl_HashTable *tablePtr; /* Pointer to table record, which
* is supplied by the caller. */
int keyType; /* Type of keys to use in table:
* TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
* or an integer >= 2. */
{
/*
* Use a special value to inform the extended version that it must
* not access any of the new fields in the Tcl_HashTable. If an
* extension is rebuilt then any calls to this function will be
* redirected to the extended version by a macro.
*/
Tcl_InitCustomHashTable(tablePtr, keyType, (Tcl_HashKeyType *) -1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitCustomHashTable --
*
* Given storage for a hash table, set up the fields to prepare
* the hash table for use. This is an extended version of
* Tcl_InitHashTable which supports user defined keys.
*
* Results:
* None.
*
* Side effects:
* TablePtr is now ready to be passed to Tcl_FindHashEntry and
* Tcl_CreateHashEntry.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitCustomHashTable(tablePtr, keyType, typePtr)
register Tcl_HashTable *tablePtr; /* Pointer to table record, which
* is supplied by the caller. */
int keyType; /* Type of keys to use in table:
* TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
* TCL_CUSTOM_TYPE_KEYS,
* TCL_CUSTOM_PTR_KEYS, or an
* integer >= 2. */
Tcl_HashKeyType *typePtr; /* Pointer to structure which defines
* the behaviour of this table. */
{
#if (TCL_SMALL_HASH_TABLE != 4)
panic("Tcl_InitCustomHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
TCL_SMALL_HASH_TABLE);
#endif
tablePtr->buckets = tablePtr->staticBuckets;
tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
tablePtr->numEntries = 0;
tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
tablePtr->downShift = 28;
tablePtr->mask = 3;
tablePtr->keyType = keyType;
#if TCL_PRESERVE_BINARY_COMPATABILITY
tablePtr->findProc = FindHashEntry;
tablePtr->createProc = CreateHashEntry;
if (typePtr == NULL) {
/*
* The caller has been rebuilt so the hash table is an extended
* version.
*/
} else if (typePtr != (Tcl_HashKeyType *) -1) {
/*
* The caller is requesting a customized hash table so it must be
* an extended version.
*/
tablePtr->typePtr = typePtr;
} else {
/*
* The caller has not been rebuilt so the hash table is not
* extended.
*/
}
#else
if (typePtr == NULL) {
/*
* Use the key type to decide which key type is needed.
*/
if (keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
} else if (keyType == TCL_CUSTOM_TYPE_KEYS) {
Tcl_Panic ("No type structure specified for TCL_CUSTOM_TYPE_KEYS");
} else if (keyType == TCL_CUSTOM_PTR_KEYS) {
Tcl_Panic ("No type structure specified for TCL_CUSTOM_PTR_KEYS");
} else {
typePtr = &tclArrayHashKeyType;
}
} else if (typePtr == (Tcl_HashKeyType *) -1) {
/*
* If the caller has not been rebuilt then we cannot continue as
* the hash table is not an extended version.
*/
Tcl_Panic ("Hash table is not compatible");
}
tablePtr->typePtr = typePtr;
#endif
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindHashEntry --
*
* Given a hash table find the entry with a matching key.
*
* Results:
* The return value is a token for the matching entry in the
* hash table, or NULL if there was no matching entry.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_HashEntry *
Tcl_FindHashEntry(tablePtr, key)
Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
CONST char *key; /* Key to use to find matching entry. */
#if TCL_PRESERVE_BINARY_COMPATABILITY
{
return tablePtr->findProc(tablePtr, key);
}
static Tcl_HashEntry *
FindHashEntry(tablePtr, key)
Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
CONST char *key; /* Key to use to find matching entry. */
#endif /* TCL_PRESERVE_BINARY_COMPATABILITY */
{
register Tcl_HashEntry *hPtr;
Tcl_HashKeyType *typePtr;
unsigned int hash;
int index;
#if TCL_PRESERVE_BINARY_COMPATABILITY
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
} else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
|| tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
typePtr = tablePtr->typePtr;
} else {
typePtr = &tclArrayHashKeyType;
}
#else
typePtr = tablePtr->typePtr;
if (typePtr == NULL) {
Tcl_Panic("called Tcl_FindHashEntry on deleted table");
return NULL;
}
#endif
if (typePtr->hashKeyProc) {
hash = typePtr->hashKeyProc (tablePtr, (VOID *) key);
if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
index = RANDOM_INDEX (tablePtr, hash);
} else {
index = hash & tablePtr->mask;
}
} else {
hash = (unsigned int) key;
index = RANDOM_INDEX (tablePtr, hash);
}
/*
* Search all of the entries in the appropriate bucket.
*/
if (typePtr->compareKeysProc) {
Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
if (hash != (unsigned int) hPtr->hash) {
continue;
}
#endif
if (compareKeysProc ((VOID *) key, hPtr)) {
return hPtr;
}
}
} else {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
if (hash != (unsigned int) hPtr->hash) {
continue;
}
#endif
if (key == hPtr->key.oneWordValue) {
return hPtr;
}
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateHashEntry --
*
* Given a hash table with string keys, and a string key, find
* the entry with a matching key. If there is no matching entry,
* then create a new entry that does match.
*
* Results:
* The return value is a pointer to the matching entry. If this
* is a newly-created entry, then *newPtr will be set to a non-zero
* value; otherwise *newPtr will be set to 0. If this is a new
* entry the value stored in the entry will initially be 0.
*
* Side effects:
* A new entry may be added to the hash table.
*
*----------------------------------------------------------------------
*/
Tcl_HashEntry *
Tcl_CreateHashEntry(tablePtr, key, newPtr)
Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
CONST char *key; /* Key to use to find or create matching
* entry. */
int *newPtr; /* Store info here telling whether a new
* entry was created. */
#if TCL_PRESERVE_BINARY_COMPATABILITY
{
return tablePtr->createProc(tablePtr, key, newPtr);
}
static Tcl_HashEntry *
CreateHashEntry(tablePtr, key, newPtr)
Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
CONST char *key; /* Key to use to find or create matching
* entry. */
int *newPtr; /* Store info here telling whether a new
* entry was created. */
#endif /* TCL_PRESERVE_BINARY_COMPATABILITY */
{
register Tcl_HashEntry *hPtr;
Tcl_HashKeyType *typePtr;
unsigned int hash;
int index;
#if TCL_PRESERVE_BINARY_COMPATABILITY
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
} else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
|| tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
typePtr = tablePtr->typePtr;
} else {
typePtr = &tclArrayHashKeyType;
}
#else
typePtr = tablePtr->typePtr;
if (typePtr == NULL) {
Tcl_Panic("called Tcl_CreateHashEntry on deleted table");
return NULL;
}
#endif
if (typePtr->hashKeyProc) {
hash = typePtr->hashKeyProc (tablePtr, (VOID *) key);
if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
index = RANDOM_INDEX (tablePtr, hash);
} else {
index = hash & tablePtr->mask;
}
} else {
hash = (unsigned int) key;
index = RANDOM_INDEX (tablePtr, hash);
}
/*
* Search all of the entries in the appropriate bucket.
*/
if (typePtr->compareKeysProc) {
Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
if (hash != (unsigned int) hPtr->hash) {
continue;
}
#endif
if (compareKeysProc ((VOID *) key, hPtr)) {
*newPtr = 0;
return hPtr;
}
}
} else {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
if (hash != (unsigned int) hPtr->hash) {
continue;
}
#endif
if (key == hPtr->key.oneWordValue) {
*newPtr = 0;
return hPtr;
}
}
}
/*
* Entry not found. Add a new one to the bucket.
*/
*newPtr = 1;
if (typePtr->allocEntryProc) {
hPtr = typePtr->allocEntryProc (tablePtr, (VOID *) key);
} else {
hPtr = (Tcl_HashEntry *) ckalloc((unsigned) sizeof(Tcl_HashEntry));
hPtr->key.oneWordValue = (char *) key;
}
hPtr->tablePtr = tablePtr;
#if TCL_HASH_KEY_STORE_HASH
# if TCL_PRESERVE_BINARY_COMPATABILITY
hPtr->hash = (VOID *) hash;
# else
hPtr->hash = hash;
# endif
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
#else
hPtr->bucketPtr = &(tablePtr->buckets[index]);
hPtr->nextPtr = *hPtr->bucketPtr;
*hPtr->bucketPtr = hPtr;
#endif
hPtr->clientData = 0;
tablePtr->numEntries++;
/*
* If the table has exceeded a decent size, rebuild it with many
* more buckets.
*/
if (tablePtr->numEntries >= tablePtr->rebuildSize) {
RebuildTable(tablePtr);
}
return hPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteHashEntry --
*
* Remove a single entry from a hash table.
*
* Results:
* None.
*
* Side effects:
* The entry given by entryPtr is deleted from its table and
* should never again be used by the caller. It is up to the
* caller to free the clientData field of the entry, if that
* is relevant.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteHashEntry(entryPtr)
Tcl_HashEntry *entryPtr;
{
register Tcl_HashEntry *prevPtr;
Tcl_HashKeyType *typePtr;
Tcl_HashTable *tablePtr;
Tcl_HashEntry **bucketPtr;
#if TCL_HASH_KEY_STORE_HASH
int index;
#endif
tablePtr = entryPtr->tablePtr;
#if TCL_PRESERVE_BINARY_COMPATABILITY
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
} else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
|| tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
typePtr = tablePtr->typePtr;
} else {
typePtr = &tclArrayHashKeyType;
}
#else
typePtr = tablePtr->typePtr;
#endif
#if TCL_HASH_KEY_STORE_HASH
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
index = RANDOM_INDEX (tablePtr, entryPtr->hash);
} else {
index = ((unsigned int) entryPtr->hash) & tablePtr->mask;
}
bucketPtr = &(tablePtr->buckets[index]);
#else
bucketPtr = entryPtr->bucketPtr;
#endif
if (*bucketPtr == entryPtr) {
*bucketPtr = entryPtr->nextPtr;
} else {
for (prevPtr = *bucketPtr; ; prevPtr = prevPtr->nextPtr) {
if (prevPtr == NULL) {
panic("malformed bucket chain in Tcl_DeleteHashEntry");
}
if (prevPtr->nextPtr == entryPtr) {
prevPtr->nextPtr = entryPtr->nextPtr;
break;
}
}
}
tablePtr->numEntries--;
if (typePtr->freeEntryProc) {
typePtr->freeEntryProc (entryPtr);
} else {
ckfree((char *) entryPtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteHashTable --
*
* Free up everything associated with a hash table except for
* the record for the table itself.
*
* Results:
* None.
*
* Side effects:
* The hash table is no longer useable.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteHashTable(tablePtr)
register Tcl_HashTable *tablePtr; /* Table to delete. */
{
register Tcl_HashEntry *hPtr, *nextPtr;
Tcl_HashKeyType *typePtr;
int i;
#if TCL_PRESERVE_BINARY_COMPATABILITY
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
} else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
|| tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
typePtr = tablePtr->typePtr;
} else {
typePtr = &tclArrayHashKeyType;
}
#else
typePtr = tablePtr->typePtr;
#endif
/*
* Free up all the entries in the table.
*/
for (i = 0; i < tablePtr->numBuckets; i++) {
hPtr = tablePtr->buckets[i];
while (hPtr != NULL) {
nextPtr = hPtr->nextPtr;
if (typePtr->freeEntryProc) {
typePtr->freeEntryProc (hPtr);
} else {
ckfree((char *) hPtr);
}
hPtr = nextPtr;
}
}
/*
* Free up the bucket array, if it was dynamically allocated.
*/
if (tablePtr->buckets != tablePtr->staticBuckets) {
ckfree((char *) tablePtr->buckets);
}
/*
* Arrange for panics if the table is used again without
* re-initialization.
*/
#if TCL_PRESERVE_BINARY_COMPATABILITY
tablePtr->findProc = BogusFind;
tablePtr->createProc = BogusCreate;
#else
tablePtr->typePtr = NULL;
#endif
}
/*
*----------------------------------------------------------------------
*
* Tcl_FirstHashEntry --
*
* Locate the first entry in a hash table and set up a record
* that can be used to step through all the remaining entries
* of the table.
*
* Results:
* The return value is a pointer to the first entry in tablePtr,
* or NULL if tablePtr has no entries in it. The memory at
* *searchPtr is initialized so that subsequent calls to
* Tcl_NextHashEntry will return all of the entries in the table,
* one at a time.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_HashEntry *
Tcl_FirstHashEntry(tablePtr, searchPtr)
Tcl_HashTable *tablePtr; /* Table to search. */
Tcl_HashSearch *searchPtr; /* Place to store information about
* progress through the table. */
{
searchPtr->tablePtr = tablePtr;
searchPtr->nextIndex = 0;
searchPtr->nextEntryPtr = NULL;
return Tcl_NextHashEntry(searchPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_NextHashEntry --
*
* Once a hash table enumeration has been initiated by calling
* Tcl_FirstHashEntry, this procedure may be called to return
* successive elements of the table.
*
* Results:
* The return value is the next entry in the hash table being
* enumerated, or NULL if the end of the table is reached.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_HashEntry *
Tcl_NextHashEntry(searchPtr)
register Tcl_HashSearch *searchPtr; /* Place to store information about
* progress through the table. Must
* have been initialized by calling
* Tcl_FirstHashEntry. */
{
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr = searchPtr->tablePtr;
while (searchPtr->nextEntryPtr == NULL) {
if (searchPtr->nextIndex >= tablePtr->numBuckets) {
return NULL;
}
searchPtr->nextEntryPtr =
tablePtr->buckets[searchPtr->nextIndex];
searchPtr->nextIndex++;
}
hPtr = searchPtr->nextEntryPtr;
searchPtr->nextEntryPtr = hPtr->nextPtr;
return hPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_HashStats --
*
* Return statistics describing the layout of the hash table
* in its hash buckets.
*
* Results:
* The return value is a malloc-ed string containing information
* about tablePtr. It is the caller's responsibility to free
* this string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
Tcl_HashStats(tablePtr)
Tcl_HashTable *tablePtr; /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
int count[NUM_COUNTERS], overflow, i, j;
double average, tmp;
register Tcl_HashEntry *hPtr;
char *result, *p;
/*
* Compute a histogram of bucket usage.
*/
for (i = 0; i < NUM_COUNTERS; i++) {
count[i] = 0;
}
overflow = 0;
average = 0.0;
for (i = 0; i < tablePtr->numBuckets; i++) {
j = 0;
for (hPtr = tablePtr->buckets[i]; hPtr != NULL; hPtr = hPtr->nextPtr) {
j++;
}
if (j < NUM_COUNTERS) {
count[j]++;
} else {
overflow++;
}
tmp = j;
average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
}
/*
* Print out the histogram and a few other pieces of information.
*/
result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
sprintf(result, "%d entries in table, %d buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i = 0; i < NUM_COUNTERS; i++) {
sprintf(p, "number of buckets with %d entries: %d\n",
i, count[i]);
p += strlen(p);
}
sprintf(p, "number of buckets with %d or more entries: %d\n",
NUM_COUNTERS, overflow);
p += strlen(p);
sprintf(p, "average search distance for entry: %.1f", average);
return result;
}
/*
*----------------------------------------------------------------------
*
* AllocArrayEntry --
*
* Allocate space for a Tcl_HashEntry containing the array key.
*
* Results:
* The return value is a pointer to the created entry.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocArrayEntry(tablePtr, keyPtr)
Tcl_HashTable *tablePtr; /* Hash table. */
VOID *keyPtr; /* Key to store in the hash table entry. */
{
int *array = (int *) keyPtr;
register int *iPtr1, *iPtr2;
Tcl_HashEntry *hPtr;
int count;
unsigned int size;
count = tablePtr->keyType;
size = sizeof(Tcl_HashEntry) + (count*sizeof(int)) - sizeof(hPtr->key);
if (size < sizeof(Tcl_HashEntry))
size = sizeof(Tcl_HashEntry);
hPtr = (Tcl_HashEntry *) ckalloc(size);
for (iPtr1 = array, iPtr2 = hPtr->key.words;
count > 0; count--, iPtr1++, iPtr2++) {
*iPtr2 = *iPtr1;
}
return hPtr;
}
/*
*----------------------------------------------------------------------
*
* CompareArrayKeys --
*
* Compares two array keys.
*
* Results:
* The return value is 0 if they are different and 1 if they are
* the same.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CompareArrayKeys(keyPtr, hPtr)
VOID *keyPtr; /* New key to compare. */
Tcl_HashEntry *hPtr; /* Existing key to compare. */
{
register CONST int *iPtr1 = (CONST int *) keyPtr;
register CONST int *iPtr2 = (CONST int *) hPtr->key.words;
Tcl_HashTable *tablePtr = hPtr->tablePtr;
int count;
for (count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
if (count == 0) {
return 1;
}
if (*iPtr1 != *iPtr2) {
break;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* HashArrayKey --
*
* Compute a one-word summary of an array, which can be
* used to generate a hash index.
*
* Results:
* The return value is a one-word summary of the information in
* string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static unsigned int
HashArrayKey(tablePtr, keyPtr)
Tcl_HashTable *tablePtr; /* Hash table. */
VOID *keyPtr; /* Key from which to compute hash value. */
{
register CONST int *array = (CONST int *) keyPtr;
register unsigned int result;
int count;
for (result = 0, count = tablePtr->keyType; count > 0;
count--, array++) {
result += *array;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* AllocStringEntry --
*
* Allocate space for a Tcl_HashEntry containing the string key.
*
* Results:
* The return value is a pointer to the created entry.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocStringEntry(tablePtr, keyPtr)
Tcl_HashTable *tablePtr; /* Hash table. */
VOID *keyPtr; /* Key to store in the hash table entry. */
{
CONST char *string = (CONST char *) keyPtr;
Tcl_HashEntry *hPtr;
unsigned int size, allocsize;
allocsize = size = strlen(string) + 1;
if (size < sizeof(hPtr->key)) {
allocsize = sizeof(hPtr->key);
}
hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry) + allocsize - sizeof(hPtr->key));
memcpy(hPtr->key.string, string, size);
return hPtr;
}
/*
*----------------------------------------------------------------------
*
* CompareStringKeys --
*
* Compares two string keys.
*
* Results:
* The return value is 0 if they are different and 1 if they are
* the same.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CompareStringKeys(keyPtr, hPtr)
VOID *keyPtr; /* New key to compare. */
Tcl_HashEntry *hPtr; /* Existing key to compare. */
{
register CONST char *p1 = (CONST char *) keyPtr;
register CONST char *p2 = (CONST char *) hPtr->key.string;
for (;; p1++, p2++) {
if (*p1 != *p2) {
break;
}
if (*p1 == '\0') {
return 1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* HashStringKey --
*
* Compute a one-word summary of a text string, which can be
* used to generate a hash index.
*
* Results:
* The return value is a one-word summary of the information in
* string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static unsigned int
HashStringKey(tablePtr, keyPtr)
Tcl_HashTable *tablePtr; /* Hash table. */
VOID *keyPtr; /* Key from which to compute hash value. */
{
register CONST char *string = (CONST char *) keyPtr;
register unsigned int result;
register int c;
/*
* I tried a zillion different hash functions and asked many other
* people for advice. Many people had their own favorite functions,
* all different, but no-one had much idea why they were good ones.
* I chose the one below (multiply by 9 and add new character)
* because of the following reasons:
*
* 1. Multiplying by 10 is perfect for keys that are decimal strings,
* and multiplying by 9 is just about as good.
* 2. Times-9 is (shift-left-3) plus (old). This means that each
* character's bits hang around in the low-order bits of the
* hash value for ever, plus they spread fairly rapidly up to
* the high-order bits to fill out the hash value. This seems
* works well both for decimal and non-decimal strings.
*/
result = 0;
while (1) {
c = *string;
if (c == 0) {
break;
}
result += (result<<3) + c;
string++;
}
return result;
}
#if TCL_PRESERVE_BINARY_COMPATABILITY
/*
*----------------------------------------------------------------------
*
* BogusFind --
*
* This procedure is invoked when an Tcl_FindHashEntry is called
* on a table that has been deleted.
*
* Results:
* If panic returns (which it shouldn't) this procedure returns
* NULL.
*
* Side effects:
* Generates a panic.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static Tcl_HashEntry *
BogusFind(tablePtr, key)
Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
CONST char *key; /* Key to use to find matching entry. */
{
panic("called Tcl_FindHashEntry on deleted table");
return NULL;
}
/*
*----------------------------------------------------------------------
*
* BogusCreate --
*
* This procedure is invoked when an Tcl_CreateHashEntry is called
* on a table that has been deleted.
*
* Results:
* If panic returns (which it shouldn't) this procedure returns
* NULL.
*
* Side effects:
* Generates a panic.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static Tcl_HashEntry *
BogusCreate(tablePtr, key, newPtr)
Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
CONST char *key; /* Key to use to find or create matching
* entry. */
int *newPtr; /* Store info here telling whether a new
* entry was created. */
{
panic("called Tcl_CreateHashEntry on deleted table");
return NULL;
}
#endif
/*
*----------------------------------------------------------------------
*
* RebuildTable --
*
* This procedure is invoked when the ratio of entries to hash
* buckets becomes too large. It creates a new table with a
* larger bucket array and moves all of the entries into the
* new table.
*
* Results:
* None.
*
* Side effects:
* Memory gets reallocated and entries get re-hashed to new
* buckets.
*
*----------------------------------------------------------------------
*/
static void
RebuildTable(tablePtr)
register Tcl_HashTable *tablePtr; /* Table to enlarge. */
{
int oldSize, count, index;
Tcl_HashEntry **oldBuckets;
register Tcl_HashEntry **oldChainPtr, **newChainPtr;
register Tcl_HashEntry *hPtr;
Tcl_HashKeyType *typePtr;
oldSize = tablePtr->numBuckets;
oldBuckets = tablePtr->buckets;
/*
* Allocate and initialize the new bucket array, and set up
* hashing constants for new array size.
*/
tablePtr->numBuckets *= 4;
tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned)
(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)));
for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
count > 0; count--, newChainPtr++) {
*newChainPtr = NULL;
}
tablePtr->rebuildSize *= 4;
tablePtr->downShift -= 2;
tablePtr->mask = (tablePtr->mask << 2) + 3;
#if TCL_PRESERVE_BINARY_COMPATABILITY
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
} else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
|| tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
typePtr = tablePtr->typePtr;
} else {
typePtr = &tclArrayHashKeyType;
}
#else
typePtr = tablePtr->typePtr;
#endif
/*
* Rehash all of the existing entries into the new bucket array.
*/
for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) {
for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) {
*oldChainPtr = hPtr->nextPtr;
#if TCL_HASH_KEY_STORE_HASH
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
index = RANDOM_INDEX (tablePtr, hPtr->hash);
} else {
index = ((unsigned int) hPtr->hash) & tablePtr->mask;
}
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
#else
VOID *key = (VOID *) Tcl_GetHashKey (tablePtr, hPtr);
if (typePtr->hashKeyProc) {
unsigned int hash;
hash = typePtr->hashKeyProc (tablePtr, (VOID *) key);
if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
index = RANDOM_INDEX (tablePtr, hash);
} else {
index = hash & tablePtr->mask;
}
} else {
index = RANDOM_INDEX (tablePtr, key);
}
hPtr->bucketPtr = &(tablePtr->buckets[index]);
hPtr->nextPtr = *hPtr->bucketPtr;
*hPtr->bucketPtr = hPtr;
#endif
}
}
/*
* Free up the old bucket array, if it was dynamically allocated.
*/
if (oldBuckets != tablePtr->staticBuckets) {
ckfree((char *) oldBuckets);
}
}
tcl8.4.20/generic/tclInt.decls 0000644 0036047 0045461 00000056427 12133546540 014613 0 ustar dgp 771div # tclInt.decls --
#
# This file contains the declarations for all unsupported
# functions that are exported by the Tcl library. This file
# is used to generate the tclIntDecls.h, tclIntPlatDecls.h,
# tclIntStub.c, tclPlatStub.c, tclCompileDecls.h and tclCompileStub.c
# files
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
library tcl
# Define the unsupported generic interfaces.
interface tclInt
# Declare each of the functions in the unsupported internal Tcl
# interface. These interfaces are allowed to changed between versions.
# Use at your own risk. Note that the position of functions should not
# be changed between versions to avoid gratuitous incompatibilities.
# Replaced by Tcl_FSAccess in 8.4:
#declare 0 {
# int TclAccess(const char *path, int mode)
#}
declare 1 {
int TclAccessDeleteProc(TclAccessProc_ *proc)
}
declare 2 {
int TclAccessInsertProc(TclAccessProc_ *proc)
}
declare 3 {
void TclAllocateFreeObjects(void)
}
# Replaced by TclpChdir in 8.1:
# declare 4 {
# int TclChdir(Tcl_Interp *interp, char *dirName)
# }
declare 5 {
int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr,
Tcl_Channel errorChan)
}
declare 6 {
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
int TclCopyAndCollapse(int count, const char *src, char *dst)
}
declare 8 {
int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan,
Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr)
}
# TclCreatePipeline unofficially exported for use by BLT.
declare 9 {
int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv,
Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr)
}
declare 10 {
int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr,
const char *procName,
Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr)
}
declare 11 {
void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr)
}
declare 12 {
void TclDeleteVars(Interp *iPtr, Tcl_HashTable *tablePtr)
}
declare 13 {
int TclDoGlob(Tcl_Interp *interp, char *separators,
Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
}
declare 14 {
void TclDumpMemoryInfo(FILE *outFile)
}
# Removed in 8.1:
# declare 15 {
# void TclExpandParseValue(ParseValue *pvPtr, int needed)
# }
declare 16 {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
# Removed in 8.4:
#declare 17 {
# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
#}
#declare 18 {
# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv)
#}
#declare 19 {
# int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv)
#}
#declare 20 {
# int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv)
#}
#declare 21 {
# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
#}
declare 22 {
int TclFindElement(Tcl_Interp *interp, const char *listStr,
int listLength, const char **elementPtr, const char **nextPtr,
int *sizePtr, int *bracePtr)
}
declare 23 {
Proc *TclFindProc(Interp *iPtr, const char *procName)
}
declare 24 {
int TclFormatInt(char *buffer, long n)
}
declare 25 {
void TclFreePackageInfo(Interp *iPtr)
}
# Removed in 8.1:
# declare 26 {
# char *TclGetCwd(Tcl_Interp *interp)
# }
declare 27 {
int TclGetDate(char *p, Tcl_WideInt now, long zone,
Tcl_WideInt *timePtr)
}
declare 28 {
Tcl_Channel TclpGetDefaultStdChannel(int type)
}
# Removed in 8.4b2:
#declare 29 {
# Tcl_Obj *TclGetElementOfIndexedArray(Tcl_Interp *interp,
# int localIndex, Tcl_Obj *elemPtr, int flags)
#}
# Replaced by char *TclGetEnv(const char *name, Tcl_DString *valuePtr) in 8.1:
# declare 30 {
# char *TclGetEnv(const char *name)
# }
declare 31 {
char *TclGetExtension(char *name)
}
declare 32 {
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
declare 33 {
TclCmdProcType TclGetInterpProc(void)
}
declare 34 {
int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
int endValue, int *indexPtr)
}
# Removed in 8.4b2:
#declare 35 {
# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
# int flags)
#}
declare 36 {
int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr)
}
declare 37 {
int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName)
}
declare 38 {
int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName,
Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr,
Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr,
const char **simpleNamePtr)
}
declare 39 {
TclObjCmdProcType TclGetObjInterpProc(void)
}
declare 40 {
int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr)
}
declare 41 {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 {
char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
}
declare 43 {
int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags)
}
declare 44 {
int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr)
}
declare 45 {
int TclHideUnsafeCommands(Tcl_Interp *interp)
}
declare 46 {
int TclInExit(void)
}
# Removed in 8.4b2:
#declare 47 {
# Tcl_Obj *TclIncrElementOfIndexedArray(Tcl_Interp *interp,
# int localIndex, Tcl_Obj *elemPtr, long incrAmount)
#}
# Removed in 8.4b2:
#declare 48 {
# Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
# long incrAmount)
#}
declare 49 {
Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
}
declare 50 {
void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
Namespace *nsPtr)
}
declare 51 {
int TclInterpInit(Tcl_Interp *interp)
}
declare 52 {
int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags)
}
declare 53 {
int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
int argc, CONST84 char **argv)
}
declare 54 {
int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 55 {
Proc *TclIsProc(Command *cmdPtr)
}
# Replaced with TclpLoadFile in 8.1:
# declare 56 {
# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
# char *sym2, Tcl_PackageInitProc **proc1Ptr,
# Tcl_PackageInitProc **proc2Ptr)
# }
# Signature changed to take a length in 8.1:
# declare 57 {
# int TclLooksLikeInt(char *p)
# }
declare 58 {
Var *TclLookupVar(Tcl_Interp *interp, const char *part1, const char *part2,
int flags, const char *msg, int createPart1, int createPart2,
Var **arrayPtrPtr)
}
# Replaced by Tcl_FSMatchInDirectory in 8.4
#declare 59 {
# int TclpMatchFiles(Tcl_Interp *interp, char *separators,
# Tcl_DString *dirPtr, char *pattern, char *tail)
#}
declare 60 {
int TclNeedSpace(const char *start, const char *end)
}
declare 61 {
Tcl_Obj *TclNewProcBodyObj(Proc *procPtr)
}
declare 62 {
int TclObjCommandComplete(Tcl_Obj *cmdPtr)
}
declare 63 {
int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 64 {
int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
declare 65 {
int TclObjInvokeGlobal(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], int flags)
}
declare 66 {
int TclOpenFileChannelDeleteProc(TclOpenFileChannelProc_ *proc)
}
declare 67 {
int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
}
# Replaced by Tcl_FSAccess in 8.4:
#declare 68 {
# int TclpAccess(const char *path, int mode)
#}
declare 69 {
char *TclpAlloc(unsigned int size)
}
#declare 70 {
# int TclpCopyFile(const char *source, const char *dest)
#}
#declare 71 {
# int TclpCopyDirectory(const char *source, const char *dest,
# Tcl_DString *errorPtr)
#}
#declare 72 {
# int TclpCreateDirectory(const char *path)
#}
#declare 73 {
# int TclpDeleteFile(const char *path)
#}
declare 74 {
void TclpFree(char *ptr)
}
declare 75 {
unsigned long TclpGetClicks(void)
}
declare 76 {
unsigned long TclpGetSeconds(void)
}
# deprecated
declare 77 {
void TclpGetTime(Tcl_Time *time)
}
declare 78 {
int TclpGetTimeZone(Tcl_WideInt time)
}
# Replaced by Tcl_FSListVolumes in 8.4:
#declare 79 {
# int TclpListVolumes(Tcl_Interp *interp)
#}
# Replaced by Tcl_FSOpenFileChannel in 8.4:
#declare 80 {
# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName,
# char *modeString, int permissions)
#}
declare 81 {
char *TclpRealloc(char *ptr, unsigned int size)
}
#declare 82 {
# int TclpRemoveDirectory(const char *path, int recursive,
# Tcl_DString *errorPtr)
#}
#declare 83 {
# int TclpRenameFile(const char *source, const char *dest)
#}
# Removed in 8.1:
# declare 84 {
# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr,
# ParseValue *pvPtr)
# }
# declare 85 {
# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags,
# char **termPtr, ParseValue *pvPtr)
# }
# declare 86 {
# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar,
# int flags, char **termPtr, ParseValue *pvPtr)
# }
# declare 87 {
# void TclPlatformInit(Tcl_Interp *interp)
# }
declare 88 {
char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags)
}
declare 89 {
int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp,
Tcl_Command cmd)
}
# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG):
# declare 90 {
# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
# }
declare 91 {
void TclProcCleanupProc(Proc *procPtr)
}
declare 92 {
int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description,
const char *procName)
}
declare 93 {
void TclProcDeleteProc(ClientData clientData)
}
declare 94 {
int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp,
int argc, CONST84 char **argv)
}
# Replaced by Tcl_FSStat in 8.4:
#declare 95 {
# int TclpStat(const char *path, Tcl_StatBuf *buf)
#}
declare 96 {
int TclRenameCommand(Tcl_Interp *interp, char *oldName,
char *newName)
}
declare 97 {
void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr)
}
declare 98 {
int TclServiceIdle(void)
}
# Removed in 8.4b2:
#declare 99 {
# Tcl_Obj *TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex,
# Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
#}
# Removed in 8.4b2:
#declare 100 {
# Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
# Tcl_Obj *objPtr, int flags)
#}
declare 101 {
char *TclSetPreInitScript(char *string)
}
declare 102 {
void TclSetupEnv(Tcl_Interp *interp)
}
declare 103 {
int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto,
int *portPtr)
}
declare 104 {
int TclSockMinimumBuffersOld(int sock, int size)
}
# Replaced by Tcl_FSStat in 8.4:
#declare 105 {
# int TclStat(const char *path, Tcl_StatBuf *buf)
#}
declare 106 {
int TclStatDeleteProc(TclStatProc_ *proc)
}
declare 107 {
int TclStatInsertProc(TclStatProc_ *proc)
}
declare 108 {
void TclTeardownNamespace(Namespace *nsPtr)
}
declare 109 {
int TclUpdateReturnInfo(Interp *iPtr)
}
declare 110 {
int TclSockMinimumBuffers(void *sock, int size)
}
# Removed in 8.1:
# declare 110 {
# char *TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr)
# }
# Procedures used in conjunction with Tcl namespaces. They are
# defined here instead of in tcl.decls since they are not stable yet.
declare 111 {
void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 112 {
int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *objPtr)
}
declare 113 {
Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 114 {
void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
}
declare 115 {
int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int resetListFirst)
}
declare 116 {
Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 117 {
Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 118 {
int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolverInfo *resInfo)
}
declare 119 {
int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo)
}
declare 120 {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 121 {
int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern)
}
declare 122 {
Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 123 {
void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
Tcl_Obj *objPtr)
}
declare 124 {
Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp)
}
declare 125 {
Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp)
}
declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
declare 127 {
int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite)
}
declare 128 {
void Tcl_PopCallFrame(Tcl_Interp *interp)
}
declare 129 {
int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr,
Tcl_Namespace *nsPtr, int isProcCallFrame)
}
declare 130 {
int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, const char *name)
}
declare 131 {
void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 132 {
int TclpHasSockets(Tcl_Interp *interp)
}
declare 133 {
struct tm *TclpGetDate(TclpTime_t time, int useGMT)
}
declare 134 {
size_t TclpStrftime(char *s, size_t maxsize, const char *format,
const struct tm *t, int useGMT)
}
declare 135 {
int TclpCheckStackSpace(void)
}
declare 138 {
CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
declare 140 {
int TclLooksLikeInt(const char *bytes, int length)
}
# This is used by TclX, but should otherwise be considered private
declare 141 {
CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
CompileHookProc *hookProc, ClientData clientData)
}
declare 143 {
int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
LiteralEntry **litPtrPtr)
}
declare 144 {
void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr,
int index)
}
declare 145 {
struct AuxDataType *TclGetAuxDataType(char *typeName)
}
declare 146 {
TclHandle TclHandleCreate(void *ptr)
}
declare 147 {
void TclHandleFree(TclHandle handle)
}
declare 148 {
TclHandle TclHandlePreserve(TclHandle handle)
}
declare 149 {
void TclHandleRelease(TclHandle handle)
}
# Added in 8.2:
declare 150 {
int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
declare 151 {
void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr,
int *endPtr)
}
declare 152 {
void TclSetLibraryPath(Tcl_Obj *pathPtr)
}
declare 153 {
Tcl_Obj *TclGetLibraryPath(void)
}
# moved to tclTest.c (static) in 8.3.2:
#declare 154 {
# int TclTestChannelCmd(ClientData clientData,
# Tcl_Interp *interp, int argc, char **argv)
#}
#declare 155 {
# int TclTestChannelEventCmd(ClientData clientData,
# Tcl_Interp *interp, int argc, char **argv)
#}
declare 156 {
void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
}
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
declare 158 {
void TclSetStartupScriptFileName(const char *filename)
}
declare 159 {
CONST84_RETURN char *TclGetStartupScriptFileName(void)
}
#declare 160 {
# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
# Tcl_DString *dirPtr, char *pattern, char *tail,
# GlobTypeData *types)
#}
# new in 8.3.2/8.4a2
declare 161 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
}
declare 162 {
void TclChannelEventScriptInvoker(ClientData clientData, int flags)
}
# ALERT: The result of 'TclGetInstructionTable' is actually a
# "const InstructionDesc*" but we do not want to describe this structure in
# "tclInt.h". It is described in "tclCompile.h". Use a cast to the
# correct type when calling this procedure.
declare 163 {
void *TclGetInstructionTable(void)
}
# ALERT: The argument of 'TclExpandCodeArray' is actually a
# "CompileEnv*" but we do not want to describe this structure in
# "tclInt.h". It is described in "tclCompile.h".
declare 164 {
void TclExpandCodeArray(void *envPtr)
}
# These functions are vfs aware, but are generally only useful internally.
declare 165 {
void TclpSetInitialEncodings(void)
}
# New function due to TIP #33
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
int index, Tcl_Obj *valuePtr)
}
# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
declare 167 {
void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
}
declare 168 {
Tcl_Obj *TclGetStartupScriptPath(void)
}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 {
int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n)
}
declare 170 {
int TclCheckInterpTraces(Tcl_Interp *interp, const char *command,
int numChars, Command *cmdPtr, int result, int traceFlags,
int objc, Tcl_Obj *const objv[])
}
declare 171 {
int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command,
int numChars, Command *cmdPtr, int result, int traceFlags,
int objc, Tcl_Obj *const objv[])
}
declare 172 {
int TclInThreadExit(void)
}
# Added in 8.4.2:
declare 173 {
int TclUniCharMatch(const Tcl_UniChar *string, int strLen,
const Tcl_UniChar *pattern, int ptnLen, int nocase)
}
# TclpGmtime and TclpLocaltime promoted to the generic interface from unix
declare 182 {
struct tm *TclpLocaltime(TclpTime_t_CONST clock)
}
declare 183 {
struct tm *TclpGmtime(TclpTime_t_CONST clock)
}
declare 199 {
int TclMatchIsTrivial(const char *pattern)
}
declare 249 {
void TclUnusedStubEntry(void)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
################################
# Windows specific functions
declare 0 win {
void TclWinConvertError(DWORD errCode)
}
declare 1 win {
void TclWinConvertWSAError(DWORD errCode)
}
declare 2 win {
struct servent *TclWinGetServByName(const char *nm,
const char *proto)
}
declare 3 win {
int TclWinGetSockOpt(SOCKET s, int level, int optname,
char *optval, int *optlen)
}
declare 4 win {
HINSTANCE TclWinGetTclInstance(void)
}
# new for 8.4.20+/8.5.12+ Cygwin only
declare 5 win {
int TclUnixWaitForFile(int fd, int mask, int timeout)
}
# Removed in 8.1:
# declare 5 win {
# HINSTANCE TclWinLoadLibrary(char *name)
# }
declare 6 win {
unsigned short TclWinNToHS(unsigned short ns)
}
declare 7 win {
int TclWinSetSockOpt(SOCKET s, int level, int optname,
const char *optval, int optlen)
}
declare 8 win {
int TclpGetPid(Tcl_Pid pid)
}
declare 9 win {
int TclWinGetPlatformId(void)
}
# new for 8.4.20+/8.5.12+ Cygwin only
declare 10 win {
Tcl_DirEntry *TclpReaddir(DIR *dir)
}
# Removed in 8.3.1 (for Win32s only):
#declare 10 win {
# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
#}
# Pipe channel functions
declare 11 win {
void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 12 win {
int TclpCloseFile(TclFile file)
}
declare 13 win {
Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr)
}
declare 14 win {
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 15 win {
int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr)
}
# new for 8.4.20+/8.5.12+ Cygwin only
declare 16 win {
int TclpIsAtty(int fd)
}
# Signature changed in 8.1:
# declare 16 win {
# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr)
# }
# declare 17 win {
# char *TclpGetTZName(void)
# }
declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
void TclWinAddProcess(HANDLE hProcess, DWORD id)
}
# new for 8.4.20+/8.5.12+
declare 21 win {
char *TclpInetNtoa(struct in_addr addr)
}
# Removed in 8.4:
#declare 21 win {
# void TclpAsyncMark(Tcl_AsyncHandler async)
#}
# Added in 8.1:
declare 22 win {
TclFile TclpCreateTempFile(const char *contents)
}
declare 23 win {
char *TclpGetTZName(int isdst)
}
declare 24 win {
char *TclWinNoBackslash(char *path)
}
declare 25 win {
TclPlatformType *TclWinGetPlatform(void)
}
declare 26 win {
void TclWinSetInterfaces(int wide)
}
# Added in 8.3.3:
declare 27 win {
void TclWinFlushDirtyChannels(void)
}
# Added in 8.4.2:
declare 28 win {
void TclWinResetInterfaces(void)
}
################################
# Unix specific functions
# Pipe channel functions
declare 0 unix {
void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 1 unix {
int TclpCloseFile(TclFile file)
}
declare 2 unix {
Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr)
}
declare 3 unix {
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 4 unix {
int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr)
}
# Signature changed in 8.1:
# declare 5 unix {
# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr)
# }
declare 6 unix {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 7 unix {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 8 unix {
int TclUnixWaitForFile(int fd, int mask, int timeout)
}
# Added in 8.1:
declare 9 unix {
TclFile TclpCreateTempFile(const char *contents)
}
# Added in 8.4:
declare 10 unix {
Tcl_DirEntry *TclpReaddir(DIR *dir)
}
# Slots 11 and 12 are forwarders for functions that were promoted to
# generic Stubs
declare 11 unix {
struct tm *TclpLocaltime_unix(TclpTime_t_CONST clock)
}
declare 12 unix {
struct tm *TclpGmtime_unix(TclpTime_t_CONST clock)
}
declare 13 unix {
char *TclpInetNtoa(struct in_addr addr)
}
declare 29 {win unix} {
int TclWinCPUID(unsigned int index, unsigned int *regs)
}
# Local Variables:
# mode: tcl
# End:
tcl8.4.20/generic/regcomp.c 0000644 0036047 0045461 00000161640 12133546537 014142 0 ustar dgp 771div /*
* re_*comp and friends - compile REs
* This file #includes several others (see the bottom).
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*/
#include "regguts.h"
/*
* forward declarations, up here so forward datatypes etc. are defined early
*/
/* =====^!^===== begin forwards =====^!^===== */
/* automatically gathered by fwd; do not hand-edit */
/* === regcomp.c === */
int compile _ANSI_ARGS_((regex_t *, CONST chr *, size_t, int));
static VOID moresubs _ANSI_ARGS_((struct vars *, int));
static int freev _ANSI_ARGS_((struct vars *, int));
static VOID makesearch _ANSI_ARGS_((struct vars *, struct nfa *));
static struct subre *parse _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *));
static struct subre *parsebranch _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *, int));
static VOID parseqatom _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *, struct subre *));
static VOID nonword _ANSI_ARGS_((struct vars *, int, struct state *, struct state *));
static VOID word _ANSI_ARGS_((struct vars *, int, struct state *, struct state *));
static int scannum _ANSI_ARGS_((struct vars *));
static VOID repeat _ANSI_ARGS_((struct vars *, struct state *, struct state *, int, int));
static VOID bracket _ANSI_ARGS_((struct vars *, struct state *, struct state *));
static VOID cbracket _ANSI_ARGS_((struct vars *, struct state *, struct state *));
static VOID brackpart _ANSI_ARGS_((struct vars *, struct state *, struct state *));
static CONST chr *scanplain _ANSI_ARGS_((struct vars *));
static VOID onechr _ANSI_ARGS_((struct vars *, pchr, struct state *, struct state *));
static VOID dovec _ANSI_ARGS_((struct vars *, struct cvec *, struct state *, struct state *));
static celt nextleader _ANSI_ARGS_((struct vars *, pchr, pchr));
static VOID wordchrs _ANSI_ARGS_((struct vars *));
static struct subre *subre _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *));
static VOID freesubre _ANSI_ARGS_((struct vars *, struct subre *));
static VOID freesrnode _ANSI_ARGS_((struct vars *, struct subre *));
static VOID optst _ANSI_ARGS_((struct vars *, struct subre *));
static int numst _ANSI_ARGS_((struct subre *, int));
static VOID markst _ANSI_ARGS_((struct subre *));
static VOID cleanst _ANSI_ARGS_((struct vars *));
static long nfatree _ANSI_ARGS_((struct vars *, struct subre *, FILE *));
static long nfanode _ANSI_ARGS_((struct vars *, struct subre *, FILE *));
static int newlacon _ANSI_ARGS_((struct vars *, struct state *, struct state *, int));
static VOID freelacons _ANSI_ARGS_((struct subre *, int));
static VOID rfree _ANSI_ARGS_((regex_t *));
static VOID dump _ANSI_ARGS_((regex_t *, FILE *));
static VOID dumpst _ANSI_ARGS_((struct subre *, FILE *, int));
static VOID stdump _ANSI_ARGS_((struct subre *, FILE *, int));
static char *stid _ANSI_ARGS_((struct subre *, char *, size_t));
/* === regc_lex.c === */
static VOID lexstart _ANSI_ARGS_((struct vars *));
static VOID prefixes _ANSI_ARGS_((struct vars *));
static VOID lexnest _ANSI_ARGS_((struct vars *, CONST chr *, CONST chr *));
static VOID lexword _ANSI_ARGS_((struct vars *));
static int next _ANSI_ARGS_((struct vars *));
static int lexescape _ANSI_ARGS_((struct vars *));
static chr lexdigits _ANSI_ARGS_((struct vars *, int, int, int));
static int brenext _ANSI_ARGS_((struct vars *, pchr));
static VOID skip _ANSI_ARGS_((struct vars *));
static chr newline _ANSI_ARGS_((NOPARMS));
#ifdef REG_DEBUG
static CONST chr *ch _ANSI_ARGS_((NOPARMS));
#endif
static chr chrnamed _ANSI_ARGS_((struct vars *, CONST chr *, CONST chr *, pchr));
/* === regc_color.c === */
static VOID initcm _ANSI_ARGS_((struct vars *, struct colormap *));
static VOID freecm _ANSI_ARGS_((struct colormap *));
static VOID cmtreefree _ANSI_ARGS_((struct colormap *, union tree *, int));
static color setcolor _ANSI_ARGS_((struct colormap *, pchr, pcolor));
static color maxcolor _ANSI_ARGS_((struct colormap *));
static color newcolor _ANSI_ARGS_((struct colormap *));
static VOID freecolor _ANSI_ARGS_((struct colormap *, pcolor));
static color pseudocolor _ANSI_ARGS_((struct colormap *));
static color subcolor _ANSI_ARGS_((struct colormap *, pchr c));
static color newsub _ANSI_ARGS_((struct colormap *, pcolor));
static VOID subrange _ANSI_ARGS_((struct vars *, pchr, pchr, struct state *, struct state *));
static VOID subblock _ANSI_ARGS_((struct vars *, pchr, struct state *, struct state *));
static VOID okcolors _ANSI_ARGS_((struct nfa *, struct colormap *));
static VOID colorchain _ANSI_ARGS_((struct colormap *, struct arc *));
static VOID uncolorchain _ANSI_ARGS_((struct colormap *, struct arc *));
static int singleton _ANSI_ARGS_((struct colormap *, pchr c));
static VOID rainbow _ANSI_ARGS_((struct nfa *, struct colormap *, int, pcolor, struct state *, struct state *));
static VOID colorcomplement _ANSI_ARGS_((struct nfa *, struct colormap *, int, struct state *, struct state *, struct state *));
#ifdef REG_DEBUG
static VOID dumpcolors _ANSI_ARGS_((struct colormap *, FILE *));
static VOID fillcheck _ANSI_ARGS_((struct colormap *, union tree *, int, FILE *));
static VOID dumpchr _ANSI_ARGS_((pchr, FILE *));
#endif
/* === regc_nfa.c === */
static struct nfa *newnfa _ANSI_ARGS_((struct vars *, struct colormap *, struct nfa *));
static VOID freenfa _ANSI_ARGS_((struct nfa *));
static struct state *newstate _ANSI_ARGS_((struct nfa *));
static struct state *newfstate _ANSI_ARGS_((struct nfa *, int flag));
static VOID dropstate _ANSI_ARGS_((struct nfa *, struct state *));
static VOID freestate _ANSI_ARGS_((struct nfa *, struct state *));
static VOID destroystate _ANSI_ARGS_((struct nfa *, struct state *));
static VOID newarc _ANSI_ARGS_((struct nfa *, int, pcolor, struct state *, struct state *));
static struct arc *allocarc _ANSI_ARGS_((struct nfa *, struct state *));
static VOID freearc _ANSI_ARGS_((struct nfa *, struct arc *));
static int hasnonemptyout _ANSI_ARGS_((struct state *));
static int nonemptyouts _ANSI_ARGS_((struct state *));
static int nonemptyins _ANSI_ARGS_((struct state *));
static struct arc *findarc _ANSI_ARGS_((struct state *, int, pcolor));
static VOID cparc _ANSI_ARGS_((struct nfa *, struct arc *, struct state *, struct state *));
static VOID moveins _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
static VOID copyins _ANSI_ARGS_((struct nfa *, struct state *, struct state *, int));
static VOID moveouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
static VOID copyouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *, int));
static VOID cloneouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *, int));
static VOID delsub _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
static VOID deltraverse _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
static VOID dupnfa _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *, struct state *));
static VOID duptraverse _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
static VOID cleartraverse _ANSI_ARGS_((struct nfa *, struct state *));
static VOID specialcolors _ANSI_ARGS_((struct nfa *));
static long optimize _ANSI_ARGS_((struct nfa *, FILE *));
static VOID pullback _ANSI_ARGS_((struct nfa *, FILE *));
static int pull _ANSI_ARGS_((struct nfa *, struct arc *));
static VOID pushfwd _ANSI_ARGS_((struct nfa *, FILE *));
static int push _ANSI_ARGS_((struct nfa *, struct arc *));
#define INCOMPATIBLE 1 /* destroys arc */
#define SATISFIED 2 /* constraint satisfied */
#define COMPATIBLE 3 /* compatible but not satisfied yet */
static int combine _ANSI_ARGS_((struct arc *, struct arc *));
static VOID fixempties _ANSI_ARGS_((struct nfa *, FILE *));
static struct state *emptyreachable _ANSI_ARGS_((struct state *, struct state *));
static VOID replaceempty _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
static VOID cleanup _ANSI_ARGS_((struct nfa *));
static VOID markreachable _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *));
static VOID markcanreach _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *));
static long analyze _ANSI_ARGS_((struct nfa *));
static VOID compact _ANSI_ARGS_((struct nfa *, struct cnfa *));
static VOID carcsort _ANSI_ARGS_((struct carc *, struct carc *));
static VOID freecnfa _ANSI_ARGS_((struct cnfa *));
static VOID dumpnfa _ANSI_ARGS_((struct nfa *, FILE *));
#ifdef REG_DEBUG
static VOID dumpstate _ANSI_ARGS_((struct state *, FILE *));
static VOID dumparcs _ANSI_ARGS_((struct state *, FILE *));
static int dumprarcs _ANSI_ARGS_((struct arc *, struct state *, FILE *, int));
static VOID dumparc _ANSI_ARGS_((struct arc *, struct state *, FILE *));
#endif
static VOID dumpcnfa _ANSI_ARGS_((struct cnfa *, FILE *));
#ifdef REG_DEBUG
static VOID dumpcstate _ANSI_ARGS_((int, struct carc *, struct cnfa *, FILE *));
#endif
/* === regc_cvec.c === */
static struct cvec *newcvec _ANSI_ARGS_((int, int, int));
static struct cvec *clearcvec _ANSI_ARGS_((struct cvec *));
static VOID addchr _ANSI_ARGS_((struct cvec *, pchr));
static VOID addrange _ANSI_ARGS_((struct cvec *, pchr, pchr));
static int haschr _ANSI_ARGS_((struct cvec *, pchr));
static struct cvec *getcvec _ANSI_ARGS_((struct vars *, int, int));
static VOID freecvec _ANSI_ARGS_((struct cvec *));
/* === regc_locale.c === */
static celt element _ANSI_ARGS_((struct vars *, CONST chr *, CONST chr *));
static struct cvec *range _ANSI_ARGS_((struct vars *, celt, celt, int));
static int before _ANSI_ARGS_((celt, celt));
static struct cvec *eclass _ANSI_ARGS_((struct vars *, celt, int));
static struct cvec *cclass _ANSI_ARGS_((struct vars *, CONST chr *, CONST chr *, int));
static struct cvec *allcases _ANSI_ARGS_((struct vars *, pchr));
static int cmp _ANSI_ARGS_((CONST chr *, CONST chr *, size_t));
static int casecmp _ANSI_ARGS_((CONST chr *, CONST chr *, size_t));
/* automatically gathered by fwd; do not hand-edit */
/* =====^!^===== end forwards =====^!^===== */
/* internal variables, bundled for easy passing around */
struct vars {
regex_t *re;
CONST chr *now; /* scan pointer into string */
CONST chr *stop; /* end of string */
CONST chr *savenow; /* saved now and stop for "subroutine call" */
CONST chr *savestop;
int err; /* error code (0 if none) */
int cflags; /* copy of compile flags */
int lasttype; /* type of previous token */
int nexttype; /* type of next token */
chr nextvalue; /* value (if any) of next token */
int lexcon; /* lexical context type (see lex.c) */
int nsubexp; /* subexpression count */
struct subre **subs; /* subRE pointer vector */
size_t nsubs; /* length of vector */
struct subre *sub10[10]; /* initial vector, enough for most */
struct nfa *nfa; /* the NFA */
struct colormap *cm; /* character color map */
color nlcolor; /* color of newline */
struct state *wordchrs; /* state in nfa holding word-char outarcs */
struct subre *tree; /* subexpression tree */
struct subre *treechain; /* all tree nodes allocated */
struct subre *treefree; /* any free tree nodes */
int ntree; /* number of tree nodes */
struct cvec *cv; /* interface cvec */
struct cvec *cv2; /* utility cvec */
struct cvec *mcces; /* collating-element information */
# define ISCELEADER(v,c) (v->mcces != NULL && haschr(v->mcces, (c)))
struct state *mccepbegin; /* in nfa, start of MCCE prototypes */
struct state *mccepend; /* in nfa, end of MCCE prototypes */
struct subre *lacons; /* lookahead-constraint vector */
int nlacons; /* size of lacons */
};
/* parsing macros; most know that `v' is the struct vars pointer */
#define NEXT() (next(v)) /* advance by one token */
#define SEE(t) (v->nexttype == (t)) /* is next token this? */
#define EAT(t) (SEE(t) && next(v)) /* if next is this, swallow it */
#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */
#define ISERR() VISERR(v)
#define VERR(vv,e) ((vv)->nexttype = EOS, ((vv)->err) ? (vv)->err :\
((vv)->err = (e)))
#define ERR(e) VERR(v, e) /* record an error */
#define NOERR() {if (ISERR()) return;} /* if error seen, return */
#define NOERRN() {if (ISERR()) return NULL;} /* NOERR with retval */
#define NOERRZ() {if (ISERR()) return 0;} /* NOERR with retval */
#define INSIST(c, e) ((c) ? 0 : ERR(e)) /* if condition false, error */
#define NOTE(b) (v->re->re_info |= (b)) /* note visible condition */
#define EMPTYARC(x, y) newarc(v->nfa, EMPTY, 0, x, y)
/* token type codes, some also used as NFA arc types */
#define EMPTY 'n' /* no token present */
#define EOS 'e' /* end of string */
#define PLAIN 'p' /* ordinary character */
#define DIGIT 'd' /* digit (in bound) */
#define BACKREF 'b' /* back reference */
#define COLLEL 'I' /* start of [. */
#define ECLASS 'E' /* start of [= */
#define CCLASS 'C' /* start of [: */
#define END 'X' /* end of [. [= [: */
#define RANGE 'R' /* - within [] which might be range delim. */
#define LACON 'L' /* lookahead constraint subRE */
#define AHEAD 'a' /* color-lookahead arc */
#define BEHIND 'r' /* color-lookbehind arc */
#define WBDRY 'w' /* word boundary constraint */
#define NWBDRY 'W' /* non-word-boundary constraint */
#define SBEGIN 'A' /* beginning of string (even if not BOL) */
#define SEND 'Z' /* end of string (even if not EOL) */
#define PREFER 'P' /* length preference */
/* is an arc colored, and hence on a color chain? */
#define COLORED(a) ((a)->type == PLAIN || (a)->type == AHEAD || \
(a)->type == BEHIND)
/* static function list */
static struct fns functions = {
rfree, /* regfree insides */
};
/*
- compile - compile regular expression
^ int compile(regex_t *, CONST chr *, size_t, int);
*/
int
compile(re, string, len, flags)
regex_t *re;
CONST chr *string;
size_t len;
int flags;
{
struct vars var;
struct vars *v = &var;
struct guts *g;
int i;
size_t j;
FILE *debug = (flags®_PROGRESS) ? stdout : (FILE *)NULL;
# define CNOERR() { if (ISERR()) return freev(v, v->err); }
/* sanity checks */
if (re == NULL || string == NULL)
return REG_INVARG;
if ((flags®_QUOTE) &&
(flags&(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE)))
return REG_INVARG;
if (!(flags®_EXTENDED) && (flags®_ADVF))
return REG_INVARG;
/* initial setup (after which freev() is callable) */
v->re = re;
v->now = (chr *)string;
v->stop = v->now + len;
v->savenow = v->savestop = NULL;
v->err = 0;
v->cflags = flags;
v->nsubexp = 0;
v->subs = v->sub10;
v->nsubs = 10;
for (j = 0; j < v->nsubs; j++)
v->subs[j] = NULL;
v->nfa = NULL;
v->cm = NULL;
v->nlcolor = COLORLESS;
v->wordchrs = NULL;
v->tree = NULL;
v->treechain = NULL;
v->treefree = NULL;
v->cv = NULL;
v->cv2 = NULL;
v->mcces = NULL;
v->lacons = NULL;
v->nlacons = 0;
re->re_magic = REMAGIC;
re->re_info = 0; /* bits get set during parse */
re->re_csize = sizeof(chr);
re->re_guts = NULL;
re->re_fns = VS(&functions);
/* more complex setup, malloced things */
re->re_guts = VS(MALLOC(sizeof(struct guts)));
if (re->re_guts == NULL)
return freev(v, REG_ESPACE);
g = (struct guts *)re->re_guts;
g->tree = NULL;
initcm(v, &g->cmap);
v->cm = &g->cmap;
g->lacons = NULL;
g->nlacons = 0;
ZAPCNFA(g->search);
v->nfa = newnfa(v, v->cm, (struct nfa *)NULL);
CNOERR();
v->cv = newcvec(100, 20, 10);
if (v->cv == NULL)
return freev(v, REG_ESPACE);
CNOERR();
/* parsing */
lexstart(v); /* also handles prefixes */
if ((v->cflags®_NLSTOP) || (v->cflags®_NLANCH)) {
/* assign newline a unique color */
v->nlcolor = subcolor(v->cm, newline());
okcolors(v->nfa, v->cm);
}
CNOERR();
v->tree = parse(v, EOS, PLAIN, v->nfa->init, v->nfa->final);
assert(SEE(EOS)); /* even if error; ISERR() => SEE(EOS) */
CNOERR();
assert(v->tree != NULL);
/* finish setup of nfa and its subre tree */
specialcolors(v->nfa);
CNOERR();
if (debug != NULL) {
fprintf(debug, "\n\n\n========= RAW ==========\n");
dumpnfa(v->nfa, debug);
dumpst(v->tree, debug, 1);
}
optst(v, v->tree);
v->ntree = numst(v->tree, 1);
markst(v->tree);
cleanst(v);
if (debug != NULL) {
fprintf(debug, "\n\n\n========= TREE FIXED ==========\n");
dumpst(v->tree, debug, 1);
}
/* build compacted NFAs for tree and lacons */
re->re_info |= nfatree(v, v->tree, debug);
CNOERR();
assert(v->nlacons == 0 || v->lacons != NULL);
for (i = 1; i < v->nlacons; i++) {
if (debug != NULL)
fprintf(debug, "\n\n\n========= LA%d ==========\n", i);
nfanode(v, &v->lacons[i], debug);
}
CNOERR();
if (v->tree->flags&SHORTER)
NOTE(REG_USHORTEST);
/* build compacted NFAs for tree, lacons, fast search */
if (debug != NULL)
fprintf(debug, "\n\n\n========= SEARCH ==========\n");
/* can sacrifice main NFA now, so use it as work area */
(DISCARD)optimize(v->nfa, debug);
CNOERR();
makesearch(v, v->nfa);
CNOERR();
compact(v->nfa, &g->search);
CNOERR();
/* looks okay, package it up */
re->re_nsub = v->nsubexp;
v->re = NULL; /* freev no longer frees re */
g->magic = GUTSMAGIC;
g->cflags = v->cflags;
g->info = re->re_info;
g->nsub = re->re_nsub;
g->tree = v->tree;
v->tree = NULL;
g->ntree = v->ntree;
g->compare = (v->cflags®_ICASE) ? casecmp : cmp;
g->lacons = v->lacons;
v->lacons = NULL;
g->nlacons = v->nlacons;
if (flags®_DUMP)
dump(re, stdout);
assert(v->err == 0);
return freev(v, 0);
}
/*
- moresubs - enlarge subRE vector
^ static VOID moresubs(struct vars *, int);
*/
static VOID
moresubs(v, wanted)
struct vars *v;
int wanted; /* want enough room for this one */
{
struct subre **p;
size_t n;
assert(wanted > 0 && (size_t)wanted >= v->nsubs);
n = (size_t)wanted * 3 / 2 + 1;
if (v->subs == v->sub10) {
p = (struct subre **)MALLOC(n * sizeof(struct subre *));
if (p != NULL)
memcpy(VS(p), VS(v->subs),
v->nsubs * sizeof(struct subre *));
} else
p = (struct subre **)REALLOC(v->subs, n*sizeof(struct subre *));
if (p == NULL) {
ERR(REG_ESPACE);
return;
}
v->subs = p;
for (p = &v->subs[v->nsubs]; v->nsubs < n; p++, v->nsubs++)
*p = NULL;
assert(v->nsubs == n);
assert((size_t)wanted < v->nsubs);
}
/*
- freev - free vars struct's substructures where necessary
* Optionally does error-number setting, and always returns error code
* (if any), to make error-handling code terser.
^ static int freev(struct vars *, int);
*/
static int
freev(v, err)
struct vars *v;
int err;
{
if (v->re != NULL)
rfree(v->re);
if (v->subs != v->sub10)
FREE(v->subs);
if (v->nfa != NULL)
freenfa(v->nfa);
if (v->tree != NULL)
freesubre(v, v->tree);
if (v->treechain != NULL)
cleanst(v);
if (v->cv != NULL)
freecvec(v->cv);
if (v->cv2 != NULL)
freecvec(v->cv2);
if (v->mcces != NULL)
freecvec(v->mcces);
if (v->lacons != NULL)
freelacons(v->lacons, v->nlacons);
ERR(err); /* nop if err==0 */
return v->err;
}
/*
- makesearch - turn an NFA into a search NFA (implicit prepend of .*?)
* NFA must have been optimize()d already.
^ static VOID makesearch(struct vars *, struct nfa *);
*/
static VOID
makesearch(v, nfa)
struct vars *v;
struct nfa *nfa;
{
struct arc *a;
struct arc *b;
struct state *pre = nfa->pre;
struct state *s;
struct state *s2;
struct state *slist;
/* no loops are needed if it's anchored */
for (a = pre->outs; a != NULL; a = a->outchain) {
assert(a->type == PLAIN);
if (a->co != nfa->bos[0] && a->co != nfa->bos[1])
break;
}
if (a != NULL) {
/* add implicit .* in front */
rainbow(nfa, v->cm, PLAIN, COLORLESS, pre, pre);
/* and ^* and \A* too -- not always necessary, but harmless */
newarc(nfa, PLAIN, nfa->bos[0], pre, pre);
newarc(nfa, PLAIN, nfa->bos[1], pre, pre);
}
/*
* Now here's the subtle part. Because many REs have no lookback
* constraints, often knowing when you were in the pre state tells
* you little; it's the next state(s) that are informative. But
* some of them may have other inarcs, i.e. it may be possible to
* make actual progress and then return to one of them. We must
* de-optimize such cases, splitting each such state into progress
* and no-progress states.
*/
/* first, make a list of the states */
slist = NULL;
for (a = pre->outs; a != NULL; a = a->outchain) {
s = a->to;
for (b = s->ins; b != NULL; b = b->inchain)
if (b->from != pre)
break;
if (b != NULL) { /* must be split */
if (s->tmp == NULL) { /* if not already in the list */
/* (fixes bugs 505048, 230589, */
/* 840258, 504785) */
s->tmp = slist;
slist = s;
}
}
}
/* do the splits */
for (s = slist; s != NULL; s = s2) {
s2 = newstate(nfa);
copyouts(nfa, s, s2, 1);
for (a = s->ins; a != NULL; a = b) {
b = a->inchain;
if (a->from != pre) {
cparc(nfa, a, a->from, s2);
freearc(nfa, a);
}
}
s2 = s->tmp;
s->tmp = NULL; /* clean up while we're at it */
}
}
/*
- parse - parse an RE
* This is actually just the top level, which parses a bunch of branches
* tied together with '|'. They appear in the tree as the left children
* of a chain of '|' subres.
^ static struct subre *parse(struct vars *, int, int, struct state *,
^ struct state *);
*/
static struct subre *
parse(v, stopper, type, init, final)
struct vars *v;
int stopper; /* EOS or ')' */
int type; /* LACON (lookahead subRE) or PLAIN */
struct state *init; /* initial state */
struct state *final; /* final state */
{
struct state *left; /* scaffolding for branch */
struct state *right;
struct subre *branches; /* top level */
struct subre *branch; /* current branch */
struct subre *t; /* temporary */
int firstbranch; /* is this the first branch? */
assert(stopper == ')' || stopper == EOS);
branches = subre(v, '|', LONGER, init, final);
NOERRN();
branch = branches;
firstbranch = 1;
do { /* a branch */
if (!firstbranch) {
/* need a place to hang it */
branch->right = subre(v, '|', LONGER, init, final);
NOERRN();
branch = branch->right;
}
firstbranch = 0;
left = newstate(v->nfa);
right = newstate(v->nfa);
NOERRN();
EMPTYARC(init, left);
EMPTYARC(right, final);
NOERRN();
branch->left = parsebranch(v, stopper, type, left, right, 0);
NOERRN();
branch->flags |= UP(branch->flags | branch->left->flags);
if ((branch->flags &~ branches->flags) != 0) /* new flags */
for (t = branches; t != branch; t = t->right)
t->flags |= branch->flags;
} while (EAT('|'));
assert(SEE(stopper) || SEE(EOS));
if (!SEE(stopper)) {
assert(stopper == ')' && SEE(EOS));
ERR(REG_EPAREN);
}
/* optimize out simple cases */
if (branch == branches) { /* only one branch */
assert(branch->right == NULL);
t = branch->left;
branch->left = NULL;
freesubre(v, branches);
branches = t;
} else if (!MESSY(branches->flags)) { /* no interesting innards */
freesubre(v, branches->left);
branches->left = NULL;
freesubre(v, branches->right);
branches->right = NULL;
branches->op = '=';
}
return branches;
}
/*
- parsebranch - parse one branch of an RE
* This mostly manages concatenation, working closely with parseqatom().
* Concatenated things are bundled up as much as possible, with separate
* ',' nodes introduced only when necessary due to substructure.
^ static struct subre *parsebranch(struct vars *, int, int, struct state *,
^ struct state *, int);
*/
static struct subre *
parsebranch(v, stopper, type, left, right, partial)
struct vars *v;
int stopper; /* EOS or ')' */
int type; /* LACON (lookahead subRE) or PLAIN */
struct state *left; /* leftmost state */
struct state *right; /* rightmost state */
int partial; /* is this only part of a branch? */
{
struct state *lp; /* left end of current construct */
int seencontent; /* is there anything in this branch yet? */
struct subre *t;
lp = left;
seencontent = 0;
t = subre(v, '=', 0, left, right); /* op '=' is tentative */
NOERRN();
while (!SEE('|') && !SEE(stopper) && !SEE(EOS)) {
if (seencontent) { /* implicit concat operator */
lp = newstate(v->nfa);
NOERRN();
moveins(v->nfa, right, lp);
}
seencontent = 1;
/* NB, recursion in parseqatom() may swallow rest of branch */
parseqatom(v, stopper, type, lp, right, t);
NOERRN();
}
if (!seencontent) { /* empty branch */
if (!partial)
NOTE(REG_UUNSPEC);
assert(lp == left);
EMPTYARC(left, right);
}
return t;
}
/*
- parseqatom - parse one quantified atom or constraint of an RE
* The bookkeeping near the end cooperates very closely with parsebranch();
* in particular, it contains a recursion that can involve parsing the rest
* of the branch, making this function's name somewhat inaccurate.
^ static VOID parseqatom(struct vars *, int, int, struct state *,
^ struct state *, struct subre *);
*/
static VOID
parseqatom(v, stopper, type, lp, rp, top)
struct vars *v;
int stopper; /* EOS or ')' */
int type; /* LACON (lookahead subRE) or PLAIN */
struct state *lp; /* left state to hang it on */
struct state *rp; /* right state to hang it on */
struct subre *top; /* subtree top */
{
struct state *s; /* temporaries for new states */
struct state *s2;
# define ARCV(t, val) newarc(v->nfa, t, val, lp, rp)
int m, n;
struct subre *atom; /* atom's subtree */
struct subre *t;
int cap; /* capturing parens? */
int pos; /* positive lookahead? */
int subno; /* capturing-parens or backref number */
int atomtype;
int qprefer; /* quantifier short/long preference */
int f;
struct subre **atomp; /* where the pointer to atom is */
/* initial bookkeeping */
atom = NULL;
assert(lp->nouts == 0); /* must string new code */
assert(rp->nins == 0); /* between lp and rp */
subno = 0; /* just to shut lint up */
/* an atom or constraint... */
atomtype = v->nexttype;
switch (atomtype) {
/* first, constraints, which end by returning */
case '^':
ARCV('^', 1);
if (v->cflags®_NLANCH)
ARCV(BEHIND, v->nlcolor);
NEXT();
return;
break;
case '$':
ARCV('$', 1);
if (v->cflags®_NLANCH)
ARCV(AHEAD, v->nlcolor);
NEXT();
return;
break;
case SBEGIN:
ARCV('^', 1); /* BOL */
ARCV('^', 0); /* or BOS */
NEXT();
return;
break;
case SEND:
ARCV('$', 1); /* EOL */
ARCV('$', 0); /* or EOS */
NEXT();
return;
break;
case '<':
wordchrs(v); /* does NEXT() */
s = newstate(v->nfa);
NOERR();
nonword(v, BEHIND, lp, s);
word(v, AHEAD, s, rp);
return;
break;
case '>':
wordchrs(v); /* does NEXT() */
s = newstate(v->nfa);
NOERR();
word(v, BEHIND, lp, s);
nonword(v, AHEAD, s, rp);
return;
break;
case WBDRY:
wordchrs(v); /* does NEXT() */
s = newstate(v->nfa);
NOERR();
nonword(v, BEHIND, lp, s);
word(v, AHEAD, s, rp);
s = newstate(v->nfa);
NOERR();
word(v, BEHIND, lp, s);
nonword(v, AHEAD, s, rp);
return;
break;
case NWBDRY:
wordchrs(v); /* does NEXT() */
s = newstate(v->nfa);
NOERR();
word(v, BEHIND, lp, s);
word(v, AHEAD, s, rp);
s = newstate(v->nfa);
NOERR();
nonword(v, BEHIND, lp, s);
nonword(v, AHEAD, s, rp);
return;
break;
case LACON: /* lookahead constraint */
pos = v->nextvalue;
NEXT();
s = newstate(v->nfa);
s2 = newstate(v->nfa);
NOERR();
t = parse(v, ')', LACON, s, s2);
freesubre(v, t); /* internal structure irrelevant */
assert(SEE(')') || ISERR());
NEXT();
n = newlacon(v, s, s2, pos);
NOERR();
ARCV(LACON, n);
return;
break;
/* then errors, to get them out of the way */
case '*':
case '+':
case '?':
case '{':
ERR(REG_BADRPT);
return;
break;
default:
ERR(REG_ASSERT);
return;
break;
/* then plain characters, and minor variants on that theme */
case ')': /* unbalanced paren */
if ((v->cflags®_ADVANCED) != REG_EXTENDED) {
ERR(REG_EPAREN);
return;
}
/* legal in EREs due to specification botch */
NOTE(REG_UPBOTCH);
/* fallthrough into case PLAIN */
case PLAIN:
onechr(v, v->nextvalue, lp, rp);
okcolors(v->nfa, v->cm);
NOERR();
NEXT();
break;
case '[':
if (v->nextvalue == 1)
bracket(v, lp, rp);
else
cbracket(v, lp, rp);
assert(SEE(']') || ISERR());
NEXT();
break;
case '.':
rainbow(v->nfa, v->cm, PLAIN,
(v->cflags®_NLSTOP) ? v->nlcolor : COLORLESS,
lp, rp);
NEXT();
break;
/* and finally the ugly stuff */
case '(': /* value flags as capturing or non */
cap = (type == LACON) ? 0 : v->nextvalue;
if (cap) {
v->nsubexp++;
subno = v->nsubexp;
if ((size_t)subno >= v->nsubs)
moresubs(v, subno);
assert((size_t)subno < v->nsubs);
} else
atomtype = PLAIN; /* something that's not '(' */
NEXT();
/* need new endpoints because tree will contain pointers */
s = newstate(v->nfa);
s2 = newstate(v->nfa);
NOERR();
EMPTYARC(lp, s);
EMPTYARC(s2, rp);
NOERR();
atom = parse(v, ')', PLAIN, s, s2);
assert(SEE(')') || ISERR());
NEXT();
NOERR();
if (cap) {
v->subs[subno] = atom;
t = subre(v, '(', atom->flags|CAP, lp, rp);
NOERR();
t->subno = subno;
t->left = atom;
atom = t;
}
/* postpone everything else pending possible {0} */
break;
case BACKREF: /* the Feature From The Black Lagoon */
INSIST(type != LACON, REG_ESUBREG);
INSIST(v->nextvalue < v->nsubs, REG_ESUBREG);
INSIST(v->subs[v->nextvalue] != NULL, REG_ESUBREG);
NOERR();
assert(v->nextvalue > 0);
atom = subre(v, 'b', BACKR, lp, rp);
subno = v->nextvalue;
atom->subno = subno;
EMPTYARC(lp, rp); /* temporarily, so there's something */
NEXT();
break;
}
/* ...and an atom may be followed by a quantifier */
switch (v->nexttype) {
case '*':
m = 0;
n = INFINITY;
qprefer = (v->nextvalue) ? LONGER : SHORTER;
NEXT();
break;
case '+':
m = 1;
n = INFINITY;
qprefer = (v->nextvalue) ? LONGER : SHORTER;
NEXT();
break;
case '?':
m = 0;
n = 1;
qprefer = (v->nextvalue) ? LONGER : SHORTER;
NEXT();
break;
case '{':
NEXT();
m = scannum(v);
if (EAT(',')) {
if (SEE(DIGIT))
n = scannum(v);
else
n = INFINITY;
if (m > n) {
ERR(REG_BADBR);
return;
}
/* {m,n} exercises preference, even if it's {m,m} */
qprefer = (v->nextvalue) ? LONGER : SHORTER;
} else {
n = m;
/* {m} passes operand's preference through */
qprefer = 0;
}
if (!SEE('}')) { /* catches errors too */
ERR(REG_BADBR);
return;
}
NEXT();
break;
default: /* no quantifier */
m = n = 1;
qprefer = 0;
break;
}
/* annoying special case: {0} or {0,0} cancels everything */
if (m == 0 && n == 0) {
if (atom != NULL)
freesubre(v, atom);
if (atomtype == '(')
v->subs[subno] = NULL;
delsub(v->nfa, lp, rp);
EMPTYARC(lp, rp);
return;
}
/* if not a messy case, avoid hard part */
assert(!MESSY(top->flags));
f = top->flags | qprefer | ((atom != NULL) ? atom->flags : 0);
if (atomtype != '(' && atomtype != BACKREF && !MESSY(UP(f))) {
if (!(m == 1 && n == 1))
repeat(v, lp, rp, m, n);
if (atom != NULL)
freesubre(v, atom);
top->flags = f;
return;
}
/*
* hard part: something messy
* That is, capturing parens, back reference, short/long clash, or
* an atom with substructure containing one of those.
*/
/* now we'll need a subre for the contents even if they're boring */
if (atom == NULL) {
atom = subre(v, '=', 0, lp, rp);
NOERR();
}
/*
* prepare a general-purpose state skeleton
*
* ---> [s] ---prefix---> [begin] ---atom---> [end] ----rest---> [rp]
* / /
* [lp] ----> [s2] ----bypass---------------------
*
* where bypass is an empty, and prefix is some repetitions of atom
*/
s = newstate(v->nfa); /* first, new endpoints for the atom */
s2 = newstate(v->nfa);
NOERR();
moveouts(v->nfa, lp, s);
moveins(v->nfa, rp, s2);
NOERR();
atom->begin = s;
atom->end = s2;
s = newstate(v->nfa); /* and spots for prefix and bypass */
s2 = newstate(v->nfa);
NOERR();
EMPTYARC(lp, s);
EMPTYARC(lp, s2);
NOERR();
/* break remaining subRE into x{...} and what follows */
t = subre(v, '.', COMBINE(qprefer, atom->flags), lp, rp);
t->left = atom;
atomp = &t->left;
/* here we should recurse... but we must postpone that to the end */
/* split top into prefix and remaining */
assert(top->op == '=' && top->left == NULL && top->right == NULL);
top->left = subre(v, '=', top->flags, top->begin, lp);
top->op = '.';
top->right = t;
/* if it's a backref, now is the time to replicate the subNFA */
if (atomtype == BACKREF) {
assert(atom->begin->nouts == 1); /* just the EMPTY */
delsub(v->nfa, atom->begin, atom->end);
assert(v->subs[subno] != NULL);
/* and here's why the recursion got postponed: it must */
/* wait until the skeleton is filled in, because it may */
/* hit a backref that wants to copy the filled-in skeleton */
dupnfa(v->nfa, v->subs[subno]->begin, v->subs[subno]->end,
atom->begin, atom->end);
NOERR();
}
/* it's quantifier time; first, turn x{0,...} into x{1,...}|empty */
if (m == 0) {
EMPTYARC(s2, atom->end); /* the bypass */
assert(PREF(qprefer) != 0);
f = COMBINE(qprefer, atom->flags);
t = subre(v, '|', f, lp, atom->end);
NOERR();
t->left = atom;
t->right = subre(v, '|', PREF(f), s2, atom->end);
NOERR();
t->right->left = subre(v, '=', 0, s2, atom->end);
NOERR();
*atomp = t;
atomp = &t->left;
m = 1;
}
/* deal with the rest of the quantifier */
if (atomtype == BACKREF) {
/* special case: backrefs have internal quantifiers */
EMPTYARC(s, atom->begin); /* empty prefix */
/* just stuff everything into atom */
repeat(v, atom->begin, atom->end, m, n);
atom->min = (short)m;
atom->max = (short)n;
atom->flags |= COMBINE(qprefer, atom->flags);
} else if (m == 1 && n == 1) {
/* no/vacuous quantifier: done */
EMPTYARC(s, atom->begin); /* empty prefix */
} else {
/* turn x{m,n} into x{m-1,n-1}x, with capturing */
/* parens in only second x */
dupnfa(v->nfa, atom->begin, atom->end, s, atom->begin);
assert(m >= 1 && m != INFINITY && n >= 1);
repeat(v, s, atom->begin, m-1, (n == INFINITY) ? n : n-1);
f = COMBINE(qprefer, atom->flags);
t = subre(v, '.', f, s, atom->end); /* prefix and atom */
NOERR();
t->left = subre(v, '=', PREF(f), s, atom->begin);
NOERR();
t->right = atom;
*atomp = t;
}
/* and finally, look after that postponed recursion */
t = top->right;
if (!(SEE('|') || SEE(stopper) || SEE(EOS)))
t->right = parsebranch(v, stopper, type, atom->end, rp, 1);
else {
EMPTYARC(atom->end, rp);
t->right = subre(v, '=', 0, atom->end, rp);
}
NOERR();
assert(SEE('|') || SEE(stopper) || SEE(EOS));
t->flags |= COMBINE(t->flags, t->right->flags);
top->flags |= COMBINE(top->flags, t->flags);
}
/*
- nonword - generate arcs for non-word-character ahead or behind
^ static VOID nonword(struct vars *, int, struct state *, struct state *);
*/
static VOID
nonword(v, dir, lp, rp)
struct vars *v;
int dir; /* AHEAD or BEHIND */
struct state *lp;
struct state *rp;
{
int anchor = (dir == AHEAD) ? '$' : '^';
assert(dir == AHEAD || dir == BEHIND);
newarc(v->nfa, anchor, 1, lp, rp);
newarc(v->nfa, anchor, 0, lp, rp);
colorcomplement(v->nfa, v->cm, dir, v->wordchrs, lp, rp);
/* (no need for special attention to \n) */
}
/*
- word - generate arcs for word character ahead or behind
^ static VOID word(struct vars *, int, struct state *, struct state *);
*/
static VOID
word(v, dir, lp, rp)
struct vars *v;
int dir; /* AHEAD or BEHIND */
struct state *lp;
struct state *rp;
{
assert(dir == AHEAD || dir == BEHIND);
cloneouts(v->nfa, v->wordchrs, lp, rp, dir);
/* (no need for special attention to \n) */
}
/*
- scannum - scan a number
^ static int scannum(struct vars *);
*/
static int /* value, <= DUPMAX */
scannum(v)
struct vars *v;
{
int n = 0;
while (SEE(DIGIT) && n < DUPMAX) {
n = n*10 + v->nextvalue;
NEXT();
}
if (SEE(DIGIT) || n > DUPMAX) {
ERR(REG_BADBR);
return 0;
}
return n;
}
/*
- repeat - replicate subNFA for quantifiers
* The duplication sequences used here are chosen carefully so that any
* pointers starting out pointing into the subexpression end up pointing into
* the last occurrence. (Note that it may not be strung between the same
* left and right end states, however!) This used to be important for the
* subRE tree, although the important bits are now handled by the in-line
* code in parse(), and when this is called, it doesn't matter any more.
^ static VOID repeat(struct vars *, struct state *, struct state *, int, int);
*/
static VOID
repeat(v, lp, rp, m, n)
struct vars *v;
struct state *lp;
struct state *rp;
int m;
int n;
{
# define SOME 2
# define INF 3
# define PAIR(x, y) ((x)*4 + (y))
# define REDUCE(x) ( ((x) == INFINITY) ? INF : (((x) > 1) ? SOME : (x)) )
CONST int rm = REDUCE(m);
CONST int rn = REDUCE(n);
struct state *s;
struct state *s2;
switch (PAIR(rm, rn)) {
case PAIR(0, 0): /* empty string */
delsub(v->nfa, lp, rp);
EMPTYARC(lp, rp);
break;
case PAIR(0, 1): /* do as x| */
EMPTYARC(lp, rp);
break;
case PAIR(0, SOME): /* do as x{1,n}| */
repeat(v, lp, rp, 1, n);
NOERR();
EMPTYARC(lp, rp);
break;
case PAIR(0, INF): /* loop x around */
s = newstate(v->nfa);
NOERR();
moveouts(v->nfa, lp, s);
moveins(v->nfa, rp, s);
EMPTYARC(lp, s);
EMPTYARC(s, rp);
break;
case PAIR(1, 1): /* no action required */
break;
case PAIR(1, SOME): /* do as x{0,n-1}x = (x{1,n-1}|)x */
s = newstate(v->nfa);
NOERR();
moveouts(v->nfa, lp, s);
dupnfa(v->nfa, s, rp, lp, s);
NOERR();
repeat(v, lp, s, 1, n-1);
NOERR();
EMPTYARC(lp, s);
break;
case PAIR(1, INF): /* add loopback arc */
s = newstate(v->nfa);
s2 = newstate(v->nfa);
NOERR();
moveouts(v->nfa, lp, s);
moveins(v->nfa, rp, s2);
EMPTYARC(lp, s);
EMPTYARC(s2, rp);
EMPTYARC(s2, s);
break;
case PAIR(SOME, SOME): /* do as x{m-1,n-1}x */
s = newstate(v->nfa);
NOERR();
moveouts(v->nfa, lp, s);
dupnfa(v->nfa, s, rp, lp, s);
NOERR();
repeat(v, lp, s, m-1, n-1);
break;
case PAIR(SOME, INF): /* do as x{m-1,}x */
s = newstate(v->nfa);
NOERR();
moveouts(v->nfa, lp, s);
dupnfa(v->nfa, s, rp, lp, s);
NOERR();
repeat(v, lp, s, m-1, n);
break;
default:
ERR(REG_ASSERT);
break;
}
}
/*
- bracket - handle non-complemented bracket expression
* Also called from cbracket for complemented bracket expressions.
^ static VOID bracket(struct vars *, struct state *, struct state *);
*/
static VOID
bracket(v, lp, rp)
struct vars *v;
struct state *lp;
struct state *rp;
{
assert(SEE('['));
NEXT();
while (!SEE(']') && !SEE(EOS))
brackpart(v, lp, rp);
assert(SEE(']') || ISERR());
okcolors(v->nfa, v->cm);
}
/*
- cbracket - handle complemented bracket expression
* We do it by calling bracket() with dummy endpoints, and then complementing
* the result. The alternative would be to invoke rainbow(), and then delete
* arcs as the b.e. is seen... but that gets messy.
^ static VOID cbracket(struct vars *, struct state *, struct state *);
*/
static VOID
cbracket(v, lp, rp)
struct vars *v;
struct state *lp;
struct state *rp;
{
struct state *left = newstate(v->nfa);
struct state *right = newstate(v->nfa);
struct state *s;
struct arc *a; /* arc from lp */
struct arc *ba; /* arc from left, from bracket() */
struct arc *pa; /* MCCE-prototype arc */
color co;
chr *p;
int i;
NOERR();
bracket(v, left, right);
if (v->cflags®_NLSTOP)
newarc(v->nfa, PLAIN, v->nlcolor, left, right);
NOERR();
assert(lp->nouts == 0); /* all outarcs will be ours */
/* easy part of complementing */
colorcomplement(v->nfa, v->cm, PLAIN, left, lp, rp);
NOERR();
if (v->mcces == NULL) { /* no MCCEs -- we're done */
dropstate(v->nfa, left);
assert(right->nins == 0);
freestate(v->nfa, right);
return;
}
/* but complementing gets messy in the presence of MCCEs... */
NOTE(REG_ULOCALE);
for (p = v->mcces->chrs, i = v->mcces->nchrs; i > 0; p++, i--) {
co = GETCOLOR(v->cm, *p);
a = findarc(lp, PLAIN, co);
ba = findarc(left, PLAIN, co);
if (ba == NULL) {
assert(a != NULL);
freearc(v->nfa, a);
} else {
assert(a == NULL);
}
s = newstate(v->nfa);
NOERR();
newarc(v->nfa, PLAIN, co, lp, s);
NOERR();
pa = findarc(v->mccepbegin, PLAIN, co);
assert(pa != NULL);
if (ba == NULL) { /* easy case, need all of them */
cloneouts(v->nfa, pa->to, s, rp, PLAIN);
newarc(v->nfa, '$', 1, s, rp);
newarc(v->nfa, '$', 0, s, rp);
colorcomplement(v->nfa, v->cm, AHEAD, pa->to, s, rp);
} else { /* must be selective */
if (findarc(ba->to, '$', 1) == NULL) {
newarc(v->nfa, '$', 1, s, rp);
newarc(v->nfa, '$', 0, s, rp);
colorcomplement(v->nfa, v->cm, AHEAD, pa->to,
s, rp);
}
for (pa = pa->to->outs; pa != NULL; pa = pa->outchain)
if (findarc(ba->to, PLAIN, pa->co) == NULL)
newarc(v->nfa, PLAIN, pa->co, s, rp);
if (s->nouts == 0) /* limit of selectivity: none */
dropstate(v->nfa, s); /* frees arc too */
}
NOERR();
}
delsub(v->nfa, left, right);
assert(left->nouts == 0);
freestate(v->nfa, left);
assert(right->nins == 0);
freestate(v->nfa, right);
}
/*
- brackpart - handle one item (or range) within a bracket expression
^ static VOID brackpart(struct vars *, struct state *, struct state *);
*/
static VOID
brackpart(v, lp, rp)
struct vars *v;
struct state *lp;
struct state *rp;
{
celt startc;
celt endc;
struct cvec *cv;
CONST chr *startp;
CONST chr *endp;
chr c[1];
/* parse something, get rid of special cases, take shortcuts */
switch (v->nexttype) {
case RANGE: /* a-b-c or other botch */
ERR(REG_ERANGE);
return;
break;
case PLAIN:
c[0] = v->nextvalue;
NEXT();
/* shortcut for ordinary chr (not range, not MCCE leader) */
if (!SEE(RANGE) && !ISCELEADER(v, c[0])) {
onechr(v, c[0], lp, rp);
return;
}
startc = element(v, c, c+1);
NOERR();
break;
case COLLEL:
startp = v->now;
endp = scanplain(v);
INSIST(startp < endp, REG_ECOLLATE);
NOERR();
startc = element(v, startp, endp);
NOERR();
break;
case ECLASS:
startp = v->now;
endp = scanplain(v);
INSIST(startp < endp, REG_ECOLLATE);
NOERR();
startc = element(v, startp, endp);
NOERR();
cv = eclass(v, startc, (v->cflags®_ICASE));
NOERR();
dovec(v, cv, lp, rp);
return;
break;
case CCLASS:
startp = v->now;
endp = scanplain(v);
INSIST(startp < endp, REG_ECTYPE);
NOERR();
cv = cclass(v, startp, endp, (v->cflags®_ICASE));
NOERR();
dovec(v, cv, lp, rp);
return;
break;
default:
ERR(REG_ASSERT);
return;
break;
}
if (SEE(RANGE)) {
NEXT();
switch (v->nexttype) {
case PLAIN:
case RANGE:
c[0] = v->nextvalue;
NEXT();
endc = element(v, c, c+1);
NOERR();
break;
case COLLEL:
startp = v->now;
endp = scanplain(v);
INSIST(startp < endp, REG_ECOLLATE);
NOERR();
endc = element(v, startp, endp);
NOERR();
break;
default:
ERR(REG_ERANGE);
return;
break;
}
} else
endc = startc;
/*
* Ranges are unportable. Actually, standard C does
* guarantee that digits are contiguous, but making
* that an exception is just too complicated.
*/
if (startc != endc)
NOTE(REG_UUNPORT);
cv = range(v, startc, endc, (v->cflags®_ICASE));
NOERR();
dovec(v, cv, lp, rp);
}
/*
- scanplain - scan PLAIN contents of [. etc.
* Certain bits of trickery in lex.c know that this code does not try
* to look past the final bracket of the [. etc.
^ static chr *scanplain(struct vars *);
*/
static CONST chr * /* just after end of sequence */
scanplain(v)
struct vars *v;
{
CONST chr *endp;
assert(SEE(COLLEL) || SEE(ECLASS) || SEE(CCLASS));
NEXT();
endp = v->now;
while (SEE(PLAIN)) {
endp = v->now;
NEXT();
}
assert(SEE(END) || ISERR());
NEXT();
return endp;
}
/*
- onechr - fill in arcs for a plain character, and possible case complements
* This is mostly a shortcut for efficient handling of the common case.
^ static VOID onechr(struct vars *, pchr, struct state *, struct state *);
*/
static VOID
onechr(v, c, lp, rp)
struct vars *v;
pchr c;
struct state *lp;
struct state *rp;
{
if (!(v->cflags®_ICASE)) {
newarc(v->nfa, PLAIN, subcolor(v->cm, c), lp, rp);
return;
}
/* rats, need general case anyway... */
dovec(v, allcases(v, c), lp, rp);
}
/*
- dovec - fill in arcs for each element of a cvec
* This one has to handle the messy cases, like MCCEs and MCCE leaders.
^ static VOID dovec(struct vars *, struct cvec *, struct state *,
^ struct state *);
*/
static VOID
dovec(v, cv, lp, rp)
struct vars *v;
struct cvec *cv;
struct state *lp;
struct state *rp;
{
chr ch, from, to;
celt ce;
chr *p;
int i;
color co;
struct cvec *leads;
struct arc *a;
struct arc *pa; /* arc in prototype */
struct state *s;
struct state *ps; /* state in prototype */
leads = NULL;
/* first, get the ordinary characters out of the way */
for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) {
ch = *p;
if (!ISCELEADER(v, ch))
newarc(v->nfa, PLAIN, subcolor(v->cm, ch), lp, rp);
else {
assert(singleton(v->cm, ch));
assert(leads != NULL);
if (!haschr(leads, ch))
addchr(leads, ch);
}
}
/* and the ranges */
for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) {
from = *p;
to = *(p+1);
while (from <= to && (ce = nextleader(v, from, to)) != NOCELT) {
if (from < ce)
subrange(v, from, ce - 1, lp, rp);
assert(singleton(v->cm, ce));
assert(leads != NULL);
if (!haschr(leads, ce))
addchr(leads, ce);
from = ce + 1;
}
if (from <= to)
subrange(v, from, to, lp, rp);
}
if ((leads == NULL || leads->nchrs == 0) && cv->nmcces == 0)
return;
/* deal with the MCCE leaders */
NOTE(REG_ULOCALE);
for (p = leads->chrs, i = leads->nchrs; i > 0; p++, i--) {
co = GETCOLOR(v->cm, *p);
a = findarc(lp, PLAIN, co);
if (a != NULL)
s = a->to;
else {
s = newstate(v->nfa);
NOERR();
newarc(v->nfa, PLAIN, co, lp, s);
NOERR();
}
pa = findarc(v->mccepbegin, PLAIN, co);
assert(pa != NULL);
ps = pa->to;
newarc(v->nfa, '$', 1, s, rp);
newarc(v->nfa, '$', 0, s, rp);
colorcomplement(v->nfa, v->cm, AHEAD, ps, s, rp);
NOERR();
}
/* and the MCCEs */
for (i = 0; i < cv->nmcces; i++) {
p = cv->mcces[i];
assert(singleton(v->cm, *p));
if (!singleton(v->cm, *p)) {
ERR(REG_ASSERT);
return;
}
ch = *p++;
co = GETCOLOR(v->cm, ch);
a = findarc(lp, PLAIN, co);
if (a != NULL)
s = a->to;
else {
s = newstate(v->nfa);
NOERR();
newarc(v->nfa, PLAIN, co, lp, s);
NOERR();
}
assert(*p != 0); /* at least two chars */
assert(singleton(v->cm, *p));
ch = *p++;
co = GETCOLOR(v->cm, ch);
assert(*p == 0); /* and only two, for now */
newarc(v->nfa, PLAIN, co, s, rp);
NOERR();
}
}
/*
- nextleader - find next MCCE leader within range
^ static celt nextleader(struct vars *, pchr, pchr);
*/
static celt /* NOCELT means none */
nextleader(v, from, to)
struct vars *v;
pchr from;
pchr to;
{
int i;
chr *p;
chr ch;
celt it = NOCELT;
if (v->mcces == NULL)
return it;
for (i = v->mcces->nchrs, p = v->mcces->chrs; i > 0; i--, p++) {
ch = *p;
if (from <= ch && ch <= to)
if (it == NOCELT || ch < it)
it = ch;
}
return it;
}
/*
- wordchrs - set up word-chr list for word-boundary stuff, if needed
* The list is kept as a bunch of arcs between two dummy states; it's
* disposed of by the unreachable-states sweep in NFA optimization.
* Does NEXT(). Must not be called from any unusual lexical context.
* This should be reconciled with the \w etc. handling in lex.c, and
* should be cleaned up to reduce dependencies on input scanning.
^ static VOID wordchrs(struct vars *);
*/
static VOID
wordchrs(v)
struct vars *v;
{
struct state *left;
struct state *right;
if (v->wordchrs != NULL) {
NEXT(); /* for consistency */
return;
}
left = newstate(v->nfa);
right = newstate(v->nfa);
NOERR();
/* fine point: implemented with [::], and lexer will set REG_ULOCALE */
lexword(v);
NEXT();
assert(v->savenow != NULL && SEE('['));
bracket(v, left, right);
assert((v->savenow != NULL && SEE(']')) || ISERR());
NEXT();
NOERR();
v->wordchrs = left;
}
/*
- subre - allocate a subre
^ static struct subre *subre(struct vars *, int, int, struct state *,
^ struct state *);
*/
static struct subre *
subre(v, op, flags, begin, end)
struct vars *v;
int op;
int flags;
struct state *begin;
struct state *end;
{
struct subre *ret;
ret = v->treefree;
if (ret != NULL)
v->treefree = ret->left;
else {
ret = (struct subre *)MALLOC(sizeof(struct subre));
if (ret == NULL) {
ERR(REG_ESPACE);
return NULL;
}
ret->chain = v->treechain;
v->treechain = ret;
}
assert(strchr("|.b(=", op) != NULL);
ret->op = op;
ret->flags = flags;
ret->retry = 0;
ret->subno = 0;
ret->min = ret->max = 1;
ret->left = NULL;
ret->right = NULL;
ret->begin = begin;
ret->end = end;
ZAPCNFA(ret->cnfa);
return ret;
}
/*
- freesubre - free a subRE subtree
^ static VOID freesubre(struct vars *, struct subre *);
*/
static VOID
freesubre(v, sr)
struct vars *v; /* might be NULL */
struct subre *sr;
{
if (sr == NULL)
return;
if (sr->left != NULL)
freesubre(v, sr->left);
if (sr->right != NULL)
freesubre(v, sr->right);
freesrnode(v, sr);
}
/*
- freesrnode - free one node in a subRE subtree
^ static VOID freesrnode(struct vars *, struct subre *);
*/
static VOID
freesrnode(v, sr)
struct vars *v; /* might be NULL */
struct subre *sr;
{
if (sr == NULL)
return;
if (!NULLCNFA(sr->cnfa))
freecnfa(&sr->cnfa);
sr->flags = 0;
if (v != NULL) {
sr->left = v->treefree;
v->treefree = sr;
} else
FREE(sr);
}
/*
- optst - optimize a subRE subtree
^ static VOID optst(struct vars *, struct subre *);
*/
static VOID
optst(v, t)
struct vars *v;
struct subre *t;
{
/*
* DGP (2007-11-13): I assume it was the programmer's intent to eventually
* come back and add code to optimize subRE trees, but the routine coded
* just spent effort traversing the tree and doing nothing. We can do
* nothing with less effort.
*/
return;
}
/*
- numst - number tree nodes (assigning retry indexes)
^ static int numst(struct subre *, int);
*/
static int /* next number */
numst(t, start)
struct subre *t;
int start; /* starting point for subtree numbers */
{
int i;
assert(t != NULL);
i = start;
t->retry = (short)i++;
if (t->left != NULL)
i = numst(t->left, i);
if (t->right != NULL)
i = numst(t->right, i);
return i;
}
/*
- markst - mark tree nodes as INUSE
^ static VOID markst(struct subre *);
*/
static VOID
markst(t)
struct subre *t;
{
assert(t != NULL);
t->flags |= INUSE;
if (t->left != NULL)
markst(t->left);
if (t->right != NULL)
markst(t->right);
}
/*
- cleanst - free any tree nodes not marked INUSE
^ static VOID cleanst(struct vars *);
*/
static VOID
cleanst(v)
struct vars *v;
{
struct subre *t;
struct subre *next;
for (t = v->treechain; t != NULL; t = next) {
next = t->chain;
if (!(t->flags&INUSE))
FREE(t);
}
v->treechain = NULL;
v->treefree = NULL; /* just on general principles */
}
/*
- nfatree - turn a subRE subtree into a tree of compacted NFAs
^ static long nfatree(struct vars *, struct subre *, FILE *);
*/
static long /* optimize results from top node */
nfatree(v, t, f)
struct vars *v;
struct subre *t;
FILE *f; /* for debug output */
{
assert(t != NULL && t->begin != NULL);
if (t->left != NULL)
(DISCARD)nfatree(v, t->left, f);
if (t->right != NULL)
(DISCARD)nfatree(v, t->right, f);
return nfanode(v, t, f);
}
/*
- nfanode - do one NFA for nfatree
^ static long nfanode(struct vars *, struct subre *, FILE *);
*/
static long /* optimize results */
nfanode(v, t, f)
struct vars *v;
struct subre *t;
FILE *f; /* for debug output */
{
struct nfa *nfa;
long ret = 0;
char idbuf[50];
assert(t->begin != NULL);
if (f != NULL)
fprintf(f, "\n\n\n========= TREE NODE %s ==========\n",
stid(t, idbuf, sizeof(idbuf)));
nfa = newnfa(v, v->cm, v->nfa);
NOERRZ();
dupnfa(nfa, t->begin, t->end, nfa->init, nfa->final);
if (!ISERR()) {
specialcolors(nfa);
ret = optimize(nfa, f);
}
if (!ISERR())
compact(nfa, &t->cnfa);
freenfa(nfa);
return ret;
}
/*
- newlacon - allocate a lookahead-constraint subRE
^ static int newlacon(struct vars *, struct state *, struct state *, int);
*/
static int /* lacon number */
newlacon(v, begin, end, pos)
struct vars *v;
struct state *begin;
struct state *end;
int pos;
{
int n;
struct subre *sub;
if (v->nlacons == 0) {
v->lacons = (struct subre *)MALLOC(2 * sizeof(struct subre));
n = 1; /* skip 0th */
v->nlacons = 2;
} else {
v->lacons = (struct subre *)REALLOC(v->lacons,
(v->nlacons+1)*sizeof(struct subre));
n = v->nlacons++;
}
if (v->lacons == NULL) {
ERR(REG_ESPACE);
return 0;
}
sub = &v->lacons[n];
sub->begin = begin;
sub->end = end;
sub->subno = pos;
ZAPCNFA(sub->cnfa);
return n;
}
/*
- freelacons - free lookahead-constraint subRE vector
^ static VOID freelacons(struct subre *, int);
*/
static VOID
freelacons(subs, n)
struct subre *subs;
int n;
{
struct subre *sub;
int i;
assert(n > 0);
for (sub = subs + 1, i = n - 1; i > 0; sub++, i--) /* no 0th */
if (!NULLCNFA(sub->cnfa))
freecnfa(&sub->cnfa);
FREE(subs);
}
/*
- rfree - free a whole RE (insides of regfree)
^ static VOID rfree(regex_t *);
*/
static VOID
rfree(re)
regex_t *re;
{
struct guts *g;
if (re == NULL || re->re_magic != REMAGIC)
return;
re->re_magic = 0; /* invalidate RE */
g = (struct guts *)re->re_guts;
re->re_guts = NULL;
re->re_fns = NULL;
g->magic = 0;
freecm(&g->cmap);
if (g->tree != NULL)
freesubre((struct vars *)NULL, g->tree);
if (g->lacons != NULL)
freelacons(g->lacons, g->nlacons);
if (!NULLCNFA(g->search))
freecnfa(&g->search);
FREE(g);
}
/*
- dump - dump an RE in human-readable form
^ static VOID dump(regex_t *, FILE *);
*/
static VOID
dump(re, f)
regex_t *re;
FILE *f;
{
#ifdef REG_DEBUG
struct guts *g;
int i;
if (re->re_magic != REMAGIC)
fprintf(f, "bad magic number (0x%x not 0x%x)\n", re->re_magic,
REMAGIC);
if (re->re_guts == NULL) {
fprintf(f, "NULL guts!!!\n");
return;
}
g = (struct guts *)re->re_guts;
if (g->magic != GUTSMAGIC)
fprintf(f, "bad guts magic number (0x%x not 0x%x)\n", g->magic,
GUTSMAGIC);
fprintf(f, "\n\n\n========= DUMP ==========\n");
fprintf(f, "nsub %d, info 0%lo, csize %d, ntree %d\n",
re->re_nsub, re->re_info, re->re_csize, g->ntree);
dumpcolors(&g->cmap, f);
if (!NULLCNFA(g->search)) {
printf("\nsearch:\n");
dumpcnfa(&g->search, f);
}
for (i = 1; i < g->nlacons; i++) {
fprintf(f, "\nla%d (%s):\n", i,
(g->lacons[i].subno) ? "positive" : "negative");
dumpcnfa(&g->lacons[i].cnfa, f);
}
fprintf(f, "\n");
dumpst(g->tree, f, 0);
#endif
}
/*
- dumpst - dump a subRE tree
^ static VOID dumpst(struct subre *, FILE *, int);
*/
static VOID
dumpst(t, f, nfapresent)
struct subre *t;
FILE *f;
int nfapresent; /* is the original NFA still around? */
{
if (t == NULL)
fprintf(f, "null tree\n");
else
stdump(t, f, nfapresent);
fflush(f);
}
/*
- stdump - recursive guts of dumpst
^ static VOID stdump(struct subre *, FILE *, int);
*/
static VOID
stdump(t, f, nfapresent)
struct subre *t;
FILE *f;
int nfapresent; /* is the original NFA still around? */
{
char idbuf[50];
fprintf(f, "%s. `%c'", stid(t, idbuf, sizeof(idbuf)), t->op);
if (t->flags&LONGER)
fprintf(f, " longest");
if (t->flags&SHORTER)
fprintf(f, " shortest");
if (t->flags&MIXED)
fprintf(f, " hasmixed");
if (t->flags&CAP)
fprintf(f, " hascapture");
if (t->flags&BACKR)
fprintf(f, " hasbackref");
if (!(t->flags&INUSE))
fprintf(f, " UNUSED");
if (t->subno != 0)
fprintf(f, " (#%d)", t->subno);
if (t->min != 1 || t->max != 1) {
fprintf(f, " {%d,", t->min);
if (t->max != INFINITY)
fprintf(f, "%d", t->max);
fprintf(f, "}");
}
if (nfapresent)
fprintf(f, " %ld-%ld", (long)t->begin->no, (long)t->end->no);
if (t->left != NULL)
fprintf(f, " L:%s", stid(t->left, idbuf, sizeof(idbuf)));
if (t->right != NULL)
fprintf(f, " R:%s", stid(t->right, idbuf, sizeof(idbuf)));
if (!NULLCNFA(t->cnfa)) {
fprintf(f, "\n");
dumpcnfa(&t->cnfa, f);
}
fprintf(f, "\n");
if (t->left != NULL)
stdump(t->left, f, nfapresent);
if (t->right != NULL)
stdump(t->right, f, nfapresent);
}
/*
- stid - identify a subtree node for dumping
^ static char *stid(struct subre *, char *, size_t);
*/
static char * /* points to buf or constant string */
stid(t, buf, bufsize)
struct subre *t;
char *buf;
size_t bufsize;
{
/* big enough for hex int or decimal t->retry? */
if (bufsize < sizeof(void*)*2 + 3 || bufsize < sizeof(t->retry)*3 + 1)
return "unable";
if (t->retry != 0)
sprintf(buf, "%d", t->retry);
else
sprintf(buf, "%p", t);
return buf;
}
#include "regc_lex.c"
#include "regc_color.c"
#include "regc_nfa.c"
#include "regc_cvec.c"
#include "regc_locale.c"
tcl8.4.20/generic/tclExecute.c 0000644 0036047 0045461 00000561036 12133546537 014616 0 ustar dgp 771div /*
* tclExecute.c --
*
* This file contains procedures that execute byte-compiled Tcl
* commands.
*
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclCompile.h"
#ifndef TCL_NO_MATH
# include
#endif
/*
* The stuff below is a bit of a hack so that this file can be used
* in environments that include no UNIX, i.e. no errno. Just define
* errno here.
*/
#ifndef TCL_GENERIC_ONLY
# include "tclPort.h"
#else /* TCL_GENERIC_ONLY */
# ifndef NO_FLOAT_H
# include
# else /* NO_FLOAT_H */
# ifndef NO_VALUES_H
# include
# endif /* !NO_VALUES_H */
# endif /* !NO_FLOAT_H */
# define NO_ERRNO_H
#endif /* !TCL_GENERIC_ONLY */
#ifdef NO_ERRNO_H
int errno;
# define EDOM 33
# define ERANGE 34
#endif
/*
* Need DBL_MAX for IS_INF() macro...
*/
#ifndef DBL_MAX
# ifdef MAXDOUBLE
# define DBL_MAX MAXDOUBLE
# else /* !MAXDOUBLE */
/*
* This value is from the Solaris headers, but doubles seem to be the
* same size everywhere. Long doubles aren't, but we don't use those.
*/
# define DBL_MAX 1.79769313486231570e+308
# endif /* MAXDOUBLE */
#endif /* !DBL_MAX */
/*
* Boolean flag indicating whether the Tcl bytecode interpreter has been
* initialized.
*/
static int execInitialized = 0;
TCL_DECLARE_MUTEX(execMutex)
#ifdef TCL_COMPILE_DEBUG
/*
* Variable that controls whether execution tracing is enabled and, if so,
* what level of tracing is desired:
* 0: no execution tracing
* 1: trace invocations of Tcl procs only
* 2: trace invocations of all (not compiled away) commands
* 3: display each instruction executed
* This variable is linked to the Tcl variable "tcl_traceExec".
*/
int tclTraceExec = 0;
#endif
/*
* Mapping from expression instruction opcodes to strings; used for error
* messages. Note that these entries must match the order and number of the
* expression opcodes (e.g., INST_LOR) in tclCompile.h.
*/
static CONST char *CONST operatorStrings[] = {
"||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
"+", "-", "*", "/", "%", "+", "-", "~", "!",
"BUILTIN FUNCTION", "FUNCTION",
"", "", "", "", "", "", "", "", "eq", "ne",
};
/*
* Mapping from Tcl result codes to strings; used for error and debugging
* messages.
*/
#ifdef TCL_COMPILE_DEBUG
static CONST char *CONST resultStrings[] = {
"TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
};
#endif
/*
* These are used by evalstats to monitor object usage in Tcl.
*/
#ifdef TCL_COMPILE_STATS
long tclObjsAlloced = 0;
long tclObjsFreed = 0;
#define TCL_MAX_SHARED_OBJ_STATS 5
long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */
/*
* Macros for testing floating-point values for certain special cases. Test
* for not-a-number by comparing a value against itself; test for infinity
* by comparing against the largest floating-point value.
*/
#define IS_NAN(v) ((v) != (v))
#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
/*
* The new macro for ending an instruction; note that a
* reasonable C-optimiser will resolve all branches
* at compile time. (result) is always a constant; the macro
* NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is
* resolved at runtime for variable (nCleanup).
*
* ARGUMENTS:
* pcAdjustment: how much to increment pc
* nCleanup: how many objects to remove from the stack
* result: 0 indicates no object should be pushed on the
* stack; otherwise, push objResultPtr. If (result < 0),
* objResultPtr already has the correct reference count.
*/
#define NEXT_INST_F(pcAdjustment, nCleanup, result) \
if (nCleanup == 0) {\
if (result != 0) {\
if ((result) > 0) {\
PUSH_OBJECT(objResultPtr);\
} else {\
stackPtr[++stackTop] = objResultPtr;\
}\
} \
pc += (pcAdjustment);\
goto cleanup0;\
} else if (result != 0) {\
if ((result) > 0) {\
Tcl_IncrRefCount(objResultPtr);\
}\
pc += (pcAdjustment);\
switch (nCleanup) {\
case 1: goto cleanup1_pushObjResultPtr;\
case 2: goto cleanup2_pushObjResultPtr;\
default: panic("ERROR: bad usage of macro NEXT_INST_F");\
}\
} else {\
pc += (pcAdjustment);\
switch (nCleanup) {\
case 1: goto cleanup1;\
case 2: goto cleanup2;\
default: panic("ERROR: bad usage of macro NEXT_INST_F");\
}\
}
#define NEXT_INST_V(pcAdjustment, nCleanup, result) \
pc += (pcAdjustment);\
cleanup = (nCleanup);\
if (result) {\
if ((result) > 0) {\
Tcl_IncrRefCount(objResultPtr);\
}\
goto cleanupV_pushObjResultPtr;\
} else {\
goto cleanupV;\
}
/*
* Macros used to cache often-referenced Tcl evaluation stack information
* in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
* pair must surround any call inside TclExecuteByteCode (and a few other
* procedures that use this scheme) that could result in a recursive call
* to TclExecuteByteCode.
*/
#define CACHE_STACK_INFO() \
stackPtr = eePtr->stackPtr; \
stackTop = eePtr->stackTop
#define DECACHE_STACK_INFO() \
eePtr->stackTop = stackTop
/*
* Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
* increments the object's ref count since it makes the stack have another
* reference pointing to the object. However, POP_OBJECT does not decrement
* the ref count. This is because the stack may hold the only reference to
* the object, so the object would be destroyed if its ref count were
* decremented before the caller had a chance to, e.g., store it in a
* variable. It is the caller's responsibility to decrement the ref count
* when it is finished with an object.
*
* WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
* macro. The actual parameter might be an expression with side effects,
* and this ensures that it will be executed only once.
*/
#define PUSH_OBJECT(objPtr) \
Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr))
#define POP_OBJECT() \
(stackPtr[stackTop--])
/*
* Macros used to trace instruction execution. The macros TRACE,
* TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
* O2S is only used in TRACE* calls to get a string from an object.
*/
#ifdef TCL_COMPILE_DEBUG
# define TRACE(a) \
if (traceInstructions) { \
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
(unsigned int)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
}
# define TRACE_APPEND(a) \
if (traceInstructions) { \
printf a; \
}
# define TRACE_WITH_OBJ(a, objPtr) \
if (traceInstructions) { \
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
(unsigned int)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
TclPrintObject(stdout, objPtr, 30); \
fprintf(stdout, "\n"); \
}
# define O2S(objPtr) \
(objPtr ? TclGetString(objPtr) : "")
#else /* !TCL_COMPILE_DEBUG */
# define TRACE(a)
# define TRACE_APPEND(a)
# define TRACE_WITH_OBJ(a, objPtr)
# define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */
/*
* DTrace instruction probe macros.
*/
#define TCL_DTRACE_INST_NEXT() \
if (TCL_DTRACE_INST_DONE_ENABLED()) {\
if (curInstName) {\
TCL_DTRACE_INST_DONE(curInstName, stackTop - initStackTop,\
stackPtr + stackTop);\
}\
curInstName = tclInstructionTable[*pc].name;\
if (TCL_DTRACE_INST_START_ENABLED()) {\
TCL_DTRACE_INST_START(curInstName, stackTop - initStackTop,\
stackPtr + stackTop);\
}\
} else if (TCL_DTRACE_INST_START_ENABLED()) {\
TCL_DTRACE_INST_START(tclInstructionTable[*pc].name,\
stackTop - initStackTop, stackPtr + stackTop);\
}
#define TCL_DTRACE_INST_LAST() \
if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {\
TCL_DTRACE_INST_DONE(curInstName, stackTop - initStackTop,\
stackPtr + stackTop);\
}
/*
* Macro to read a string containing either a wide or an int and
* decide which it is while decoding it at the same time. This
* enforces the policy that integer constants between LONG_MIN and
* LONG_MAX (inclusive) are represented by normal longs, and integer
* constants outside that range are represented by wide ints.
*
* GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never
* generates an error message.
*/
#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
(resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \
if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
&& (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
(objPtr)->typePtr = &tclIntType; \
(objPtr)->internalRep.longValue = (longVar) \
= Tcl_WideAsLong(wideVar); \
}
#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
(resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \
&(wideVar)); \
if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
&& (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
(objPtr)->typePtr = &tclIntType; \
(objPtr)->internalRep.longValue = (longVar) \
= Tcl_WideAsLong(wideVar); \
}
/*
* Combined with REQUIRE_WIDE_OR_INT, this gets a long value from
* an obj.
*/
#define FORCE_LONG(objPtr, longVar, wideVar) \
if ((objPtr)->typePtr == &tclWideIntType) { \
(longVar) = Tcl_WideAsLong(wideVar); \
}
#define IS_INTEGER_TYPE(typePtr) \
((typePtr) == &tclIntType || (typePtr) == &tclWideIntType)
#define IS_NUMERIC_TYPE(typePtr) \
(IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType)
#define W0 Tcl_LongAsWide(0)
/*
* For tracing that uses wide values.
*/
#define LLD "%" TCL_LL_MODIFIER "d"
#ifndef TCL_WIDE_INT_IS_LONG
/*
* Extract a double value from a general numeric object.
*/
#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
if ((typePtr) == &tclIntType) { \
(doubleVar) = (double) (objPtr)->internalRep.longValue; \
} else if ((typePtr) == &tclWideIntType) { \
(doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\
} else { \
(doubleVar) = (objPtr)->internalRep.doubleValue; \
}
#else /* TCL_WIDE_INT_IS_LONG */
#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \
(doubleVar) = (double) (objPtr)->internalRep.longValue; \
} else { \
(doubleVar) = (objPtr)->internalRep.doubleValue; \
}
#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Declarations for local procedures to this file:
*/
static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
ByteCode *codePtr));
static void DupExprCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, int objc, Tcl_Obj **objv));
static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
#ifdef TCL_COMPILE_STATS
static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
#endif /* TCL_COMPILE_STATS */
static void FreeExprCodeInternalRep _ANSI_ARGS_ ((Tcl_Obj *objPtr));
#ifdef TCL_COMPILE_DEBUG
static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
#endif /* TCL_COMPILE_DEBUG */
static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
int catchOnly, ByteCode* codePtr));
static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
ByteCode* codePtr, int *lengthPtr));
static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
static void IllegalExprOperandType _ANSI_ARGS_((
Tcl_Interp *interp, unsigned char *pc,
Tcl_Obj *opndPtr));
static void InitByteCodeExecution _ANSI_ARGS_((
Tcl_Interp *interp));
#ifdef TCL_COMPILE_DEBUG
static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
static CONST char * StringForResultCode _ANSI_ARGS_((int result));
static void ValidatePcAndStackTop _ANSI_ARGS_((
ByteCode *codePtr, unsigned char *pc,
int stackTop, int stackLowerBound));
#endif /* TCL_COMPILE_DEBUG */
static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
/*
* The structure below defines a bytecode Tcl object type to hold the
* compiled bytecode for Tcl expressions.
*/
static Tcl_ObjType exprCodeType = {
"exprcode",
FreeExprCodeInternalRep, /* freeIntRepProc */
DupExprCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
* Table describing the built-in math functions. Entries in this table are
* indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
* operand byte.
*/
BuiltinFunc tclBuiltinFuncTable[] = {
#ifndef TCL_NO_MATH
{"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
{"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
{"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
{"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
{"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
{"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
{"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
{"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
{"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
{"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
{"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
{"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
{"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
{"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
{"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
{"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
{"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
{"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
{"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
#endif
{"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
{"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
{"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
{"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
{"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
{"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
{"wide", 1, {TCL_EITHER}, ExprWideFunc, 0},
{0, 0, {TCL_INT}, 0, 0},
};
/*
*----------------------------------------------------------------------
*
* InitByteCodeExecution --
*
* This procedure is called once to initialize the Tcl bytecode
* interpreter.
*
* Results:
* None.
*
* Side effects:
* This procedure initializes the array of instruction names. If
* compiling with the TCL_COMPILE_STATS flag, it initializes the
* array that counts the executions of each instruction and it
* creates the "evalstats" command. It also establishes the link
* between the Tcl "tcl_traceExec" and C "tclTraceExec" variables.
*
*----------------------------------------------------------------------
*/
static void
InitByteCodeExecution(interp)
Tcl_Interp *interp; /* Interpreter for which the Tcl variable
* "tcl_traceExec" is linked to control
* instruction tracing. */
{
#ifdef TCL_COMPILE_DEBUG
if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
TCL_LINK_INT) != TCL_OK) {
panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
}
#endif
#ifdef TCL_COMPILE_STATS
Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
#endif /* TCL_COMPILE_STATS */
}
/*
*----------------------------------------------------------------------
*
* TclCreateExecEnv --
*
* This procedure creates a new execution environment for Tcl bytecode
* execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
* is typically created once for each Tcl interpreter (Interp
* structure) and recursively passed to TclExecuteByteCode to execute
* ByteCode sequences for nested commands.
*
* Results:
* A newly allocated ExecEnv is returned. This points to an empty
* evaluation stack of the standard initial size.
*
* Side effects:
* The bytecode interpreter is also initialized here, as this
* procedure will be called before any call to TclExecuteByteCode.
*
*----------------------------------------------------------------------
*/
#define TCL_STACK_INITIAL_SIZE 2000
ExecEnv *
TclCreateExecEnv(interp)
Tcl_Interp *interp; /* Interpreter for which the execution
* environment is being created. */
{
ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
Tcl_Obj **stackPtr;
stackPtr = (Tcl_Obj **)
ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
/*
* Use the bottom pointer to keep a reference count; the
* execution environment holds a reference.
*/
stackPtr++;
eePtr->stackPtr = stackPtr;
stackPtr[-1] = (Tcl_Obj *) ((char *) 1);
eePtr->stackTop = -1;
eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 2);
eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1);
Tcl_IncrRefCount(eePtr->errorInfo);
eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1);
Tcl_IncrRefCount(eePtr->errorCode);
Tcl_MutexLock(&execMutex);
if (!execInitialized) {
TclInitAuxDataTypeTable();
InitByteCodeExecution(interp);
execInitialized = 1;
}
Tcl_MutexUnlock(&execMutex);
return eePtr;
}
#undef TCL_STACK_INITIAL_SIZE
/*
*----------------------------------------------------------------------
*
* TclDeleteExecEnv --
*
* Frees the storage for an ExecEnv.
*
* Results:
* None.
*
* Side effects:
* Storage for an ExecEnv and its contained storage (e.g. the
* evaluation stack) is freed.
*
*----------------------------------------------------------------------
*/
void
TclDeleteExecEnv(eePtr)
ExecEnv *eePtr; /* Execution environment to free. */
{
if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) {
ckfree((char *) (eePtr->stackPtr-1));
} else {
panic("ERROR: freeing an execEnv whose stack is still in use.\n");
}
TclDecrRefCount(eePtr->errorInfo);
TclDecrRefCount(eePtr->errorCode);
ckfree((char *) eePtr);
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeExecution --
*
* Finalizes the execution environment setup so that it can be
* later reinitialized.
*
* Results:
* None.
*
* Side effects:
* After this call, the next time TclCreateExecEnv will be called
* it will call InitByteCodeExecution.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeExecution()
{
Tcl_MutexLock(&execMutex);
execInitialized = 0;
Tcl_MutexUnlock(&execMutex);
TclFinalizeAuxDataTypeTable();
}
/*
*----------------------------------------------------------------------
*
* GrowEvaluationStack --
*
* This procedure grows a Tcl evaluation stack stored in an ExecEnv.
*
* Results:
* None.
*
* Side effects:
* The size of the evaluation stack is doubled.
*
*----------------------------------------------------------------------
*/
static void
GrowEvaluationStack(eePtr)
register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation
* stack to enlarge. */
{
/*
* The current Tcl stack elements are stored from eePtr->stackPtr[0]
* to eePtr->stackPtr[eePtr->stackEnd] (inclusive).
*/
int currElems = (eePtr->stackEnd + 1);
int newElems = 2*currElems;
int currBytes = currElems * sizeof(Tcl_Obj *);
int newBytes = 2*currBytes;
Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
Tcl_Obj **oldStackPtr = eePtr->stackPtr;
/*
* We keep the stack reference count as a (char *), as that
* works nicely as a portable pointer-sized counter.
*/
char *refCount = (char *) oldStackPtr[-1];
/*
* Copy the existing stack items to the new stack space, free the old
* storage if appropriate, and record the refCount of the new stack
* held by the environment.
*/
newStackPtr++;
memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr,
(size_t) currBytes);
if (refCount == (char *) 1) {
ckfree((VOID *) (oldStackPtr-1));
} else {
/*
* Remove the reference corresponding to the
* environment pointer.
*/
oldStackPtr[-1] = (Tcl_Obj *) (refCount-1);
}
eePtr->stackPtr = newStackPtr;
eePtr->stackEnd = (newElems - 2); /* index of last usable item */
newStackPtr[-1] = (Tcl_Obj *) ((char *) 1);
}
/*
*--------------------------------------------------------------
*
* Tcl_ExprObj --
*
* Evaluate an expression in a Tcl_Obj.
*
* Results:
* A standard Tcl object result. If the result is other than TCL_OK,
* then the interpreter's result contains an error message. If the
* result is TCL_OK, then a pointer to the expression's result value
* object is stored in resultPtrPtr. In that case, the object's ref
* count is incremented to reflect the reference returned to the
* caller; the caller is then responsible for the resulting object
* and must, for example, decrement the ref count when it is finished
* with the object.
*
* Side effects:
* Any side effects caused by subcommands in the expression, if any.
* The interpreter result is not modified unless there is an error.
*
*--------------------------------------------------------------
*/
int
Tcl_ExprObj(interp, objPtr, resultPtrPtr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
register Tcl_Obj *objPtr; /* Points to Tcl object containing
* expression to evaluate. */
Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
* result is stored if no errors occur. */
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure
* allocated in frame. */
LiteralTable *localTablePtr = &(compEnv.localLitTable);
register ByteCode *codePtr = NULL;
/* Tcl Internal type of bytecode.
* Initialized to avoid compiler warning. */
Tcl_Obj *saveObjPtr;
char *string;
int length, result;
/*
* First handle some common expressions specially.
*/
string = Tcl_GetStringFromObj(objPtr, &length);
if (length == 1) {
if (*string == '0') {
*resultPtrPtr = Tcl_NewLongObj(0);
Tcl_IncrRefCount(*resultPtrPtr);
return TCL_OK;
} else if (*string == '1') {
*resultPtrPtr = Tcl_NewLongObj(1);
Tcl_IncrRefCount(*resultPtrPtr);
return TCL_OK;
}
} else if ((length == 2) && (*string == '!')) {
if (*(string+1) == '0') {
*resultPtrPtr = Tcl_NewLongObj(1);
Tcl_IncrRefCount(*resultPtrPtr);
return TCL_OK;
} else if (*(string+1) == '1') {
*resultPtrPtr = Tcl_NewLongObj(0);
Tcl_IncrRefCount(*resultPtrPtr);
return TCL_OK;
}
}
/*
* Compile and execute the expression after saving the interp's result.
*/
saveObjPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(saveObjPtr);
/*
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
if (objPtr->typePtr == &exprCodeType) {
Namespace *namespacePtr = iPtr->varFramePtr ?
iPtr->varFramePtr->nsPtr : iPtr->globalNsPtr;
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
objPtr->typePtr->freeIntRepProc(objPtr);
objPtr->typePtr = (Tcl_ObjType *) NULL;
}
}
if (objPtr->typePtr != &exprCodeType) {
#ifndef TCL_TIP280
TclInitCompileEnv(interp, &compEnv, string, length);
#else
/* TIP #280 : No invoker (yet) - Expression compilation */
TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
#endif
result = TclCompileExpr(interp, string, length, &compEnv);
/*
* Free the compilation environment's literal table bucket array if
* it was dynamically allocated.
*/
if (localTablePtr->buckets != localTablePtr->staticBuckets) {
ckfree((char *) localTablePtr->buckets);
}
if (result != TCL_OK) {
/*
* Compilation errors. Free storage allocated for compilation.
*/
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(&compEnv);
#endif /*TCL_COMPILE_DEBUG*/
TclFreeCompileEnv(&compEnv);
goto done;
}
/*
* Successful compilation. If the expression yielded no
* instructions, push an zero object as the expression's result.
*/
if (compEnv.codeNext == compEnv.codeStart) {
TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0),
&compEnv);
}
/*
* Add a "done" instruction as the last instruction and change the
* object into a ByteCode object. Ownership of the literal objects
* and aux data items is given to the ByteCode object.
*/
compEnv.numSrcBytes = iPtr->termOffset;
TclEmitOpcode(INST_DONE, &compEnv);
TclInitByteCodeObj(objPtr, &compEnv);
objPtr->typePtr = &exprCodeType;
TclFreeCompileEnv(&compEnv);
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile == 2) {
TclPrintByteCodeObj(interp, objPtr);
}
#endif /* TCL_COMPILE_DEBUG */
}
Tcl_ResetResult(interp);
/*
* Increment the code's ref count while it is being executed. If
* afterwards no references to it remain, free the code.
*/
codePtr->refCount++;
result = TclExecuteByteCode(interp, codePtr);
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
/*
* If the expression evaluated successfully, store a pointer to its
* value object in resultPtrPtr then restore the old interpreter result.
* We increment the object's ref count to reflect the reference that we
* are returning to the caller. We also decrement the ref count of the
* interpreter's result object after calling Tcl_SetResult since we
* next store into that field directly.
*/
if (result == TCL_OK) {
*resultPtrPtr = iPtr->objResultPtr;
Tcl_IncrRefCount(iPtr->objResultPtr);
Tcl_SetObjResult(interp, saveObjPtr);
}
done:
TclDecrRefCount(saveObjPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* DupExprCodeInternalRep --
*
* Part of the Tcl object type implementation for Tcl expression
* bytecode. We do not copy the bytecode intrep. Instead, we
* return without setting copyPtr->typePtr, so the copy is a plain
* string copy of the expression value, and if it is to be used
* as a compiled expression, it will just need a recompile.
*
* This makes sense, because with Tcl's copy-on-write practices,
* the usual (only?) time Tcl_DuplicateObj() will be called is
* when the copy is about to be modified, which would invalidate
* any copied bytecode anyway. The only reason it might make sense
* to copy the bytecode is if we had some modifying routines that
* operated directly on the intrep, like we do for lists and dicts.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
DupExprCodeInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
return;
}
/*
*----------------------------------------------------------------------
*
* FreeExprCodeInternalRep --
*
* Part of the Tcl object type implementation for Tcl expression
* bytecode. Frees the storage allocated to hold the internal rep,
* unless ref counts indicate bytecode execution is still in progress.
*
* Results:
* None.
*
* Side effects:
* May free allocated memory. Leaves objPtr untyped.
*----------------------------------------------------------------------
*/
static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
objPtr->typePtr = NULL;
objPtr->internalRep.otherValuePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* TclCompEvalObj --
*
* This procedure evaluates the script contained in a Tcl_Obj by
* first compiling it and then passing it to TclExecuteByteCode.
*
* Results:
* The return value is one of the return codes defined in tcl.h
* (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
* that either contains the result of executing the code or an
* error message.
*
* Side effects:
* Almost certainly, depending on the ByteCode's instructions.
*
*----------------------------------------------------------------------
*/
int
#ifndef TCL_TIP280
TclCompEvalObj(interp, objPtr)
#else
TclCompEvalObj(interp, objPtr, invoker, word)
#endif
Tcl_Interp *interp;
Tcl_Obj *objPtr;
#ifdef TCL_TIP280
CONST CmdFrame* invoker; /* Frame of the command doing the eval */
int word; /* Index of the word which is in objPtr */
#endif
{
register Interp *iPtr = (Interp *) interp;
register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
* at all were executed. */
char *script;
int numSrcBytes;
int result;
Namespace *namespacePtr;
/*
* Check that the interpreter is ready to execute scripts
*/
iPtr->numLevels++;
if (TclInterpReady(interp) == TCL_ERROR) {
iPtr->numLevels--;
return TCL_ERROR;
}
if (iPtr->varFramePtr != NULL) {
namespacePtr = iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = iPtr->globalNsPtr;
}
/*
* If the object is not already of tclByteCodeType, compile it (and
* reset the compilation flags in the interpreter; this should be
* done after any compilation).
* Otherwise, check that it is "fresh" enough.
*/
if (objPtr->typePtr != &tclByteCodeType) {
recompileObj:
iPtr->errorLine = 1;
#ifdef TCL_TIP280
/* TIP #280. Remember the invoker for a moment in the interpreter
* structures so that the byte code compiler can pick it up when
* initializing the compilation environment, i.e. the extended
* location information.
*/
iPtr->invokeCmdFramePtr = invoker;
iPtr->invokeWord = word;
#endif
result = tclByteCodeType.setFromAnyProc(interp, objPtr);
#ifdef TCL_TIP280
iPtr->invokeCmdFramePtr = NULL;
#endif
if (result != TCL_OK) {
iPtr->numLevels--;
return result;
}
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
} else {
/*
* Make sure the Bytecode hasn't been invalidated by, e.g., someone
* redefining a command with a compile procedure (this might make the
* compiled code wrong).
* The object needs to be recompiled if it was compiled in/for a
* different interpreter, or for a different namespace, or for the
* same namespace but with different name resolution rules.
* Precompiled objects, however, are immutable and therefore
* they are not recompiled, even if the epoch has changed.
*
* To be pedantically correct, we should also check that the
* originating procPtr is the same as the current context procPtr
* (assuming one exists at all - none for global level). This
* code is #def'ed out because [info body] was changed to never
* return a bytecode type object, which should obviate us from
* the extra checks here.
*/
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */
|| (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
iPtr->varFramePtr->procPtr == codePtr->procPtr))
#endif
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
panic("Tcl_EvalObj: compiled script jumped interps");
}
codePtr->compileEpoch = iPtr->compileEpoch;
} else {
/*
* This byteCode is invalid: free it and recompile
*/
tclByteCodeType.freeIntRepProc(objPtr);
goto recompileObj;
}
}
}
/*
* Execute the commands. If the code was compiled from an empty string,
* don't bother executing the code.
*/
numSrcBytes = codePtr->numSrcBytes;
if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
/*
* Increment the code's ref count while it is being executed. If
* afterwards no references to it remain, free the code.
*/
codePtr->refCount++;
result = TclExecuteByteCode(interp, codePtr);
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
} else {
result = TCL_OK;
}
iPtr->numLevels--;
/*
* If no commands at all were executed, check for asynchronous
* handlers so that they at least get one change to execute.
* This is needed to handle event loops written in Tcl with
* empty bodies.
*/
if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
result = Tcl_AsyncInvoke(interp, result);
/*
* If an error occurred, record information about what was being
* executed when the error occurred.
*/
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
}
/*
* Set the interpreter's termOffset member to the offset of the
* character just after the last one executed. We approximate the offset
* of the last character executed by using the number of characters
* compiled.
*/
iPtr->termOffset = numSrcBytes;
iPtr->flags &= ~ERR_ALREADY_LOGGED;
return result;
}
/*
*----------------------------------------------------------------------
*
* TclExecuteByteCode --
*
* This procedure executes the instructions of a ByteCode structure.
* It returns when a "done" instruction is executed or an error occurs.
*
* Results:
* The return value is one of the return codes defined in tcl.h
* (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
* that either contains the result of executing the code or an
* error message.
*
* Side effects:
* Almost certainly, depending on the ByteCode's instructions.
*
*----------------------------------------------------------------------
*/
static int
TclExecuteByteCode(interp, codePtr)
Tcl_Interp *interp; /* Token for command interpreter. */
ByteCode *codePtr; /* The bytecode sequence to interpret. */
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr = iPtr->execEnvPtr;
/* Points to the execution environment. */
register Tcl_Obj **stackPtr = eePtr->stackPtr;
/* Cached evaluation stack base pointer. */
register int stackTop = eePtr->stackTop;
/* Cached top index of evaluation stack. */
register unsigned char *pc = codePtr->codeStart;
/* The current program counter. */
int opnd; /* Current instruction's operand byte(s). */
int pcAdjustment; /* Hold pc adjustment after instruction. */
int initStackTop = stackTop;/* Stack top at start of execution. */
ExceptionRange *rangePtr; /* Points to closest loop or catch exception
* range enclosing the pc. Used by various
* instructions and processCatch to
* process break, continue, and errors. */
int result = TCL_OK; /* Return code returned after execution. */
int storeFlags;
Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
char *bytes;
int length;
long i = 0; /* Init. avoids compiler warning. */
Tcl_WideInt w;
register int cleanup;
Tcl_Obj *objResultPtr;
char *part1, *part2;
Var *varPtr, *arrayPtr;
CallFrame *varFramePtr = iPtr->varFramePtr;
#ifdef TCL_TIP280
/* TIP #280 : Structures for tracking lines */
CmdFrame bcFrame;
#endif
#ifdef TCL_COMPILE_DEBUG
int traceInstructions = (tclTraceExec == 3);
char cmdNameBuf[21];
#endif
char *curInstName = NULL;
/*
* This procedure uses a stack to hold information about catch commands.
* This information is the current operand stack top when starting to
* execute the code for each catch command. It starts out with stack-
* allocated space but uses dynamically-allocated storage if needed.
*/
#define STATIC_CATCH_STACK_SIZE 4
int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
int *catchStackPtr = catchStackStorage;
int catchTop = -1;
#ifdef TCL_TIP280
/* TIP #280 : Initialize the frame. Do not push it yet. */
bcFrame.type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
? TCL_LOCATION_PREBC
: TCL_LOCATION_BC);
bcFrame.level = (iPtr->cmdFramePtr == NULL ?
1 :
iPtr->cmdFramePtr->level + 1);
bcFrame.framePtr = iPtr->framePtr;
bcFrame.nextPtr = iPtr->cmdFramePtr;
bcFrame.nline = 0;
bcFrame.line = NULL;
bcFrame.data.tebc.codePtr = codePtr;
bcFrame.data.tebc.pc = NULL;
bcFrame.cmd.str.cmd = NULL;
bcFrame.cmd.str.len = 0;
#endif
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
fflush(stdout);
}
opnd = 0; /* Init. avoids compiler warning. */
#endif
#ifdef TCL_COMPILE_STATS
iPtr->stats.numExecutions++;
#endif
/*
* Make sure the catch stack is large enough to hold the maximum number
* of catch commands that could ever be executing at the same time. This
* will be no more than the exception range array's depth.
*/
if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
catchStackPtr = (int *)
ckalloc(codePtr->maxExceptDepth * sizeof(int));
}
/*
* Make sure the stack has enough room to execute this ByteCode.
*/
while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
GrowEvaluationStack(eePtr);
stackPtr = eePtr->stackPtr;
}
/*
* Loop executing instructions until a "done" instruction, a
* TCL_RETURN, or some error.
*/
goto cleanup0;
/*
* Targets for standard instruction endings; unrolled
* for speed in the most frequent cases (instructions that
* consume up to two stack elements).
*
* This used to be a "for(;;)" loop, with each instruction doing
* its own cleanup.
*/
cleanupV_pushObjResultPtr:
switch (cleanup) {
case 0:
stackPtr[++stackTop] = (objResultPtr);
goto cleanup0;
default:
cleanup -= 2;
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
case 2:
cleanup2_pushObjResultPtr:
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
case 1:
cleanup1_pushObjResultPtr:
valuePtr = stackPtr[stackTop];
TclDecrRefCount(valuePtr);
}
stackPtr[stackTop] = objResultPtr;
goto cleanup0;
cleanupV:
switch (cleanup) {
default:
cleanup -= 2;
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
case 2:
cleanup2:
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
case 1:
cleanup1:
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
case 0:
/*
* We really want to do nothing now, but this is needed
* for some compilers (SunPro CC)
*/
break;
}
cleanup0:
#ifdef TCL_COMPILE_DEBUG
ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop);
if (traceInstructions) {
fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
TclPrintInstruction(codePtr, pc);
fflush(stdout);
}
#endif /* TCL_COMPILE_DEBUG */
#ifdef TCL_COMPILE_STATS
iPtr->stats.instructionCount[*pc]++;
#endif
TCL_DTRACE_INST_NEXT();
switch (*pc) {
case INST_DONE:
if (stackTop <= initStackTop) {
stackTop--;
goto abnormalReturn;
}
/*
* Set the interpreter's object result to point to the
* topmost object from the stack, and check for a possible
* [catch]. The stackTop's level and refCount will be handled
* by "processCatch" or "abnormalReturn".
*/
valuePtr = stackPtr[stackTop];
Tcl_SetObjResult(interp, valuePtr);
#ifdef TCL_COMPILE_DEBUG
TRACE_WITH_OBJ(("=> return code=%d, result=", result),
iPtr->objResultPtr);
if (traceInstructions) {
fprintf(stdout, "\n");
}
#endif
goto checkForCatch;
case INST_PUSH1:
objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr);
NEXT_INST_F(2, 0, 1);
case INST_PUSH4:
objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
NEXT_INST_F(5, 0, 1);
case INST_POP:
TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]);
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
NEXT_INST_F(1, 0, 0);
case INST_DUP:
objResultPtr = stackPtr[stackTop];
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_OVER:
opnd = TclGetUInt4AtPtr( pc+1 );
objResultPtr = stackPtr[ stackTop - opnd ];
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(5, 0, 1);
case INST_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
{
int totalLen = 0;
/*
* Peephole optimisation for appending an empty string.
* This enables replacing 'K $x [set x{}]' by '$x[set x{}]'
* for fastest execution. Avoid doing the optimisation for wide
* ints - a case where equal strings may refer to different values
* (see [Bug 1251791]).
*/
if ((opnd == 2) && (stackPtr[stackTop-1]->typePtr != &tclWideIntType)) {
Tcl_GetStringFromObj(stackPtr[stackTop], &length);
if (length == 0) {
/* Just drop the top item from the stack */
NEXT_INST_F(2, 1, 0);
}
}
/*
* Concatenate strings (with no separators) from the top
* opnd items on the stack starting with the deepest item.
* First, determine how many characters are needed.
*/
for (i = (stackTop - (opnd-1));
totalLen >= 0 && i <= stackTop; i++) {
bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
if (bytes != NULL) {
totalLen += length;
}
}
if (totalLen < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
INT_MAX);
}
/*
* Initialize the new append string object by appending the
* strings of the opnd stack objects. Also pop the objects.
*/
TclNewObj(objResultPtr);
if (totalLen > 0) {
char *p = (char *) ckalloc((unsigned) (totalLen + 1));
objResultPtr->bytes = p;
objResultPtr->length = totalLen;
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
valuePtr = stackPtr[i];
bytes = Tcl_GetStringFromObj(valuePtr, &length);
if (bytes != NULL) {
memcpy((VOID *) p, (VOID *) bytes,
(size_t) length);
p += length;
}
}
*p = '\0';
}
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
}
case INST_INVOKE_STK4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doInvocation;
case INST_INVOKE_STK1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doInvocation:
{
int objc = opnd; /* The number of arguments. */
Tcl_Obj **objv; /* The array of argument objects. */
/*
* We keep the stack reference count as a (char *), as that
* works nicely as a portable pointer-sized counter.
*/
char **preservedStackRefCountPtr;
/*
* Reference to memory block containing
* objv array (must be kept live throughout
* trace and command invokations.)
*/
objv = &(stackPtr[stackTop - (objc-1)]);
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
TRACE(("%u => call ", objc));
} else {
fprintf(stdout, "%d: (%u) invoking ",
iPtr->numLevels,
(unsigned int)(pc - codePtr->codeStart));
}
for (i = 0; i < objc; i++) {
TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
fflush(stdout);
}
#endif /*TCL_COMPILE_DEBUG*/
/*
* If trace procedures will be called, we need a
* command string to pass to TclEvalObjvInternal; note
* that a copy of the string will be made there to
* include the ending \0.
*/
bytes = NULL;
length = 0;
if (iPtr->tracePtr != NULL) {
Trace *tracePtr, *nextTracePtr;
for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
tracePtr = nextTracePtr) {
nextTracePtr = tracePtr->nextPtr;
if (tracePtr->level == 0 ||
iPtr->numLevels <= tracePtr->level) {
/*
* Traces will be called: get command string
*/
bytes = GetSrcInfoForPc(pc, codePtr, &length);
break;
}
}
} else {
Command *cmdPtr;
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
bytes = GetSrcInfoForPc(pc, codePtr, &length);
}
}
/*
* A reference to part of the stack vector itself
* escapes our control: increase its refCount
* to stop it from being deallocated by a recursive
* call to ourselves. The extra variable is needed
* because all others are liable to change due to the
* trace procedures.
*/
preservedStackRefCountPtr = (char **) (stackPtr-1);
++*preservedStackRefCountPtr;
/*
* Finally, let TclEvalObjvInternal handle the command.
*
* TIP #280 : Record the last piece of info needed by
* 'TclGetSrcInfoForPc', and push the frame.
*/
#ifdef TCL_TIP280
bcFrame.data.tebc.pc = (char*) pc;
iPtr->cmdFramePtr = &bcFrame;
TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc,
codePtr, &bcFrame,
pc - codePtr->codeStart);
#endif
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
CACHE_STACK_INFO();
#ifdef TCL_TIP280
TclArgumentBCRelease((Tcl_Interp*) iPtr, objv, objc,
codePtr,
pc - codePtr->codeStart);
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
#endif
/*
* If the old stack is going to be released, it is
* safe to do so now, since no references to objv are
* going to be used from now on.
*/
--*preservedStackRefCountPtr;
if (*preservedStackRefCountPtr == (char *) 0) {
ckfree((VOID *) preservedStackRefCountPtr);
}
if (result == TCL_OK) {
/*
* Push the call's object result and continue execution
* with the next instruction.
*/
TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
objResultPtr = Tcl_GetObjResult(interp);
/*
* Reset the interp's result to avoid possible duplications
* of large objects [Bug 781585]. We do not call
* Tcl_ResetResult() to avoid any side effects caused by
* the resetting of errorInfo and errorCode [Bug 804681],
* which are not needed here. We chose instead to manipulate
* the interp's object result directly.
*
* Note that the result object is now in objResultPtr, it
* keeps the refCount it had in its role of iPtr->objResultPtr.
*/
{
Tcl_Obj *newObjResultPtr;
TclNewObj(newObjResultPtr);
Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;
}
NEXT_INST_V(pcAdjustment, opnd, -1);
} else {
cleanup = opnd;
goto processExceptionReturn;
}
}
case INST_EVAL_STK:
/*
* Note to maintainers: it is important that INST_EVAL_STK
* pop its argument from the stack before jumping to
* checkForCatch! DO NOT OPTIMISE!
*/
objPtr = stackPtr[stackTop];
DECACHE_STACK_INFO();
#ifndef TCL_TIP280
result = TclCompEvalObj(interp, objPtr);
#else
/* TIP #280: The invoking context is left NULL for a dynamically
* constructed command. We cannot match its lines to the outer
* context.
*/
result = TclCompEvalObj(interp, objPtr, NULL,0);
#endif
CACHE_STACK_INFO();
if (result == TCL_OK) {
/*
* Normal return; push the eval's object result.
*/
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
Tcl_GetObjResult(interp));
/*
* Reset the interp's result to avoid possible duplications
* of large objects [Bug 781585]. We do not call
* Tcl_ResetResult() to avoid any side effects caused by
* the resetting of errorInfo and errorCode [Bug 804681],
* which are not needed here. We chose instead to manipulate
* the interp's object result directly.
*
* Note that the result object is now in objResultPtr, it
* keeps the refCount it had in its role of iPtr->objResultPtr.
*/
{
Tcl_Obj *newObjResultPtr;
TclNewObj(newObjResultPtr);
Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;
}
NEXT_INST_F(1, 1, -1);
} else {
cleanup = 1;
goto processExceptionReturn;
}
case INST_EXPR_STK:
objPtr = stackPtr[stackTop];
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
result = Tcl_ExprObj(interp, objPtr, &valuePtr);
CACHE_STACK_INFO();
if (result != TCL_OK) {
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
O2S(objPtr)), Tcl_GetObjResult(interp));
goto checkForCatch;
}
objResultPtr = valuePtr;
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
NEXT_INST_F(1, 1, -1); /* already has right refct */
/*
* ---------------------------------------------------------
* Start of INST_LOAD instructions.
*
* WARNING: more 'goto' here than your doctor recommended!
* The different instructions set the value of some variables
* and then jump to somme common execution code.
*/
case INST_LOAD_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(2, 0, 1);
}
pcAdjustment = 2;
cleanup = 0;
arrayPtr = NULL;
part2 = NULL;
goto doCallPtrGetVar;
case INST_LOAD_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 0, 1);
}
pcAdjustment = 5;
cleanup = 0;
arrayPtr = NULL;
part2 = NULL;
goto doCallPtrGetVar;
case INST_LOAD_ARRAY_STK:
cleanup = 2;
part2 = Tcl_GetString(stackPtr[stackTop]); /* element name */
objPtr = stackPtr[stackTop-1]; /* array name */
TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2));
goto doLoadStk;
case INST_LOAD_STK:
case INST_LOAD_SCALAR_STK:
cleanup = 1;
part2 = NULL;
objPtr = stackPtr[stackTop]; /* variable name */
TRACE(("\"%.30s\" => ", O2S(objPtr)));
doLoadStk:
part1 = TclGetString(objPtr);
varPtr = TclObjLookupVar(interp, objPtr, part2,
TCL_LEAVE_ERR_MSG, "read",
/*createPart1*/ 0,
/*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(1, cleanup, 1);
}
pcAdjustment = 1;
goto doCallPtrGetVar;
case INST_LOAD_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doLoadArray;
case INST_LOAD_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doLoadArray:
part2 = TclGetString(stackPtr[stackTop]);
arrayPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = arrayPtr->name;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" => ", opnd, part2));
varPtr = TclLookupArrayElement(interp, part1, part2,
TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
}
cleanup = 1;
goto doCallPtrGetVar;
doCallPtrGetVar:
/*
* There are either errors or the variable is traced:
* call TclPtrGetVar to process fully.
*/
DECACHE_STACK_INFO();
objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1,
part2, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
/*
* End of INST_LOAD instructions.
* ---------------------------------------------------------
*/
/*
* ---------------------------------------------------------
* Start of INST_STORE and related instructions.
*
* WARNING: more 'goto' here than your doctor recommended!
* The different instructions set the value of some variables
* and then jump to somme common execution code.
*/
case INST_LAPPEND_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = NULL;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);
goto doStoreStk;
case INST_LAPPEND_ARRAY_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = TclGetString(stackPtr[stackTop - 1]);
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);
goto doStoreStk;
case INST_APPEND_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = NULL;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreStk;
case INST_APPEND_ARRAY_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = TclGetString(stackPtr[stackTop - 1]);
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreStk;
case INST_STORE_ARRAY_STK:
valuePtr = stackPtr[stackTop];
part2 = TclGetString(stackPtr[stackTop - 1]);
storeFlags = TCL_LEAVE_ERR_MSG;
goto doStoreStk;
case INST_STORE_STK:
case INST_STORE_SCALAR_STK:
valuePtr = stackPtr[stackTop];
part2 = NULL;
storeFlags = TCL_LEAVE_ERR_MSG;
doStoreStk:
objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */
part1 = TclGetString(objPtr);
#ifdef TCL_COMPILE_DEBUG
if (part2 == NULL) {
TRACE(("\"%.30s\" <- \"%.30s\" =>",
part1, O2S(valuePtr)));
} else {
TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
part1, part2, O2S(valuePtr)));
}
#endif
varPtr = TclObjLookupVar(interp, objPtr, part2,
TCL_LEAVE_ERR_MSG, "set",
/*createPart1*/ 1,
/*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = ((part2 == NULL)? 2 : 3);
pcAdjustment = 1;
goto doCallPtrSetVar;
case INST_LAPPEND_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);
goto doStoreArray;
case INST_LAPPEND_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);
goto doStoreArray;
case INST_APPEND_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreArray;
case INST_APPEND_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreArray;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = TCL_LEAVE_ERR_MSG;
goto doStoreArray;
case INST_STORE_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = TCL_LEAVE_ERR_MSG;
doStoreArray:
valuePtr = stackPtr[stackTop];
part2 = TclGetString(stackPtr[stackTop - 1]);
arrayPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = arrayPtr->name;
TRACE(("%u \"%.30s\" <- \"%.30s\" => ",
opnd, part2, O2S(valuePtr)));
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
varPtr = TclLookupArrayElement(interp, part1, part2,
TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = 2;
goto doCallPtrSetVar;
case INST_LAPPEND_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);
goto doStoreScalar;
case INST_LAPPEND_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT);
goto doStoreScalar;
case INST_APPEND_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreScalar;
case INST_APPEND_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreScalar;
case INST_STORE_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = TCL_LEAVE_ERR_MSG;
goto doStoreScalar;
case INST_STORE_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = TCL_LEAVE_ERR_MSG;
doStoreScalar:
valuePtr = stackPtr[stackTop];
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
cleanup = 1;
arrayPtr = NULL;
part2 = NULL;
doCallPtrSetVar:
if ((storeFlags == TCL_LEAVE_ERR_MSG)
&& !((varPtr->flags & VAR_IN_HASHTABLE)
&& (varPtr->hPtr == NULL))
&& (varPtr->tracePtr == NULL)
&& (TclIsVarScalar(varPtr)
|| TclIsVarUndefined(varPtr))
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))) {
/*
* No traces, no errors, plain 'set': we can safely inline.
* The value *will* be set to what's requested, so that
* the stack top remains pointing to the same Tcl_Obj.
*/
valuePtr = varPtr->value.objPtr;
objResultPtr = stackPtr[stackTop];
if (valuePtr != objResultPtr) {
if (valuePtr != NULL) {
TclDecrRefCount(valuePtr);
} else {
TclSetVarScalar(varPtr);
TclClearVarUndefined(varPtr);
}
varPtr->value.objPtr = objResultPtr;
Tcl_IncrRefCount(objResultPtr);
}
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#else
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#endif
NEXT_INST_V(pcAdjustment, cleanup, 1);
} else {
DECACHE_STACK_INFO();
objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
part1, part2, valuePtr, storeFlags);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
}
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
/*
* End of INST_STORE and related instructions.
* ---------------------------------------------------------
*/
/*
* ---------------------------------------------------------
* Start of INST_INCR instructions.
*
* WARNING: more 'goto' here than your doctor recommended!
* The different instructions set the value of some variables
* and then jump to somme common execution code.
*/
case INST_INCR_SCALAR1:
case INST_INCR_ARRAY1:
case INST_INCR_ARRAY_STK:
case INST_INCR_SCALAR_STK:
case INST_INCR_STK:
opnd = TclGetUInt1AtPtr(pc+1);
valuePtr = stackPtr[stackTop];
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetLongFromWide(i,valuePtr);
} else {
REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
DECACHE_STACK_INFO();
Tcl_AddErrorInfo(interp, "\n (reading increment)");
CACHE_STACK_INFO();
goto checkForCatch;
}
FORCE_LONG(valuePtr, i, w);
}
stackTop--;
TclDecrRefCount(valuePtr);
switch (*pc) {
case INST_INCR_SCALAR1:
pcAdjustment = 2;
goto doIncrScalar;
case INST_INCR_ARRAY1:
pcAdjustment = 2;
goto doIncrArray;
default:
pcAdjustment = 1;
goto doIncrStk;
}
case INST_INCR_ARRAY_STK_IMM:
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
i = TclGetInt1AtPtr(pc+1);
pcAdjustment = 2;
doIncrStk:
if ((*pc == INST_INCR_ARRAY_STK_IMM)
|| (*pc == INST_INCR_ARRAY_STK)) {
part2 = TclGetString(stackPtr[stackTop]);
objPtr = stackPtr[stackTop - 1];
TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
O2S(objPtr), part2, i));
} else {
part2 = NULL;
objPtr = stackPtr[stackTop];
TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
}
part1 = TclGetString(objPtr);
varPtr = TclObjLookupVar(interp, objPtr, part2,
TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);
if (varPtr == NULL) {
DECACHE_STACK_INFO();
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = ((part2 == NULL)? 1 : 2);
goto doIncrVar;
case INST_INCR_ARRAY1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
pcAdjustment = 3;
doIncrArray:
part2 = TclGetString(stackPtr[stackTop]);
arrayPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = arrayPtr->name;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" (by %ld) => ",
opnd, part2, i));
varPtr = TclLookupArrayElement(interp, part1, part2,
TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = 1;
goto doIncrVar;
case INST_INCR_SCALAR1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
pcAdjustment = 3;
doIncrScalar:
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
arrayPtr = NULL;
part2 = NULL;
cleanup = 0;
TRACE(("%u %ld => ", opnd, i));
doIncrVar:
objPtr = varPtr->value.objPtr;
if (TclIsVarScalar(varPtr)
&& !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))
&& (objPtr->typePtr == &tclIntType)) {
/*
* No errors, no traces, the variable already has an
* integer value: inline processing.
*/
i += objPtr->internalRep.longValue;
if (Tcl_IsShared(objPtr)) {
objResultPtr = Tcl_NewLongObj(i);
TclDecrRefCount(objPtr);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
Tcl_SetLongObj(objPtr, i);
objResultPtr = objPtr;
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
} else {
DECACHE_STACK_INFO();
objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1,
part2, i, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#endif
NEXT_INST_V(pcAdjustment, cleanup, 1);
/*
* End of INST_INCR instructions.
* ---------------------------------------------------------
*/
case INST_JUMP1:
opnd = TclGetInt1AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
case INST_JUMP4:
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
case INST_JUMP_FALSE4:
opnd = 5; /* TRUE */
pcAdjustment = TclGetInt4AtPtr(pc+1); /* FALSE */
goto doJumpTrue;
case INST_JUMP_TRUE4:
opnd = TclGetInt4AtPtr(pc+1); /* TRUE */
pcAdjustment = 5; /* FALSE */
goto doJumpTrue;
case INST_JUMP_FALSE1:
opnd = 2; /* TRUE */
pcAdjustment = TclGetInt1AtPtr(pc+1); /* FALSE */
goto doJumpTrue;
case INST_JUMP_TRUE1:
opnd = TclGetInt1AtPtr(pc+1); /* TRUE */
pcAdjustment = 2; /* FALSE */
doJumpTrue:
{
int b;
valuePtr = stackPtr[stackTop];
if (valuePtr->typePtr == &tclIntType) {
b = (valuePtr->internalRep.longValue != 0);
} else if (valuePtr->typePtr == &tclDoubleType) {
b = (valuePtr->internalRep.doubleValue != 0.0);
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
b = (w != W0);
} else {
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
goto checkForCatch;
}
}
#ifndef TCL_COMPILE_DEBUG
NEXT_INST_F((b? opnd : pcAdjustment), 1, 0);
#else
if (b) {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
TRACE(("%d => %.20s true, new pc %u\n", opnd, O2S(valuePtr),
(unsigned int)(pc+opnd - codePtr->codeStart)));
} else {
TRACE(("%d => %.20s true\n", pcAdjustment, O2S(valuePtr)));
}
NEXT_INST_F(opnd, 1, 0);
} else {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
} else {
opnd = pcAdjustment;
TRACE(("%d => %.20s false, new pc %u\n", opnd, O2S(valuePtr),
(unsigned int)(pc + opnd - codePtr->codeStart)));
}
NEXT_INST_F(pcAdjustment, 1, 0);
}
#endif
}
case INST_LOR:
case INST_LAND:
{
/*
* Operands must be boolean or numeric. No int->double
* conversions are performed.
*/
int i1, i2;
int iResult;
char *s;
Tcl_ObjType *t1Ptr, *t2Ptr;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];;
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
i1 = (valuePtr->internalRep.longValue != 0);
} else if (t1Ptr == &tclWideIntType) {
TclGetWide(w,valuePtr);
i1 = (w != W0);
} else if (t1Ptr == &tclDoubleType) {
i1 = (valuePtr->internalRep.doubleValue != 0.0);
} else {
s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
if (valuePtr->typePtr == &tclIntType) {
i1 = (i != 0);
} else {
i1 = (w != W0);
}
} else {
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
valuePtr, &i1);
i1 = (i1 != 0);
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(t1Ptr? t1Ptr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
i2 = (value2Ptr->internalRep.longValue != 0);
} else if (t2Ptr == &tclWideIntType) {
TclGetWide(w,value2Ptr);
i2 = (w != W0);
} else if (t2Ptr == &tclDoubleType) {
i2 = (value2Ptr->internalRep.doubleValue != 0.0);
} else {
s = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, value2Ptr, i, w);
if (value2Ptr->typePtr == &tclIntType) {
i2 = (i != 0);
} else {
i2 = (w != W0);
}
} else {
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2);
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
(t2Ptr? t2Ptr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (*pc == INST_LOR) {
iResult = (i1 || i2);
} else {
iResult = (i1 && i2);
}
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_NewLongObj(iResult);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
NEXT_INST_F(1, 2, 1);
} else { /* reuse the valuePtr object */
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
Tcl_SetLongObj(valuePtr, iResult);
NEXT_INST_F(1, 1, 0);
}
}
/*
* ---------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
case INST_LIST:
/*
* Pop the opnd (objc) top stack elements into a new list obj
* and then decrement their ref counts.
*/
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)]));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
case INST_LIST_LENGTH:
valuePtr = stackPtr[stackTop];
result = Tcl_ListObjLength(interp, valuePtr, &length);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
Tcl_GetObjResult(interp));
goto checkForCatch;
}
objResultPtr = Tcl_NewIntObj(length);
TRACE(("%.20s => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX:
/*** lindex with objc == 3 ***/
/*
* Pop the two operands
*/
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop- 1];
/*
* Extract the desired list element
*/
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
if (objResultPtr == NULL) {
TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Stash the list element on the stack
*/
TRACE(("%.20s %.20s => %s\n",
O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
NEXT_INST_F(1, 2, -1); /* already has the correct refCount */
case INST_LIST_INDEX_MULTI:
{
/*
* 'lindex' with multiple index args:
*
* Determine the count of index args.
*/
int numIdx;
opnd = TclGetUInt4AtPtr(pc+1);
numIdx = opnd-1;
/*
* Do the 'lindex' operation.
*/
objResultPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx],
numIdx, stackPtr + stackTop - numIdx + 1);
/*
* Check for errors
*/
if (objResultPtr == NULL) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Set result
*/
TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
NEXT_INST_V(5, opnd, -1);
}
case INST_LSET_FLAT:
{
/*
* Lset with 3, 5, or more args. Get the number
* of index args.
*/
int numIdx;
opnd = TclGetUInt4AtPtr( pc + 1 );
numIdx = opnd - 2;
/*
* Get the old value of variable, and remove the stack ref.
* This is safe because the variable still references the
* object; the ref count will never go zero here.
*/
value2Ptr = POP_OBJECT();
TclDecrRefCount(value2Ptr); /* This one should be done here */
/*
* Get the new element value.
*/
valuePtr = stackPtr[stackTop];
/*
* Compute the new variable value
*/
objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
stackPtr + stackTop - numIdx, valuePtr);
/*
* Check for errors
*/
if (objResultPtr == NULL) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Set result
*/
TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
NEXT_INST_V(5, (numIdx+1), -1);
}
case INST_LSET_LIST:
/*
* 'lset' with 4 args.
*
* Get the old value of variable, and remove the stack ref.
* This is safe because the variable still references the
* object; the ref count will never go zero here.
*/
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr); /* This one should be done here */
/*
* Get the new element value, and the index list
*/
valuePtr = stackPtr[stackTop];
value2Ptr = stackPtr[stackTop - 1];
/*
* Compute the new variable value
*/
objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
/*
* Check for errors
*/
if (objResultPtr == NULL) {
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Set result
*/
TRACE(("=> %s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, -1);
/*
* End of INST_LIST and related instructions.
* ---------------------------------------------------------
*/
case INST_STR_EQ:
case INST_STR_NEQ:
{
/*
* String (in)equality check
*/
int iResult;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
if (valuePtr == value2Ptr) {
/*
* On the off-chance that the objects are the same,
* we don't really have to think hard about equality.
*/
iResult = (*pc == INST_STR_EQ);
} else {
char *s1, *s2;
int s1len, s2len;
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
if (s1len == s2len) {
/*
* We only need to check (in)equality when
* we have equal length strings.
*/
if (*pc == INST_STR_NEQ) {
iResult = (strcmp(s1, s2) != 0);
} else {
/* INST_STR_EQ */
iResult = (strcmp(s1, s2) == 0);
}
} else {
iResult = (*pc == INST_STR_NEQ);
}
}
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
/*
* Peep-hole optimisation: if you're about to jump, do jump
* from here.
*/
pc++;
#ifndef TCL_COMPILE_DEBUG
switch (*pc) {
case INST_JUMP_FALSE1:
NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE1:
NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
case INST_JUMP_FALSE4:
NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE4:
NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
objResultPtr = Tcl_NewIntObj(iResult);
NEXT_INST_F(0, 2, 1);
}
case INST_STR_CMP:
{
/*
* String compare
*/
CONST char *s1, *s2;
int s1len, s2len, iResult;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
/*
* The comparison function should compare up to the
* minimum byte length only.
*/
if (valuePtr == value2Ptr) {
/*
* In the pure equality case, set lengths too for
* the checks below (or we could goto beyond it).
*/
iResult = s1len = s2len = 0;
} else if ((valuePtr->typePtr == &tclByteArrayType)
&& (value2Ptr->typePtr == &tclByteArrayType)) {
s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
iResult = memcmp(s1, s2,
(size_t) ((s1len < s2len) ? s1len : s2len));
} else if (((valuePtr->typePtr == &tclStringType)
&& (value2Ptr->typePtr == &tclStringType))) {
/*
* Do a unicode-specific comparison if both of the args are of
* String type. If the char length == byte length, we can do a
* memcmp. In benchmark testing this proved the most efficient
* check between the unicode and string comparison operations.
*/
s1len = Tcl_GetCharLength(valuePtr);
s2len = Tcl_GetCharLength(value2Ptr);
if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) {
iResult = memcmp(valuePtr->bytes, value2Ptr->bytes,
(unsigned) ((s1len < s2len) ? s1len : s2len));
} else {
iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr),
Tcl_GetUnicode(value2Ptr),
(unsigned) ((s1len < s2len) ? s1len : s2len));
}
} else {
/*
* We can't do a simple memcmp in order to handle the
* special Tcl \xC0\x80 null encoding for utf-8.
*/
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
iResult = TclpUtfNcmp2(s1, s2,
(size_t) ((s1len < s2len) ? s1len : s2len));
}
/*
* Make sure only -1,0,1 is returned
*/
if (iResult == 0) {
iResult = s1len - s2len;
}
if (iResult < 0) {
iResult = -1;
} else if (iResult > 0) {
iResult = 1;
}
objResultPtr = Tcl_NewIntObj(iResult);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
NEXT_INST_F(1, 2, 1);
}
case INST_STR_LEN:
{
int length1;
valuePtr = stackPtr[stackTop];
if (valuePtr->typePtr == &tclByteArrayType) {
(void) Tcl_GetByteArrayFromObj(valuePtr, &length1);
} else {
length1 = Tcl_GetCharLength(valuePtr);
}
objResultPtr = Tcl_NewIntObj(length1);
TRACE(("%.20s => %d\n", O2S(valuePtr), length1));
NEXT_INST_F(1, 1, 1);
}
case INST_STR_INDEX:
{
/*
* String compare
*/
int index;
bytes = NULL; /* lint */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
/*
* If we have a ByteArray object, avoid indexing in the
* Utf string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* get the index'th char.
*/
if (valuePtr->typePtr == &tclByteArrayType) {
bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
} else {
/*
* Get Unicode char length to calulate what 'end' means.
*/
length = Tcl_GetCharLength(valuePtr);
}
result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index);
if (result != TCL_OK) {
goto checkForCatch;
}
if ((index >= 0) && (index < length)) {
if (valuePtr->typePtr == &tclByteArrayType) {
objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
(&bytes[index]), 1);
} else if (valuePtr->bytes && length == valuePtr->length) {
objResultPtr = Tcl_NewStringObj((CONST char *)
(&valuePtr->bytes[index]), 1);
} else {
char buf[TCL_UTF_MAX];
Tcl_UniChar ch;
ch = Tcl_GetUniChar(valuePtr, index);
/*
* This could be:
* Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1)
* but creating the object as a string seems to be
* faster in practical use.
*/
length = Tcl_UniCharToUtf(ch, buf);
objResultPtr = Tcl_NewStringObj(buf, length);
}
} else {
TclNewObj(objResultPtr);
}
TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
case INST_STR_MATCH:
{
int nocase, match;
nocase = TclGetInt1AtPtr(pc+1);
valuePtr = stackPtr[stackTop]; /* String */
value2Ptr = stackPtr[stackTop - 1]; /* Pattern */
/*
* Check that at least one of the objects is Unicode before
* promoting both.
*/
if ((valuePtr->typePtr == &tclStringType)
|| (value2Ptr->typePtr == &tclStringType)) {
Tcl_UniChar *ustring1, *ustring2;
int length1, length2;
ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1);
ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
match = TclUniCharMatch(ustring1, length1, ustring2, length2,
nocase);
} else {
match = Tcl_StringCaseMatch(TclGetString(valuePtr),
TclGetString(value2Ptr), nocase);
}
/*
* Reuse value2Ptr object already on stack if possible.
* Adjustment is 2 due to the nocase byte
*/
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
if (Tcl_IsShared(value2Ptr)) {
objResultPtr = Tcl_NewIntObj(match);
NEXT_INST_F(2, 2, 1);
} else { /* reuse the valuePtr object */
Tcl_SetIntObj(value2Ptr, match);
NEXT_INST_F(2, 1, 0);
}
}
case INST_EQ:
case INST_NEQ:
case INST_LT:
case INST_GT:
case INST_LE:
case INST_GE:
{
/*
* Any type is allowed but the two operands must have the
* same type. We will compute value op value2.
*/
Tcl_ObjType *t1Ptr, *t2Ptr;
char *s1 = NULL; /* Init. avoids compiler warning. */
char *s2 = NULL; /* Init. avoids compiler warning. */
long i2 = 0; /* Init. avoids compiler warning. */
double d1 = 0.0; /* Init. avoids compiler warning. */
double d2 = 0.0; /* Init. avoids compiler warning. */
long iResult = 0; /* Init. avoids compiler warning. */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
/*
* Be careful in the equal-object case; 'NaN' isn't supposed
* to be equal to even itself. [Bug 761471]
*/
t1Ptr = valuePtr->typePtr;
if (valuePtr == value2Ptr) {
/*
* If we are numeric already, we can proceed to the main
* equality check right now. Otherwise, we need to try to
* coerce to a numeric type so we can see if we've got a
* NaN but haven't parsed it as numeric.
*/
if (!IS_NUMERIC_TYPE(t1Ptr)) {
if (t1Ptr == &tclListType) {
int length;
/*
* Only a list of length 1 can be NaN or such
* things.
*/
(void) Tcl_ListObjLength(NULL, valuePtr, &length);
if (length == 1) {
goto mustConvertForNaNCheck;
}
} else {
/*
* Too bad, we'll have to compute the string and
* try the conversion
*/
mustConvertForNaNCheck:
s1 = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s1, length)) {
GET_WIDE_OR_INT(iResult, valuePtr, i, w);
} else {
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d1);
}
t1Ptr = valuePtr->typePtr;
}
}
switch (*pc) {
case INST_EQ:
case INST_LE:
case INST_GE:
iResult = !((t1Ptr == &tclDoubleType)
&& IS_NAN(valuePtr->internalRep.doubleValue));
break;
case INST_LT:
case INST_GT:
iResult = 0;
break;
case INST_NEQ:
iResult = ((t1Ptr == &tclDoubleType)
&& IS_NAN(valuePtr->internalRep.doubleValue));
break;
}
goto foundResult;
}
t2Ptr = value2Ptr->typePtr;
/*
* We only want to coerce numeric validation if neither type
* is NULL. A NULL type means the arg is essentially an empty
* object ("", {} or [list]).
*/
if (!( (!t1Ptr && !valuePtr->bytes)
|| (valuePtr->bytes && !valuePtr->length)
|| (!t2Ptr && !value2Ptr->bytes)
|| (value2Ptr->bytes && !value2Ptr->length))) {
if (!IS_NUMERIC_TYPE(t1Ptr)) {
s1 = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s1, length)) {
GET_WIDE_OR_INT(iResult, valuePtr, i, w);
} else {
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d1);
}
t1Ptr = valuePtr->typePtr;
}
if (!IS_NUMERIC_TYPE(t2Ptr)) {
s2 = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s2, length)) {
GET_WIDE_OR_INT(iResult, value2Ptr, i2, w);
} else {
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
value2Ptr, &d2);
}
t2Ptr = value2Ptr->typePtr;
}
}
if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) {
/*
* One operand is not numeric. Compare as strings. NOTE:
* strcmp is not correct for \x00 < \x01, but that is
* unlikely to occur here. We could use the TclUtfNCmp2
* to handle this.
*/
int s1len, s2len;
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
switch (*pc) {
case INST_EQ:
if (s1len == s2len) {
iResult = (strcmp(s1, s2) == 0);
} else {
iResult = 0;
}
break;
case INST_NEQ:
if (s1len == s2len) {
iResult = (strcmp(s1, s2) != 0);
} else {
iResult = 1;
}
break;
case INST_LT:
iResult = (strcmp(s1, s2) < 0);
break;
case INST_GT:
iResult = (strcmp(s1, s2) > 0);
break;
case INST_LE:
iResult = (strcmp(s1, s2) <= 0);
break;
case INST_GE:
iResult = (strcmp(s1, s2) >= 0);
break;
}
} else if ((t1Ptr == &tclDoubleType)
|| (t2Ptr == &tclDoubleType)) {
/*
* Compare as doubles.
*/
if (t1Ptr == &tclDoubleType) {
d1 = valuePtr->internalRep.doubleValue;
GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr);
} else { /* t1Ptr is integer, t2Ptr is double */
GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr);
d2 = value2Ptr->internalRep.doubleValue;
}
switch (*pc) {
case INST_EQ:
iResult = d1 == d2;
break;
case INST_NEQ:
iResult = d1 != d2;
break;
case INST_LT:
iResult = d1 < d2;
break;
case INST_GT:
iResult = d1 > d2;
break;
case INST_LE:
iResult = d1 <= d2;
break;
case INST_GE:
iResult = d1 >= d2;
break;
}
} else if ((t1Ptr == &tclWideIntType)
|| (t2Ptr == &tclWideIntType)) {
Tcl_WideInt w2;
/*
* Compare as wide ints (neither are doubles)
*/
if (t1Ptr == &tclIntType) {
w = Tcl_LongAsWide(valuePtr->internalRep.longValue);
TclGetWide(w2,value2Ptr);
} else if (t2Ptr == &tclIntType) {
TclGetWide(w,valuePtr);
w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
} else {
TclGetWide(w,valuePtr);
TclGetWide(w2,value2Ptr);
}
switch (*pc) {
case INST_EQ:
iResult = w == w2;
break;
case INST_NEQ:
iResult = w != w2;
break;
case INST_LT:
iResult = w < w2;
break;
case INST_GT:
iResult = w > w2;
break;
case INST_LE:
iResult = w <= w2;
break;
case INST_GE:
iResult = w >= w2;
break;
}
} else {
/*
* Compare as ints.
*/
i = valuePtr->internalRep.longValue;
i2 = value2Ptr->internalRep.longValue;
switch (*pc) {
case INST_EQ:
iResult = i == i2;
break;
case INST_NEQ:
iResult = i != i2;
break;
case INST_LT:
iResult = i < i2;
break;
case INST_GT:
iResult = i > i2;
break;
case INST_LE:
iResult = i <= i2;
break;
case INST_GE:
iResult = i >= i2;
break;
}
}
foundResult:
TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult));
/*
* Peep-hole optimisation: if you're about to jump, do jump
* from here.
*/
pc++;
#ifndef TCL_COMPILE_DEBUG
switch (*pc) {
case INST_JUMP_FALSE1:
NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE1:
NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
case INST_JUMP_FALSE4:
NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE4:
NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
objResultPtr = Tcl_NewIntObj(iResult);
NEXT_INST_F(0, 2, 1);
}
case INST_MOD:
case INST_LSHIFT:
case INST_RSHIFT:
case INST_BITOR:
case INST_BITXOR:
case INST_BITAND:
{
/*
* Only integers are allowed. We compute value op value2.
*/
long i2 = 0, rem, negative;
long iResult = 0; /* Init. avoids compiler warning. */
Tcl_WideInt w2, wResult = W0;
int doWide = 0;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
} else { /* try to convert to int */
REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
O2S(valuePtr), O2S(value2Ptr),
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
if (value2Ptr->typePtr == &tclIntType) {
i2 = value2Ptr->internalRep.longValue;
} else if (value2Ptr->typePtr == &tclWideIntType) {
TclGetWide(w2,value2Ptr);
} else {
REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2);
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
O2S(valuePtr), O2S(value2Ptr),
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
switch (*pc) {
case INST_MOD:
/*
* This code is tricky: C doesn't guarantee much about
* the quotient or remainder, but Tcl does. The
* remainder always has the same sign as the divisor and
* a smaller absolute value.
*/
if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
if (valuePtr->typePtr == &tclIntType) {
TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2));
} else {
TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
}
goto divideByZero;
}
if (value2Ptr->typePtr == &tclIntType && i2 == 0) {
if (valuePtr->typePtr == &tclIntType) {
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
} else {
TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2));
}
goto divideByZero;
}
negative = 0;
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
Tcl_WideInt wRemainder;
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
if (w2 < 0) {
w2 = -w2;
w = -w;
negative = 1;
}
wRemainder = w % w2;
if (wRemainder < 0) {
wRemainder += w2;
}
if (negative) {
wRemainder = -wRemainder;
}
wResult = wRemainder;
doWide = 1;
break;
}
if (i2 < 0) {
i2 = -i2;
i = -i;
negative = 1;
}
rem = i % i2;
if (rem < 0) {
rem += i2;
}
if (negative) {
rem = -rem;
}
iResult = rem;
break;
case INST_LSHIFT:
/*
* Shifts are never usefully 64-bits wide!
*/
FORCE_LONG(value2Ptr, i2, w2);
if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
wResult = w;
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
wResult = Tcl_LongAsWide(0);
} else if (i2 > 60) {
wResult = w << 30;
wResult <<= 30;
wResult <<= i2-60;
} else if (i2 > 30) {
wResult = w << 30;
wResult <<= i2-30;
} else {
wResult = w << i2;
}
doWide = 1;
break;
}
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
iResult = 0;
} else if (i2 > 60) {
iResult = i << 30;
iResult <<= 30;
iResult <<= i2-60;
} else if (i2 > 30) {
iResult = i << 30;
iResult <<= i2-30;
} else {
iResult = i << i2;
}
break;
case INST_RSHIFT:
/*
* The following code is a bit tricky: it ensures that
* right shifts propagate the sign bit even on machines
* where ">>" won't do it by default.
*/
/*
* Shifts are never usefully 64-bits wide!
*/
FORCE_LONG(value2Ptr, i2, w2);
if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
if (w < 0) {
wResult = ~w;
} else {
wResult = w;
}
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
wResult = Tcl_LongAsWide(0);
} else if (i2 > 60) {
wResult >>= 30;
wResult >>= 30;
wResult >>= i2-60;
} else if (i2 > 30) {
wResult >>= 30;
wResult >>= i2-30;
} else {
wResult >>= i2;
}
if (w < 0) {
wResult = ~wResult;
}
doWide = 1;
break;
}
if (i < 0) {
iResult = ~i;
} else {
iResult = i;
}
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
iResult = 0;
} else if (i2 > 60) {
iResult >>= 30;
iResult >>= 30;
iResult >>= i2-60;
} else if (i2 > 30) {
iResult >>= 30;
iResult >>= i2-30;
} else {
iResult >>= i2;
}
if (i < 0) {
iResult = ~iResult;
}
break;
case INST_BITOR:
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
wResult = w | w2;
doWide = 1;
break;
}
iResult = i | i2;
break;
case INST_BITXOR:
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
wResult = w ^ w2;
doWide = 1;
break;
}
iResult = i ^ i2;
break;
case INST_BITAND:
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
wResult = w & w2;
doWide = 1;
break;
}
iResult = i & i2;
break;
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (Tcl_IsShared(valuePtr)) {
if (doWide) {
objResultPtr = Tcl_NewWideIntObj(wResult);
TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
} else {
objResultPtr = Tcl_NewLongObj(iResult);
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
}
NEXT_INST_F(1, 2, 1);
} else { /* reuse the valuePtr object */
if (doWide) {
TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
Tcl_SetWideIntObj(valuePtr, wResult);
} else {
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
}
NEXT_INST_F(1, 1, 0);
}
}
case INST_ADD:
case INST_SUB:
case INST_MULT:
case INST_DIV:
{
/*
* Operands must be numeric and ints get converted to floats
* if necessary. We compute value op value2.
*/
Tcl_ObjType *t1Ptr, *t2Ptr;
long i2 = 0, quot, rem; /* Init. avoids compiler warning. */
double d1, d2;
long iResult = 0; /* Init. avoids compiler warning. */
double dResult = 0.0; /* Init. avoids compiler warning. */
int doDouble = 0; /* 1 if doing floating arithmetic */
Tcl_WideInt w2, wquot, wrem;
Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
int doWide = 0; /* 1 if doing wide arithmetic. */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
if (t1Ptr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else if (t1Ptr == &tclWideIntType) {
TclGetWide(w,valuePtr);
} else if ((t1Ptr == &tclDoubleType)
&& (valuePtr->bytes == NULL)) {
/*
* We can only use the internal rep directly if there is
* no string rep. Otherwise the string rep might actually
* look like an integer, which is preferred.
*/
d1 = valuePtr->internalRep.doubleValue;
} else {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d1);
}
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
s, O2S(valuePtr),
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
t1Ptr = valuePtr->typePtr;
}
if (t2Ptr == &tclIntType) {
i2 = value2Ptr->internalRep.longValue;
} else if (t2Ptr == &tclWideIntType) {
TclGetWide(w2,value2Ptr);
} else if ((t2Ptr == &tclDoubleType)
&& (value2Ptr->bytes == NULL)) {
/*
* We can only use the internal rep directly if there is
* no string rep. Otherwise the string rep might actually
* look like an integer, which is preferred.
*/
d2 = value2Ptr->internalRep.doubleValue;
} else {
char *s = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, value2Ptr, i2, w2);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
value2Ptr, &d2);
}
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
O2S(value2Ptr), s,
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
goto checkForCatch;
}
t2Ptr = value2Ptr->typePtr;
}
if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
/*
* Do double arithmetic.
*/
doDouble = 1;
if (t1Ptr == &tclIntType) {
d1 = i; /* promote value 1 to double */
} else if (t2Ptr == &tclIntType) {
d2 = i2; /* promote value 2 to double */
} else if (t1Ptr == &tclWideIntType) {
d1 = Tcl_WideAsDouble(w);
} else if (t2Ptr == &tclWideIntType) {
d2 = Tcl_WideAsDouble(w2);
}
switch (*pc) {
case INST_ADD:
dResult = d1 + d2;
break;
case INST_SUB:
dResult = d1 - d2;
break;
case INST_MULT:
dResult = d1 * d2;
break;
case INST_DIV:
if (d2 == 0.0) {
TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
goto divideByZero;
}
dResult = d1 / d2;
break;
}
/*
* Check now for IEEE floating-point error.
*/
if (IS_NAN(dResult) || IS_INF(dResult)) {
TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
O2S(valuePtr), O2S(value2Ptr)));
DECACHE_STACK_INFO();
TclExprFloatError(interp, dResult);
CACHE_STACK_INFO();
result = TCL_ERROR;
goto checkForCatch;
}
} else if ((t1Ptr == &tclWideIntType)
|| (t2Ptr == &tclWideIntType)) {
/*
* Do wide integer arithmetic.
*/
doWide = 1;
if (t1Ptr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (t2Ptr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
switch (*pc) {
case INST_ADD:
wResult = w + w2;
break;
case INST_SUB:
wResult = w - w2;
break;
case INST_MULT:
wResult = w * w2;
break;
case INST_DIV:
/*
* This code is tricky: C doesn't guarantee much
* about the quotient or remainder, but Tcl does.
* The remainder always has the same sign as the
* divisor and a smaller absolute value.
*/
if (w2 == W0) {
TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
goto divideByZero;
}
if (w2 < 0) {
w2 = -w2;
w = -w;
}
wquot = w / w2;
wrem = w % w2;
if (wrem < W0) {
wquot -= 1;
}
wResult = wquot;
break;
}
} else {
/*
* Do integer arithmetic.
*/
switch (*pc) {
case INST_ADD:
iResult = i + i2;
break;
case INST_SUB:
iResult = i - i2;
break;
case INST_MULT:
iResult = i * i2;
break;
case INST_DIV:
/*
* This code is tricky: C doesn't guarantee much
* about the quotient or remainder, but Tcl does.
* The remainder always has the same sign as the
* divisor and a smaller absolute value.
*/
if (i2 == 0) {
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
goto divideByZero;
}
if (i2 < 0) {
i2 = -i2;
i = -i;
}
quot = i / i2;
rem = i % i2;
if (rem < 0) {
quot -= 1;
}
iResult = quot;
break;
}
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (Tcl_IsShared(valuePtr)) {
if (doDouble) {
objResultPtr = Tcl_NewDoubleObj(dResult);
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
} else if (doWide) {
objResultPtr = Tcl_NewWideIntObj(wResult);
TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
} else {
objResultPtr = Tcl_NewLongObj(iResult);
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
}
NEXT_INST_F(1, 2, 1);
} else { /* reuse the valuePtr object */
if (doDouble) { /* NB: stack top is off by 1 */
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
Tcl_SetDoubleObj(valuePtr, dResult);
} else if (doWide) {
TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
Tcl_SetWideIntObj(valuePtr, wResult);
} else {
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
}
NEXT_INST_F(1, 1, 0);
}
}
case INST_UPLUS:
{
/*
* Operand must be numeric.
*/
double d;
Tcl_ObjType *tPtr;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
s, (tPtr? tPtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
tPtr = valuePtr->typePtr;
}
/*
* Ensure that the operand's string rep is the same as the
* formatted version of its internal rep. This makes sure
* that "expr +000123" yields "83", not "000123". We
* implement this by _discarding_ the string rep since we
* know it will be regenerated, if needed later, by
* formatting the internal rep's value.
*/
if (Tcl_IsShared(valuePtr)) {
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(i);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
objResultPtr = Tcl_NewWideIntObj(w);
} else {
d = valuePtr->internalRep.doubleValue;
objResultPtr = Tcl_NewDoubleObj(d);
}
TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr);
NEXT_INST_F(1, 1, 1);
} else {
Tcl_InvalidateStringRep(valuePtr);
TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
NEXT_INST_F(1, 0, 0);
}
}
case INST_UMINUS:
case INST_LNOT:
{
/*
* The operand must be numeric or a boolean string as
* accepted by Tcl_GetBooleanFromObj(). If the operand
* object is unshared modify it directly, otherwise
* create a copy to modify: this is "copy on write".
* Free any old string representation since it is now
* invalid.
*/
double d;
int boolvar;
Tcl_ObjType *tPtr;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
valuePtr->typePtr = &tclIntType;
} else {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d);
}
if (result == TCL_ERROR && *pc == INST_LNOT) {
result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
valuePtr, &boolvar);
i = (long)boolvar; /* i is long, not int! */
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
s, (tPtr? tPtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
tPtr = valuePtr->typePtr;
}
if (Tcl_IsShared(valuePtr)) {
/*
* Create a new object.
*/
if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(
(*pc == INST_UMINUS)? -i : !i);
TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
if (*pc == INST_UMINUS) {
objResultPtr = Tcl_NewWideIntObj(-w);
} else {
objResultPtr = Tcl_NewLongObj(w == W0);
}
TRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
} else {
d = valuePtr->internalRep.doubleValue;
if (*pc == INST_UMINUS) {
objResultPtr = Tcl_NewDoubleObj(-d);
} else {
/*
* Should be able to use "!d", but apparently
* some compilers can't handle it.
*/
objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
}
TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);
}
NEXT_INST_F(1, 1, 1);
} else {
/*
* valuePtr is unshared. Modify it directly.
*/
if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
Tcl_SetLongObj(valuePtr,
(*pc == INST_UMINUS)? -i : !i);
TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
if (*pc == INST_UMINUS) {
Tcl_SetWideIntObj(valuePtr, -w);
} else {
Tcl_SetLongObj(valuePtr, w == W0);
}
TRACE_WITH_OBJ((LLD" => ", w), valuePtr);
} else {
d = valuePtr->internalRep.doubleValue;
if (*pc == INST_UMINUS) {
Tcl_SetDoubleObj(valuePtr, -d);
} else {
/*
* Should be able to use "!d", but apparently
* some compilers can't handle it.
*/
Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
}
TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
}
NEXT_INST_F(1, 0, 0);
}
}
case INST_BITNOT:
{
/*
* The operand must be an integer. If the operand object is
* unshared modify it directly, otherwise modify a copy.
* Free any old string representation since it is now
* invalid.
*/
Tcl_ObjType *tPtr;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
if (!IS_INTEGER_TYPE(tPtr)) {
REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
if (result != TCL_OK) { /* try to convert to double */
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
O2S(valuePtr), (tPtr? tPtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_NewWideIntObj(~w);
TRACE(("0x%" TCL_LL_MODIFIER "x => (%" TCL_LL_MODIFIER "u)\n",
w, ~w));
NEXT_INST_F(1, 1, 1);
} else {
/*
* valuePtr is unshared. Modify it directly.
*/
Tcl_SetWideIntObj(valuePtr, ~w);
TRACE(("0x%" TCL_LL_MODIFIER "x => (%" TCL_LL_MODIFIER "u)\n",
w, ~w));
NEXT_INST_F(1, 0, 0);
}
} else {
i = valuePtr->internalRep.longValue;
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_NewLongObj(~i);
TRACE(("0x%lx => (%lu)\n", i, ~i));
NEXT_INST_F(1, 1, 1);
} else {
/*
* valuePtr is unshared. Modify it directly.
*/
Tcl_SetLongObj(valuePtr, ~i);
TRACE(("0x%lx => (%lu)\n", i, ~i));
NEXT_INST_F(1, 0, 0);
}
}
}
case INST_CALL_BUILTIN_FUNC1:
opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call one of the built-in Tcl math functions.
*/
BuiltinFunc *mathFuncPtr;
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
}
mathFuncPtr = &(tclBuiltinFuncTable[opnd]);
DECACHE_STACK_INFO();
result = (*mathFuncPtr->proc)(interp, eePtr,
mathFuncPtr->clientData);
CACHE_STACK_INFO();
if (result != TCL_OK) {
goto checkForCatch;
}
TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
}
NEXT_INST_F(2, 0, 0);
case INST_CALL_FUNC1:
opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call a non-builtin Tcl math function previously
* registered by a call to Tcl_CreateMathFunc.
*/
int objc = opnd; /* Number of arguments. The function name
* is the 0-th argument. */
Tcl_Obj **objv; /* The array of arguments. The function
* name is objv[0]. */
objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
DECACHE_STACK_INFO();
result = ExprCallMathFunc(interp, eePtr, objc, objv);
CACHE_STACK_INFO();
if (result != TCL_OK) {
goto checkForCatch;
}
TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
}
NEXT_INST_F(2, 0, 0);
case INST_TRY_CVT_TO_NUMERIC:
{
/*
* Try to convert the topmost stack object to an int or
* double object. This is done in order to support Tcl's
* policy of interpreting operands if at all possible as
* first integers, else floating-point numbers.
*/
double d;
char *s;
Tcl_ObjType *tPtr;
int converted, needNew;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
converted = 0;
if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
valuePtr->typePtr = &tclIntType;
converted = 1;
} else {
s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d);
}
if (result == TCL_OK) {
converted = 1;
}
result = TCL_OK; /* reset the result variable */
}
tPtr = valuePtr->typePtr;
}
/*
* Ensure that the topmost stack object, if numeric, has a
* string rep the same as the formatted version of its
* internal rep. This is used, e.g., to make sure that "expr
* {0001}" yields "1", not "0001". We implement this by
* _discarding_ the string rep since we know it will be
* regenerated, if needed later, by formatting the internal
* rep's value. Also check if there has been an IEEE
* floating point error.
*/
objResultPtr = valuePtr;
needNew = 0;
if (IS_NUMERIC_TYPE(tPtr)) {
if (Tcl_IsShared(valuePtr)) {
if (valuePtr->bytes != NULL) {
/*
* We only need to make a copy of the object
* when it already had a string rep
*/
needNew = 1;
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(i);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
objResultPtr = Tcl_NewWideIntObj(w);
} else {
d = valuePtr->internalRep.doubleValue;
objResultPtr = Tcl_NewDoubleObj(d);
}
tPtr = objResultPtr->typePtr;
}
} else {
Tcl_InvalidateStringRep(valuePtr);
}
if (tPtr == &tclDoubleType) {
d = objResultPtr->internalRep.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
O2S(objResultPtr)));
DECACHE_STACK_INFO();
TclExprFloatError(interp, d);
CACHE_STACK_INFO();
result = TCL_ERROR;
goto checkForCatch;
}
}
converted = converted; /* lint, converted not used. */
TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
(converted? "converted" : "not converted"),
(needNew? "new Tcl_Obj" : "same Tcl_Obj")));
} else {
TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
}
if (needNew) {
NEXT_INST_F(1, 1, 1);
} else {
NEXT_INST_F(1, 0, 0);
}
}
case INST_BREAK:
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
result = TCL_BREAK;
cleanup = 0;
goto processExceptionReturn;
case INST_CONTINUE:
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
result = TCL_CONTINUE;
cleanup = 0;
goto processExceptionReturn;
case INST_FOREACH_START4:
opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* Initialize the temporary local var that holds the count
* of the number of iterations of the loop body to -1.
*/
ForeachInfo *infoPtr = (ForeachInfo *)
codePtr->auxDataArrayPtr[opnd].clientData;
int iterTmpIndex = infoPtr->loopCtTemp;
Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
} else {
Tcl_SetLongObj(oldValuePtr, -1);
}
TclSetVarScalar(iterVarPtr);
TclClearVarUndefined(iterVarPtr);
TRACE(("%u => loop iter count temp %d\n",
opnd, iterTmpIndex));
}
#ifndef TCL_COMPILE_DEBUG
/*
* Remark that the compiler ALWAYS sets INST_FOREACH_STEP4
* immediately after INST_FOREACH_START4 - let us just fall
* through instead of jumping back to the top.
*/
pc += 5;
TCL_DTRACE_INST_NEXT();
#else
NEXT_INST_F(5, 0, 0);
#endif
case INST_FOREACH_STEP4:
opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* "Step" a foreach loop (i.e., begin its next iteration) by
* assigning the next value list element to each loop var.
*/
ForeachInfo *infoPtr = (ForeachInfo *)
codePtr->auxDataArrayPtr[opnd].clientData;
ForeachVarList *varListPtr;
int numLists = infoPtr->numLists;
Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
Tcl_Obj *listPtr;
Var *iterVarPtr, *listVarPtr;
int iterNum, listTmpIndex, listLen, numVars;
int varIndex, valIndex, continueLoop, j;
/*
* Increment the temp holding the loop iteration number.
*/
iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
valuePtr = iterVarPtr->value.objPtr;
iterNum = (valuePtr->internalRep.longValue + 1);
Tcl_SetLongObj(valuePtr, iterNum);
/*
* Check whether all value lists are exhausted and we should
* stop the loop.
*/
continueLoop = 0;
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
result = Tcl_ListObjLength(interp, listPtr, &listLen);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
goto checkForCatch;
}
if (listLen > (iterNum * numVars)) {
continueLoop = 1;
}
listTmpIndex++;
}
/*
* If some var in some var list still has a remaining list
* element iterate one more time. Assign to var the next
* element from its value list. We already checked above
* that each list temp holds a valid list object.
*/
if (continueLoop) {
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
Tcl_Obj **elements;
/*
* The call to TclPtrSetVar might shimmer listPtr,
* so re-fetch pointers every iteration for safety.
* See test foreach-10.1.
*/
Tcl_ListObjGetElements(NULL, listPtr,
&listLen, &elements);
if (valIndex >= listLen) {
TclNewObj(valuePtr);
} else {
valuePtr = elements[valIndex];
}
varIndex = varListPtr->varIndexes[j];
varPtr = &(varFramePtr->compiledLocals[varIndex]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL))
&& (varPtr->tracePtr == NULL)
&& (TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr))) {
value2Ptr = varPtr->value.objPtr;
if (valuePtr != value2Ptr) {
if (value2Ptr != NULL) {
TclDecrRefCount(value2Ptr);
} else {
TclSetVarScalar(varPtr);
TclClearVarUndefined(varPtr);
}
varPtr->value.objPtr = valuePtr;
Tcl_IncrRefCount(valuePtr);
}
} else {
DECACHE_STACK_INFO();
Tcl_IncrRefCount(valuePtr);
value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1,
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
TclDecrRefCount(valuePtr);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
opnd, varIndex),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
}
valIndex++;
}
listTmpIndex++;
}
}
TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists,
iterNum, (continueLoop? "continue" : "exit")));
/*
* Run-time peep-hole optimisation: the compiler ALWAYS follows
* INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
* instruction and jump direct from here.
*/
pc += 5;
if (*pc == INST_JUMP_FALSE1) {
NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
} else {
NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
}
}
case INST_BEGIN_CATCH4:
/*
* Record start of the catch command with exception range index
* equal to the operand. Push the current stack depth onto the
* special catch stack.
*/
catchStackPtr[++catchTop] = stackTop;
TRACE(("%u => catchTop=%d, stackTop=%d\n",
TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
NEXT_INST_F(5, 0, 0);
case INST_END_CATCH:
catchTop--;
result = TCL_OK;
TRACE(("=> catchTop=%d\n", catchTop));
NEXT_INST_F(1, 0, 0);
case INST_PUSH_RESULT:
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
/*
* See the comments at INST_INVOKE_STK
*/
{
Tcl_Obj *newObjResultPtr;
TclNewObj(newObjResultPtr);
Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;
}
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
objResultPtr = Tcl_NewLongObj(result);
TRACE(("=> %u\n", result));
NEXT_INST_F(1, 0, 1);
default:
panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
/*
* Division by zero in an expression. Control only reaches this
* point by "goto divideByZero".
*/
divideByZero:
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
(char *) NULL);
CACHE_STACK_INFO();
result = TCL_ERROR;
goto checkForCatch;
/*
* An external evaluation (INST_INVOKE or INST_EVAL) returned
* something different from TCL_OK, or else INST_BREAK or
* INST_CONTINUE were called.
*/
processExceptionReturn:
#if TCL_COMPILE_DEBUG
switch (*pc) {
case INST_INVOKE_STK1:
case INST_INVOKE_STK4:
TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
break;
case INST_EVAL_STK:
/*
* Note that the object at stacktop has to be used
* before doing the cleanup.
*/
TRACE(("\"%.30s\" => ", O2S(stackPtr[stackTop])));
break;
default:
TRACE(("=> "));
}
#endif
if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
if (rangePtr == NULL) {
TRACE_APPEND(("no encl. loop or catch, returning %s\n",
StringForResultCode(result)));
goto abnormalReturn;
}
if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
TRACE_APPEND(("%s ...\n", StringForResultCode(result)));
goto processCatch;
}
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
if (result == TCL_BREAK) {
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->breakOffset);
TRACE_APPEND(("%s, range at %d, new pc %d\n",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->breakOffset));
NEXT_INST_F(0, 0, 0);
} else {
if (rangePtr->continueOffset == -1) {
TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
StringForResultCode(result)));
goto checkForCatch;
}
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->continueOffset);
TRACE_APPEND(("%s, range at %d, new pc %d\n",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->continueOffset));
NEXT_INST_F(0, 0, 0);
}
#if TCL_COMPILE_DEBUG
} else if (traceInstructions) {
if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
result, O2S(objPtr)));
} else {
objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("%s, result= \"%s\"\n",
StringForResultCode(result), O2S(objPtr)));
}
#endif
}
/*
* Execution has generated an "exception" such as TCL_ERROR. If the
* exception is an error, record information about what was being
* executed when the error occurred. Find the closest enclosing
* catch range, if any. If no enclosing catch range is found, stop
* execution and return the "exception" code.
*/
checkForCatch:
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
bytes = GetSrcInfoForPc(pc, codePtr, &length);
if (bytes != NULL) {
DECACHE_STACK_INFO();
Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
CACHE_STACK_INFO();
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
if (catchTop == -1) {
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... no enclosing catch, returning %s\n",
StringForResultCode(result));
}
#endif
goto abnormalReturn;
}
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
if (rangePtr == NULL) {
/*
* This is only possible when compiling a [catch] that sends its
* script to INST_EVAL. Cannot correct the compiler without
* breakingcompat with previous .tbc compiled scripts.
*/
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... no enclosing catch, returning %s\n",
StringForResultCode(result));
}
#endif
goto abnormalReturn;
}
/*
* A catch exception range (rangePtr) was found to handle an
* "exception". It was found either by checkForCatch just above or
* by an instruction during break, continue, or error processing.
* Jump to its catchOffset after unwinding the operand stack to
* the depth it had when starting to execute the range's catch
* command.
*/
processCatch:
while (stackTop > catchStackPtr[catchTop]) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
(unsigned int)(rangePtr->catchOffset));
}
#endif
pc = (codePtr->codeStart + rangePtr->catchOffset);
NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */
/*
* end of infinite loop dispatching on instructions.
*/
/*
* Abnormal return code. Restore the stack to state it had when starting
* to execute the ByteCode. Panic if the stack is below the initial level.
*/
abnormalReturn:
TCL_DTRACE_INST_LAST();
while (stackTop > initStackTop) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
if (stackTop < initStackTop) {
fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n",
(unsigned int)(pc - codePtr->codeStart),
(unsigned int) stackTop,
(unsigned int) initStackTop);
panic("TclExecuteByteCode execution failure: end stack top < start stack top");
}
/*
* Free the catch stack array if malloc'ed storage was used.
*/
if (catchStackPtr != catchStackStorage) {
ckfree((char *) catchStackPtr);
}
eePtr->stackTop = initStackTop;
return result;
#undef STATIC_CATCH_STACK_SIZE
}
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
* PrintByteCodeInfo --
*
* This procedure prints a summary about a bytecode object to stdout.
* It is called by TclExecuteByteCode when starting to execute the
* bytecode object if tclTraceExec has the value 2 or more.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
PrintByteCodeInfo(codePtr)
register ByteCode *codePtr; /* The bytecode whose summary is printed
* to stdout. */
{
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
(unsigned int) codePtr, codePtr->refCount,
codePtr->compileEpoch, (unsigned int) iPtr,
iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
codePtr->numCommands, codePtr->numSrcBytes,
codePtr->numCodeBytes, codePtr->numLitObjects,
codePtr->numAuxDataItems, codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
(codePtr->numSrcBytes?
((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
#else
0.0);
#endif
#ifdef TCL_COMPILE_STATS
fprintf(stdout, " Code %u = header %u+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
(unsigned int)codePtr->structureSize,
(unsigned int)(sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
codePtr->numCodeBytes,
(unsigned long)(codePtr->numLitObjects * sizeof(Tcl_Obj *)),
(unsigned long)(codePtr->numExceptRanges * sizeof(ExceptionRange)),
(unsigned long)(codePtr->numAuxDataItems * sizeof(AuxData)),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
if (procPtr != NULL) {
fprintf(stdout,
" Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
(unsigned int) procPtr, procPtr->refCount,
procPtr->numArgs, procPtr->numCompiledLocals);
}
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* ValidatePcAndStackTop --
*
* This procedure is called by TclExecuteByteCode when debugging to
* verify that the program counter and stack top are valid during
* execution.
*
* Results:
* None.
*
* Side effects:
* Prints a message to stderr and panics if either the pc or stack
* top are invalid.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_COMPILE_DEBUG
static void
ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound)
register ByteCode *codePtr; /* The bytecode whose summary is printed
* to stdout. */
unsigned char *pc; /* Points to first byte of a bytecode
* instruction. The program counter. */
int stackTop; /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
int stackLowerBound; /* Smallest legal value for stackTop. */
{
int stackUpperBound = stackLowerBound + codePtr->maxStackDepth;
/* Greatest legal value for stackTop. */
unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
unsigned int codeStart = (unsigned int) codePtr->codeStart;
unsigned int codeEnd = (unsigned int)
(codePtr->codeStart + codePtr->numCodeBytes);
unsigned char opCode = *pc;
if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
(unsigned int) pc);
panic("TclExecuteByteCode execution failure: bad pc");
}
if ((unsigned int) opCode > LAST_INST_OPCODE) {
fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
(unsigned int) opCode, relativePc);
panic("TclExecuteByteCode execution failure: bad opcode");
}
if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
int numChars;
char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
char *ellipsis = "";
fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
stackTop, relativePc, stackLowerBound, stackUpperBound);
if (cmd != NULL) {
if (numChars > 100) {
numChars = 100;
ellipsis = "...";
}
fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
ellipsis);
} else {
fprintf(stderr, "\n");
}
panic("TclExecuteByteCode execution failure: bad stack top");
}
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* IllegalExprOperandType --
*
* Used by TclExecuteByteCode to add an error message to errorInfo
* when an illegal operand type is detected by an expression
* instruction. The argument opndPtr holds the operand object in error.
*
* Results:
* None.
*
* Side effects:
* An error message is appended to errorInfo.
*
*----------------------------------------------------------------------
*/
static void
IllegalExprOperandType(interp, pc, opndPtr)
Tcl_Interp *interp; /* Interpreter to which error information
* pertains. */
unsigned char *pc; /* Points to the instruction being executed
* when the illegal type was found. */
Tcl_Obj *opndPtr; /* Points to the operand holding the value
* with the illegal type. */
{
unsigned char opCode = *pc;
Tcl_ResetResult(interp);
if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't use empty string as operand of \"",
operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
} else {
char *msg = "non-numeric string";
char *s, *p;
int length;
int looksLikeInt = 0;
s = Tcl_GetStringFromObj(opndPtr, &length);
p = s;
/*
* strtod() isn't at all consistent about detecting Inf and
* NaN between platforms.
*/
if (length == 3) {
if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') &&
(s[2]=='n' || s[2]=='N')) {
msg = "non-numeric floating-point value";
goto makeErrorMessage;
}
if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') &&
(s[2]=='f' || s[2]=='F')) {
msg = "infinite floating-point value";
goto makeErrorMessage;
}
}
/*
* We cannot use TclLooksLikeInt here because it passes strings
* like "10;" [Bug 587140]. We'll accept as "looking like ints"
* for the present purposes any string that looks formally like
* a (decimal|octal|hex) integer.
*/
while (length && isspace(UCHAR(*p))) {
length--;
p++;
}
if (length && ((*p == '+') || (*p == '-'))) {
length--;
p++;
}
if (length) {
if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) {
p += 2;
length -= 2;
looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p)));
if (looksLikeInt) {
length--;
p++;
while (length && isxdigit(UCHAR(*p))) {
length--;
p++;
}
}
} else {
looksLikeInt = (length && isdigit(UCHAR(*p)));
if (looksLikeInt) {
length--;
p++;
while (length && isdigit(UCHAR(*p))) {
length--;
p++;
}
}
}
while (length && isspace(UCHAR(*p))) {
length--;
p++;
}
looksLikeInt = !length;
}
if (looksLikeInt) {
/*
* If something that looks like an integer could not be
* converted, then it *must* be a bad octal or too large
* to represent [Bug 542588].
*/
if (TclCheckBadOctal(NULL, s)) {
msg = "invalid octal number";
} else {
msg = "integer value too large to represent";
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
}
} else {
/*
* See if the operand can be interpreted as a double in
* order to improve the error message.
*/
double d;
if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
msg = "floating-point value";
}
}
makeErrorMessage:
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
"\"", (char *) NULL);
}
}
/*
*----------------------------------------------------------------------
*
* TclGetSrcInfoForPc, GetSrcInfoForPc --
*
* Given a program counter value, finds the closest command in the
* bytecode code unit's CmdLocation array and returns information about
* that command's source: a pointer to its first byte and the number of
* characters.
*
* Results:
* If a command is found that encloses the program counter value, a
* pointer to the command's source is returned and the length of the
* source is stored at *lengthPtr. If multiple commands resulted in
* code at pc, information about the closest enclosing command is
* returned. If no matching command is found, NULL is returned and
* *lengthPtr is unchanged.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_TIP280
void
TclGetSrcInfoForPc (cfPtr)
CmdFrame* cfPtr;
{
ByteCode* codePtr = (ByteCode*) cfPtr->data.tebc.codePtr;
if (cfPtr->cmd.str.cmd == NULL) {
cfPtr->cmd.str.cmd = GetSrcInfoForPc((unsigned char*) cfPtr->data.tebc.pc,
codePtr,
&cfPtr->cmd.str.len);
}
if (cfPtr->cmd.str.cmd != NULL) {
/* We now have the command. We can get the srcOffset back and
* from there find the list of word locations for this command
*/
ExtCmdLoc* eclPtr;
ECL* locPtr = NULL;
int srcOffset;
Interp* iPtr = (Interp*) *codePtr->interpHandle;
Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
if (!hePtr) return;
srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
{
int i;
for (i=0; i < eclPtr->nuloc; i++) {
if (eclPtr->loc [i].srcOffset == srcOffset) {
locPtr = &(eclPtr->loc [i]);
break;
}
}
}
if (locPtr == NULL) {Tcl_Panic ("LocSearch failure");}
cfPtr->line = locPtr->line;
cfPtr->nline = locPtr->nline;
cfPtr->type = eclPtr->type;
if (eclPtr->type == TCL_LOCATION_SOURCE) {
cfPtr->data.eval.path = eclPtr->path;
Tcl_IncrRefCount (cfPtr->data.eval.path);
}
/* Do not set cfPtr->data.eval.path NULL for non-SOURCE
* Needed for cfPtr->data.tebc.codePtr.
*/
}
}
#endif
static char *
GetSrcInfoForPc(pc, codePtr, lengthPtr)
unsigned char *pc; /* The program counter value for which to
* return the closest command's source info.
* This points to a bytecode instruction
* in codePtr's code. */
ByteCode *codePtr; /* The bytecode sequence in which to look
* up the command source for the pc. */
int *lengthPtr; /* If non-NULL, the location where the
* length of the command's source should be
* stored. If NULL, no length is stored. */
{
register int pcOffset = (pc - codePtr->codeStart);
int numCmds = codePtr->numCommands;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
return NULL;
}
/*
* Decode the code and source offset and length for each command. The
* closest enclosing command is the last one whose code started before
* pcOffset.
*/
codeDeltaNext = codePtr->codeDeltaStart;
codeLengthNext = codePtr->codeLengthStart;
srcDeltaNext = codePtr->srcDeltaStart;
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset = 0;
for (i = 0; i < numCmds; i++) {
if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
codeDeltaNext++;
delta = TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(codeDeltaNext);
codeDeltaNext++;
}
codeOffset += delta;
if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
codeLengthNext++;
codeLen = TclGetInt4AtPtr(codeLengthNext);
codeLengthNext += 4;
} else {
codeLen = TclGetInt1AtPtr(codeLengthNext);
codeLengthNext++;
}
codeEnd = (codeOffset + codeLen - 1);
if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
srcDeltaNext++;
delta = TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(srcDeltaNext);
srcDeltaNext++;
}
srcOffset += delta;
if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
srcLengthNext++;
srcLen = TclGetInt4AtPtr(srcLengthNext);
srcLengthNext += 4;
} else {
srcLen = TclGetInt1AtPtr(srcLengthNext);
srcLengthNext++;
}
if (codeOffset > pcOffset) { /* best cmd already found */
break;
} else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
int dist = (pcOffset - codeOffset);
if (dist <= bestDist) {
bestDist = dist;
bestSrcOffset = srcOffset;
bestSrcLength = srcLen;
}
}
}
if (bestDist == INT_MAX) {
return NULL;
}
if (lengthPtr != NULL) {
*lengthPtr = bestSrcLength;
}
return (codePtr->source + bestSrcOffset);
}
/*
*----------------------------------------------------------------------
*
* GetExceptRangeForPc --
*
* Given a program counter value, return the closest enclosing
* ExceptionRange.
*
* Results:
* In the normal case, catchOnly is 0 (false) and this procedure
* returns a pointer to the most closely enclosing ExceptionRange
* structure regardless of whether it is a loop or catch exception
* range. This is appropriate when processing a TCL_BREAK or
* TCL_CONTINUE, which will be "handled" either by a loop exception
* range or a closer catch range. If catchOnly is nonzero, this
* procedure ignores loop exception ranges and returns a pointer to the
* closest catch range. If no matching ExceptionRange is found that
* encloses pc, a NULL is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static ExceptionRange *
GetExceptRangeForPc(pc, catchOnly, codePtr)
unsigned char *pc; /* The program counter value for which to
* search for a closest enclosing exception
* range. This points to a bytecode
* instruction in codePtr's code. */
int catchOnly; /* If 0, consider either loop or catch
* ExceptionRanges in search. If nonzero
* consider only catch ranges (and ignore
* any closer loop ranges). */
ByteCode* codePtr; /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
int numRanges = codePtr->numExceptRanges;
register ExceptionRange *rangePtr;
int pcOffset = (pc - codePtr->codeStart);
register int start;
if (numRanges == 0) {
return NULL;
}
/*
* This exploits peculiarities of our compiler: nested ranges
* are always *after* their containing ranges, so that by scanning
* backwards we are sure that the first matching range is indeed
* the deepest.
*/
rangeArrayPtr = codePtr->exceptArrayPtr;
rangePtr = rangeArrayPtr + numRanges;
while (--rangePtr >= rangeArrayPtr) {
start = rangePtr->codeOffset;
if ((start <= pcOffset) &&
(pcOffset < (start + rangePtr->numCodeBytes))) {
if ((!catchOnly)
|| (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
return rangePtr;
}
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* GetOpcodeName --
*
* This procedure is called by the TRACE and TRACE_WITH_OBJ macros
* used in TclExecuteByteCode when debugging. It returns the name of
* the bytecode instruction at a specified instruction pc.
*
* Results:
* A character string for the instruction.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_COMPILE_DEBUG
static char *
GetOpcodeName(pc)
unsigned char *pc; /* Points to the instruction whose name
* should be returned. */
{
unsigned char opCode = *pc;
return tclInstructionTable[opCode].name;
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* VerifyExprObjType --
*
* This procedure is called by the math functions to verify that
* the object is either an int or double, coercing it if necessary.
* If an error occurs during conversion, an error message is left
* in the interpreter's result unless "interp" is NULL.
*
* Results:
* TCL_OK if it was int or double, TCL_ERROR otherwise
*
* Side effects:
* objPtr is ensured to be of tclIntType, tclWideIntType or
* tclDoubleType.
*
*----------------------------------------------------------------------
*/
static int
VerifyExprObjType(interp, objPtr)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
Tcl_Obj *objPtr; /* Points to the object to type check. */
{
if (IS_NUMERIC_TYPE(objPtr->typePtr)) {
return TCL_OK;
} else {
int length, result = TCL_OK;
char *s = Tcl_GetStringFromObj(objPtr, &length);
if (TclLooksLikeInt(s, length)) {
long i;
Tcl_WideInt w;
GET_WIDE_OR_INT(result, objPtr, i, w);
/* Quiet cranky old compilers that complain about
* setting i, but not using it. */
(void)i;
} else {
double d;
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
}
if ((result != TCL_OK) && (interp != NULL)) {
Tcl_ResetResult(interp);
if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"argument to math function was an invalid octal number",
-1);
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"argument to math function didn't have numeric value",
-1);
}
}
return result;
}
}
/*
*----------------------------------------------------------------------
*
* Math Functions --
*
* This page contains the procedures that implement all of the
* built-in math functions for expressions.
*
* Results:
* Each procedure returns TCL_OK if it succeeds and pushes an
* Tcl object holding the result. If it fails it returns TCL_ERROR
* and leaves an error message in the interpreter's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ExprUnaryFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Contains the address of a procedure that
* takes one double argument and returns a
* double result. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
double d, dResult;
int result;
double (*func) _ANSI_ARGS_((double)) =
(double (*)_ANSI_ARGS_((double))) clientData;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the function's argument from the evaluation stack. Convert it
* to a double if necessary.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr);
errno = 0;
dResult = (*func)(d);
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
goto done;
}
/*
* Push a Tcl object holding the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprBinaryFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Contains the address of a procedure that
* takes two double arguments and
* returns a double result. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr, *value2Ptr;
double d1, d2, dResult;
int result;
double (*func) _ANSI_ARGS_((double, double))
= (double (*)_ANSI_ARGS_((double, double))) clientData;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the function's two arguments from the evaluation stack. Convert
* them to doubles if necessary.
*/
value2Ptr = POP_OBJECT();
valuePtr = POP_OBJECT();
if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
(VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
result = TCL_ERROR;
goto done;
}
GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr);
GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr);
errno = 0;
dResult = (*func)(d1, d2);
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
goto done;
}
/*
* Push a Tcl object holding the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
TclDecrRefCount(value2Ptr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprAbsFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
long i, iResult;
double d, dResult;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
/*
* Push a Tcl object with the result.
*/
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
if (i < 0) {
if (i == LONG_MIN) {
#ifdef TCL_WIDE_INT_IS_LONG
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent", -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
#else
/*
* Special case: abs(MIN_INT) must promote to wide.
*/
PUSH_OBJECT( Tcl_NewWideIntObj(-(Tcl_WideInt) i) );
result = TCL_OK;
goto done;
#endif
}
iResult = -i;
} else {
iResult = i;
}
PUSH_OBJECT(Tcl_NewLongObj(iResult));
} else if (valuePtr->typePtr == &tclWideIntType) {
Tcl_WideInt wResult, w;
TclGetWide(w,valuePtr);
if (w < W0) {
wResult = -w;
if (wResult < 0) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
}
} else {
wResult = w;
}
PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
dResult = -d;
} else if (d == -0.0) {
/* We need to distinguish here between positive 0.0 and
* negative -0.0, see Bug ID #2954959.
*/
static const double poszero = 0.0;
if (memcmp(&d, &poszero, sizeof(double))) {
dResult = -d;
} else {
dResult = d;
}
} else {
dResult = d;
}
if (IS_NAN(dResult) || IS_INF(dResult)) {
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
goto done;
}
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
}
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprDoubleFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
double dResult;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr);
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprIntFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
long iResult;
double d;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclIntType) {
iResult = valuePtr->internalRep.longValue;
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetLongFromWide(iResult,valuePtr);
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
if (d < (double) (long) LONG_MIN) {
tooLarge:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
}
} else {
if (d > (double) LONG_MAX) {
goto tooLarge;
}
}
if (IS_NAN(d) || IS_INF(d)) {
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto done;
}
iResult = (long) d;
}
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewLongObj(iResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprWideFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
Tcl_WideInt wResult;
double d;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(wResult,valuePtr);
} else if (valuePtr->typePtr == &tclIntType) {
wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue);
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
if (d < Tcl_WideAsDouble(LLONG_MIN)) {
tooLarge:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
}
} else {
if (d > Tcl_WideAsDouble(LLONG_MAX)) {
goto tooLarge;
}
}
if (IS_NAN(d) || IS_INF(d)) {
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto done;
}
wResult = Tcl_DoubleAsWide(d);
}
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprRandFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Interp *iPtr = (Interp *) interp;
double dResult;
long tmp; /* Algorithm assumes at least 32 bits.
* Only long guarantees that. See below. */
if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
iPtr->flags |= RAND_SEED_INITIALIZED;
/*
* Take into consideration the thread this interp is running in order
* to insure different seeds in different threads (bug #416643)
*/
iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12);
/*
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
iPtr->randSeed &= (unsigned long) 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
}
/*
* Set stackPtr and stackTop from eePtr.
*/
CACHE_STACK_INFO();
/*
* Generate the random number using the linear congruential
* generator defined by the following recurrence:
* seed = ( IA * seed ) mod IM
* where IA is 16807 and IM is (2^31) - 1. The recurrence maps
* a seed in the range [1, IM - 1] to a new seed in that same range.
* The recurrence maps IM to 0, and maps 0 back to 0, so those two
* values must not be allowed as initial values of seed.
*
* In order to avoid potential problems with integer overflow, the
* recurrence is implemented in terms of additional constants
* IQ and IR such that
* IM = IA*IQ + IR
* None of the operations in the implementation overflows a 32-bit
* signed integer, and the C type long is guaranteed to be at least
* 32 bits wide.
*
* For more details on how this algorithm works, refer to the following
* papers:
*
* S.K. Park & K.W. Miller, "Random number generators: good ones
* are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
*
* W.H. Press & S.A. Teukolsky, "Portable random number
* generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
*/
#define RAND_IA 16807
#define RAND_IM 2147483647
#define RAND_IQ 127773
#define RAND_IR 2836
#define RAND_MASK 123459876
tmp = iPtr->randSeed/RAND_IQ;
iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
if (iPtr->randSeed < 0) {
iPtr->randSeed += RAND_IM;
}
/*
* Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
* dividing by RAND_IM yields a double in the range (0, 1).
*/
dResult = iPtr->randSeed * (1.0/RAND_IM);
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
DECACHE_STACK_INFO();
return TCL_OK;
}
static int
ExprRoundFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Tcl_Obj *valuePtr, *resPtr;
double d, f, i;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if ((valuePtr->typePtr == &tclIntType) ||
(valuePtr->typePtr == &tclWideIntType)) {
result = TCL_OK;
resPtr = valuePtr;
} else {
/*
* Round the number to the nearest integer. I'd like to use round(),
* but it's C99 (or BSD), and not yet universal.
*/
d = valuePtr->internalRep.doubleValue;
f = modf(d, &i);
if (d < 0.0) {
if (f <= -0.5) {
i += -1.0;
}
if (i <= Tcl_WideAsDouble(LLONG_MIN)) {
goto tooLarge;
} else if (i <= (double) LONG_MIN) {
resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
} else {
resPtr = Tcl_NewLongObj((long) i);
}
} else {
if (f >= 0.5) {
i += 1.0;
}
if (i >= Tcl_WideAsDouble(LLONG_MAX)) {
goto tooLarge;
} else if (i >= (double) LONG_MAX) {
resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
} else {
resPtr = Tcl_NewLongObj((long) i);
}
}
}
/*
* Push the result object and free the argument Tcl_Obj.
*/
PUSH_OBJECT(resPtr);
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
/*
* Error return: result cannot be represented as an integer.
*/
tooLarge:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent",
(char *) NULL);
result = TCL_ERROR;
goto done;
}
static int
ExprSrandFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Interp *iPtr = (Interp *) interp;
Tcl_Obj *valuePtr;
long i = 0; /* Initialized to avoid compiler warning. */
/*
* Set stackPtr and stackTop from eePtr.
*/
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack. Use the value
* to reset the random number seed.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
goto badValue;
}
if (Tcl_GetLongFromObj(NULL, valuePtr, &i) != TCL_OK) {
Tcl_WideInt w;
if (Tcl_GetWideIntFromObj(interp, valuePtr, &w) != TCL_OK) {
badValue:
Tcl_AddErrorInfo(interp, "\n (argument to \"srand()\")");
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return TCL_ERROR;
}
i = Tcl_WideAsLong(w);
}
/*
* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2.
* See comments in ExprRandFunc() for more details.
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
iPtr->randSeed = i;
iPtr->randSeed &= (unsigned long) 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
/*
* To avoid duplicating the random number generation code we simply
* clean up our state and call the real random number function. That
* function will always succeed.
*/
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
ExprRandFunc(interp, eePtr, clientData);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ExprCallMathFunc --
*
* This procedure is invoked to call a non-builtin math function
* during the execution of an expression.
*
* Results:
* TCL_OK is returned if all went well and the function's value
* was computed successfully. If an error occurred, TCL_ERROR
* is returned and an error message is left in the interpreter's
* result. After a successful return this procedure pushes a Tcl object
* holding the result.
*
* Side effects:
* None, unless the called math function has side effects.
*
*----------------------------------------------------------------------
*/
static int
ExprCallMathFunc(interp, eePtr, objc, objv)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
int objc; /* Number of arguments. The function name is
* the 0-th argument. */
Tcl_Obj **objv; /* The array of arguments. The function name
* is objv[0]. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
char *funcName;
Tcl_HashEntry *hPtr;
MathFunc *mathFuncPtr; /* Information about math function. */
Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
Tcl_Value funcResult; /* Result of function call as Tcl_Value. */
register Tcl_Obj *valuePtr;
long i;
double d;
int j, k, result;
Tcl_ResetResult(interp);
/*
* Set stackPtr and stackTop from eePtr.
*/
CACHE_STACK_INFO();
/*
* Look up the MathFunc record for the function.
*/
funcName = TclGetString(objv[0]);
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown math function \"", funcName, "\"", (char *) NULL);
result = TCL_ERROR;
goto done;
}
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
if (mathFuncPtr->numArgs != (objc-1)) {
panic("ExprCallMathFunc: expected number of args %d != actual number %d",
mathFuncPtr->numArgs, objc);
result = TCL_ERROR;
goto done;
}
/*
* Collect the arguments for the function, if there are any, into the
* array "args". Note that args[0] will have the Tcl_Value that
* corresponds to objv[1].
*/
for (j = 1, k = 0; j < objc; j++, k++) {
valuePtr = objv[j];
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
/*
* Copy the object's numeric value to the argument record,
* converting it if necessary.
*/
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = i;
} else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = Tcl_LongAsWide(i);
} else {
args[k].type = TCL_INT;
args[k].intValue = i;
}
} else if (valuePtr->typePtr == &tclWideIntType) {
Tcl_WideInt w;
TclGetWide(w,valuePtr);
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = Tcl_WideAsDouble(w);
} else if (mathFuncPtr->argTypes[k] == TCL_INT) {
args[k].type = TCL_INT;
args[k].intValue = Tcl_WideAsLong(w);
} else {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = w;
}
} else {
d = valuePtr->internalRep.doubleValue;
if (mathFuncPtr->argTypes[k] == TCL_INT) {
args[k].type = TCL_INT;
args[k].intValue = (long) d;
} else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = Tcl_DoubleAsWide(d);
} else {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = d;
}
}
}
/*
* Invoke the function and copy its result back into valuePtr.
*/
result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
&funcResult);
if (result != TCL_OK) {
goto done;
}
/*
* Pop the objc top stack elements and decrement their ref counts.
*/
k = (stackTop - (objc-1));
while (stackTop >= k) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
/*
* Push the call's object result.
*/
if (funcResult.type == TCL_INT) {
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
} else if (funcResult.type == TCL_WIDE_INT) {
PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue));
} else {
d = funcResult.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto done;
}
PUSH_OBJECT(Tcl_NewDoubleObj(d));
}
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
DECACHE_STACK_INFO();
return result;
}
/*
*----------------------------------------------------------------------
*
* TclExprFloatError --
*
* This procedure is called when an error occurs during a
* floating-point operation. It reads errno and sets
* interp->objResultPtr accordingly.
*
* Results:
* interp->objResultPtr is set to hold an error message.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclExprFloatError(interp, value)
Tcl_Interp *interp; /* Where to store error message. */
double value; /* Value returned after error; used to
* distinguish underflows from overflows. */
{
char *s;
Tcl_ResetResult(interp);
if ((errno == EDOM) || IS_NAN(value)) {
s = "domain error: argument not in valid range";
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
} else if ((errno == ERANGE) || IS_INF(value)) {
if (value == 0.0) {
s = "floating-point value too small to represent";
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
} else {
s = "floating-point value too large to represent";
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
}
} else {
char msg[64 + TCL_INTEGER_SPACE];
sprintf(msg, "unknown floating-point error, errno = %d", errno);
Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
}
}
#ifdef TCL_COMPILE_STATS
/*
*----------------------------------------------------------------------
*
* TclLog2 --
*
* Procedure used while collecting compilation statistics to determine
* the log base 2 of an integer.
*
* Results:
* Returns the log base 2 of the operand. If the argument is less
* than or equal to zero, a zero is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclLog2(value)
register int value; /* The integer for which to compute the
* log base 2. */
{
register int n = value;
register int result = 0;
while (n > 1) {
n = n >> 1;
result++;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* EvalStatsCmd --
*
* Implements the "evalstats" command that prints instruction execution
* counts to stdout.
*
* Results:
* Standard Tcl results.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
EvalStatsCmd(unused, interp, objc, objv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int objc; /* The number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument strings. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &(iPtr->literalTable);
ByteCodeStats *statsPtr = &(iPtr->stats);
double totalCodeBytes, currentCodeBytes;
double totalLiteralBytes, currentLiteralBytes;
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
double strBytesSharedMultX, strBytesSharedOnce;
double numInstructions, currentHeaderBytes;
long numCurrentByteCodes, numByteCodeLits;
long refCountSum, literalMgmtBytes, sum;
int numSharedMultX, numSharedOnce;
int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
char *litTableStats;
LiteralEntry *entryPtr;
numInstructions = 0.0;
for (i = 0; i < 256; i++) {
if (statsPtr->instructionCount[i] != 0) {
numInstructions += statsPtr->instructionCount[i];
}
}
totalLiteralBytes = sizeof(LiteralTable)
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
+ (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
+ (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
+ statsPtr->totalLitStringBytes;
totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
numCurrentByteCodes =
statsPtr->numCompilations - statsPtr->numByteCodesFreed;
currentHeaderBytes = numCurrentByteCodes
* (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
literalMgmtBytes = sizeof(LiteralTable)
+ (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
+ (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
currentLiteralBytes = literalMgmtBytes
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
+ statsPtr->currentLitStringBytes;
currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
/*
* Summary statistics, total and current source and ByteCode sizes.
*/
fprintf(stdout, "\n----------------------------------------------------------------\n");
fprintf(stdout,
"Compilation and execution statistics for interpreter 0x%x\n",
(unsigned int) iPtr);
fprintf(stdout, "\nNumber ByteCodes executed %ld\n",
statsPtr->numExecutions);
fprintf(stdout, "Number ByteCodes compiled %ld\n",
statsPtr->numCompilations);
fprintf(stdout, " Mean executions/compile %.1f\n",
((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
fprintf(stdout, "\nInstructions executed %.0f\n",
numInstructions);
fprintf(stdout, " Mean inst/compile %.0f\n",
numInstructions / statsPtr->numCompilations);
fprintf(stdout, " Mean inst/execution %.0f\n",
numInstructions / statsPtr->numExecutions);
fprintf(stdout, "\nTotal ByteCodes %ld\n",
statsPtr->numCompilations);
fprintf(stdout, " Source bytes %.6g\n",
statsPtr->totalSrcBytes);
fprintf(stdout, " Code bytes %.6g\n",
totalCodeBytes);
fprintf(stdout, " ByteCode bytes %.6g\n",
statsPtr->totalByteCodeBytes);
fprintf(stdout, " Literal bytes %.6g\n",
totalLiteralBytes);
fprintf(stdout, " table %u + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
(unsigned int)sizeof(LiteralTable),
(unsigned long)iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
(unsigned long)statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
(unsigned long)statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
statsPtr->totalLitStringBytes);
fprintf(stdout, " Mean code/compile %.1f\n",
totalCodeBytes / statsPtr->numCompilations);
fprintf(stdout, " Mean code/source %.1f\n",
totalCodeBytes / statsPtr->totalSrcBytes);
fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n",
numCurrentByteCodes);
fprintf(stdout, " Source bytes %.6g\n",
statsPtr->currentSrcBytes);
fprintf(stdout, " Code bytes %.6g\n",
currentCodeBytes);
fprintf(stdout, " ByteCode bytes %.6g\n",
statsPtr->currentByteCodeBytes);
fprintf(stdout, " Literal bytes %.6g\n",
currentLiteralBytes);
fprintf(stdout, " table %u + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
(unsigned int)sizeof(LiteralTable),
(unsigned long)iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
(unsigned long)iPtr->literalTable.numEntries * sizeof(LiteralEntry),
(unsigned long)iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
statsPtr->currentLitStringBytes);
fprintf(stdout, " Mean code/source %.1f\n",
currentCodeBytes / statsPtr->currentSrcBytes);
fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n",
(currentCodeBytes + statsPtr->currentSrcBytes),
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
/*
* Tcl_IsShared statistics check
*
* This gives the refcount of each obj as Tcl_IsShared was called
* for it. Shared objects must be duplicated before they can be
* modified.
*/
numSharedMultX = 0;
fprintf(stdout, "\nTcl_IsShared object check (all objects):\n");
fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n",
tclObjsShared[1]);
for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
fprintf(stdout, " refcount ==%d %ld\n",
i, tclObjsShared[i]);
numSharedMultX += tclObjsShared[i];
}
fprintf(stdout, " refcount >=%d %ld\n",
i, tclObjsShared[0]);
numSharedMultX += tclObjsShared[0];
fprintf(stdout, " Total shared objects %d\n",
numSharedMultX);
/*
* Literal table statistics.
*/
numByteCodeLits = 0;
refCountSum = 0;
numSharedMultX = 0;
numSharedOnce = 0;
objBytesIfUnshared = 0.0;
strBytesIfUnshared = 0.0;
strBytesSharedMultX = 0.0;
strBytesSharedOnce = 0.0;
for (i = 0; i < globalTablePtr->numBuckets; i++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
numByteCodeLits++;
}
(void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
strBytesIfUnshared += (entryPtr->refCount * (length+1));
if (entryPtr->refCount > 1) {
numSharedMultX++;
strBytesSharedMultX += (length+1);
} else {
numSharedOnce++;
strBytesSharedOnce += (length+1);
}
}
}
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
- currentLiteralBytes;
fprintf(stdout, "\nTotal objects (all interps) %ld\n",
tclObjsAlloced);
fprintf(stdout, "Current objects %ld\n",
(tclObjsAlloced - tclObjsFreed));
fprintf(stdout, "Total literal objects %ld\n",
statsPtr->numLiteralsCreated);
fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
globalTablePtr->numEntries,
(globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n",
numByteCodeLits,
(numByteCodeLits * 100.0) / globalTablePtr->numEntries);
fprintf(stdout, " Literals reused > 1x %d\n",
numSharedMultX);
fprintf(stdout, " Mean reference count %.2f\n",
((double) refCountSum) / globalTablePtr->numEntries);
fprintf(stdout, " Mean len, str reused >1x %.2f\n",
(numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0));
fprintf(stdout, " Mean len, str used 1x %.2f\n",
(numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0));
fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
sharingBytesSaved,
(sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared));
fprintf(stdout, " Bytes with sharing %.6g\n",
currentLiteralBytes);
fprintf(stdout, " table %u + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
(unsigned int)sizeof(LiteralTable),
(unsigned long)iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
(unsigned long)iPtr->literalTable.numEntries * sizeof(LiteralEntry),
(unsigned long)iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
statsPtr->currentLitStringBytes);
fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",
(objBytesIfUnshared + strBytesIfUnshared),
objBytesIfUnshared, strBytesIfUnshared);
fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n",
(strBytesIfUnshared - statsPtr->currentLitStringBytes),
strBytesIfUnshared, statsPtr->currentLitStringBytes);
fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
literalMgmtBytes,
(literalMgmtBytes * 100.0) / currentLiteralBytes);
fprintf(stdout, " table %u + buckets %lu + entries %lu\n",
(unsigned int)sizeof(LiteralTable),
(unsigned long)iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
(unsigned long)iPtr->literalTable.numEntries * sizeof(LiteralEntry));
/*
* Breakdown of current ByteCode space requirements.
*/
fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
fprintf(stdout, " Bytes Pct of Avg per\n");
fprintf(stdout, " total ByteCode\n");
fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n",
statsPtr->currentByteCodeBytes,
statsPtr->currentByteCodeBytes / numCurrentByteCodes);
fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n",
currentHeaderBytes,
((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes),
currentHeaderBytes / numCurrentByteCodes);
fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n",
statsPtr->currentInstBytes,
((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentInstBytes / numCurrentByteCodes);
fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
statsPtr->currentLitBytes,
((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentLitBytes / numCurrentByteCodes);
fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n",
statsPtr->currentExceptBytes,
((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentExceptBytes / numCurrentByteCodes);
fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
statsPtr->currentAuxBytes,
((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentAuxBytes / numCurrentByteCodes);
fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n",
statsPtr->currentCmdMapBytes,
((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentCmdMapBytes / numCurrentByteCodes);
/*
* Detailed literal statistics.
*/
fprintf(stdout, "\nLiteral string sizes:\n");
fprintf(stdout, " Up to length Percentage\n");
maxSizeDecade = 0;
for (i = 31; i >= 0; i--) {
if (statsPtr->literalCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = 0; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->literalCount[i];
fprintf(stdout, " %10d %8.0f%%\n",
decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
}
litTableStats = TclLiteralStats(globalTablePtr);
fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
litTableStats);
ckfree((char *) litTableStats);
/*
* Source and ByteCode size distributions.
*/
fprintf(stdout, "\nSource sizes:\n");
fprintf(stdout, " Up to size Percentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->srcCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i >= 0; i--) {
if (statsPtr->srcCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->srcCount[i];
fprintf(stdout, " %10d %8.0f%%\n",
decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
}
fprintf(stdout, "\nByteCode sizes:\n");
fprintf(stdout, " Up to size Percentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->byteCodeCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i >= 0; i--) {
if (statsPtr->byteCodeCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->byteCodeCount[i];
fprintf(stdout, " %10d %8.0f%%\n",
decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
}
fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n");
fprintf(stdout, " Up to ms Percentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->lifetimeCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i >= 0; i--) {
if (statsPtr->lifetimeCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->lifetimeCount[i];
fprintf(stdout, " %12.3f %8.0f%%\n",
decadeHigh / 1000.0,
(sum * 100.0) / statsPtr->numByteCodesFreed);
}
/*
* Instruction counts.
*/
fprintf(stdout, "\nInstruction counts:\n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
if (statsPtr->instructionCount[i]) {
fprintf(stdout, "%20s %8ld %6.1f%%\n",
tclInstructionTable[i].name,
statsPtr->instructionCount[i],
(statsPtr->instructionCount[i]*100.0) / numInstructions);
}
}
fprintf(stdout, "\nInstructions NEVER executed:\n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
if (statsPtr->instructionCount[i] == 0) {
fprintf(stdout, "%20s\n", tclInstructionTable[i].name);
}
}
#ifdef TCL_MEM_DEBUG
fprintf(stdout, "\nHeap Statistics:\n");
TclDumpMemoryInfo(stdout);
#endif
fprintf(stdout, "\n----------------------------------------------------------------\n");
return TCL_OK;
}
#endif /* TCL_COMPILE_STATS */
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
* StringForResultCode --
*
* Procedure that returns a human-readable string representing a
* Tcl result code such as TCL_ERROR.
*
* Results:
* If the result code is one of the standard Tcl return codes, the
* result is a string representing that code such as "TCL_ERROR".
* Otherwise, the result string is that code formatted as a
* sequence of decimal digit characters. Note that the resulting
* string must not be modified by the caller.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static CONST char *
StringForResultCode(result)
int result; /* The Tcl result code for which to
* generate a string. */
{
static char buf[TCL_INTEGER_SPACE];
if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
return resultStrings[result];
}
TclFormatInt(buf, result);
return buf;
}
#endif /* TCL_COMPILE_DEBUG */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclPkg.c 0000644 0036047 0045461 00000164671 12133546540 013733 0 ustar dgp 771div /*
* tclPkg.c --
*
* This file implements package and version control for Tcl via
* the "package" command and a few C APIs.
*
* Copyright (c) 1996 Sun Microsystems, Inc.
* Copyright (c) 2006 Andreas Kupries
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* TIP #268.
* Heavily rewritten to handle the extend version numbers, and extended
* package requirements.
*/
#include "tclInt.h"
/*
* Each invocation of the "package ifneeded" command creates a structure
* of the following type, which is used to load the package into the
* interpreter if it is requested with a "package require" command.
*/
typedef struct PkgAvail {
char *version; /* Version string; malloc'ed. */
char *script; /* Script to invoke to provide this version
* of the package. Malloc'ed and protected
* by Tcl_Preserve and Tcl_Release. */
struct PkgAvail *nextPtr; /* Next in list of available versions of
* the same package. */
} PkgAvail;
/*
* For each package that is known in any way to an interpreter, there
* is one record of the following type. These records are stored in
* the "packageTable" hash table in the interpreter, keyed by
* package name such as "Tk" (no version number).
*/
typedef struct Package {
char *version; /* Version that has been supplied in this
* interpreter via "package provide"
* (malloc'ed). NULL means the package doesn't
* exist in this interpreter yet. */
PkgAvail *availPtr; /* First in list of all available versions
* of this package. */
ClientData clientData; /* Client data. */
} Package;
/*
* Prototypes for procedures defined in this file:
*/
#ifndef TCL_TIP268
static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *string));
static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1,
CONST char *v2,
int *satPtr));
static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name));
#else
static int CheckVersionAndConvert(Tcl_Interp *interp,
CONST char *string, char** internal, int* stable);
static int CompareVersions(CONST char *v1i, CONST char *v2i,
int *isMajorPtr);
static int CheckRequirement(Tcl_Interp *interp,
CONST char *string);
static int CheckAllRequirements(Tcl_Interp* interp, int reqc,
Tcl_Obj *CONST reqv[]);
static int RequirementSatisfied(char *havei, CONST char *req);
static int SomeRequirementSatisfied(char *havei, int reqc,
Tcl_Obj *CONST reqv[]);
static void AddRequirementsToResult(Tcl_Interp* interp, int reqc,
Tcl_Obj *CONST reqv[]);
static void AddRequirementsToDString(Tcl_DString* dstring,
int reqc, Tcl_Obj *CONST reqv[]);
static Package * FindPackage(Tcl_Interp *interp, CONST char *name);
static CONST char * PkgRequireCore(Tcl_Interp *interp, CONST char *name,
int reqx, Tcl_Obj *CONST reqv[],
ClientData *clientDataPtr);
#endif
/*
* Helper macros.
*/
#define DupBlock(v,s,len) \
((v) = ckalloc(len), memcpy((v),(s),(len)))
#define DupString(v,s) \
do { \
unsigned local__len = (unsigned) (strlen(s) + 1); \
DupBlock((v),(s),local__len); \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_PkgProvide / Tcl_PkgProvideEx --
*
* This procedure is invoked to declare that a particular version
* of a particular package is now present in an interpreter. There
* must not be any other version of this package already
* provided in the interpreter.
*
* Results:
* Normally returns TCL_OK; if there is already another version
* of the package loaded then TCL_ERROR is returned and an error
* message is left in the interp's result.
*
* Side effects:
* The interpreter remembers that this package is available,
* so that no other version of the package may be provided for
* the interpreter.
*
*----------------------------------------------------------------------
*/
#undef Tcl_PkgProvide
int
Tcl_PkgProvide(interp, name, version)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of package. */
CONST char *version; /* Version string for package. */
{
return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL);
}
int
Tcl_PkgProvideEx(interp, name, version, clientData)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of package. */
CONST char *version; /* Version string for package. */
ClientData clientData; /* clientdata for this package (normally
* used for C callback function table) */
{
Package *pkgPtr;
#ifdef TCL_TIP268
char* pvi;
char* vi;
int res;
#endif
pkgPtr = FindPackage(interp, name);
if (pkgPtr->version == NULL) {
DupString(pkgPtr->version, version);
pkgPtr->clientData = clientData;
return TCL_OK;
}
#ifndef TCL_TIP268
if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {
#else
if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
return TCL_ERROR;
} else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) {
ckfree(pvi);
return TCL_ERROR;
}
res = CompareVersions(pvi, vi, NULL);
ckfree(pvi);
ckfree(vi);
if (res == 0) {
#endif
if (clientData != NULL) {
pkgPtr->clientData = clientData;
}
return TCL_OK;
}
Tcl_AppendResult(interp, "conflicting versions provided for package \"",
name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc --
*
* This procedure is called by code that depends on a particular
* version of a particular package. If the package is not already
* provided in the interpreter, this procedure invokes a Tcl script
* to provide it. If the package is already provided, this
* procedure makes sure that the caller's needs don't conflict with
* the version that is present.
*
* Results:
* If successful, returns the version string for the currently
* provided version of the package, which may be different from
* the "version" argument. If the caller's requirements
* cannot be met (e.g. the version requested conflicts with
* a currently provided version, or the required version cannot
* be found, or the script to provide the required version
* generates an error), NULL is returned and an error
* message is left in the interp's result.
*
* Side effects:
* The script from some previous "package ifneeded" command may
* be invoked to provide the package.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_TIP268
/*
* Empty definition for Stubs when TIP 268 is not activated.
*/
int
Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of desired package. */
int reqc; /* Requirements constraining the desired version. */
Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */
ClientData *clientDataPtr;
{
return TCL_ERROR;
}
#endif
#undef Tcl_PkgRequire
CONST char *
Tcl_PkgRequire(interp, name, version, exact)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of desired package. */
CONST char *version; /* Version string for desired version; NULL
* means use the latest version available. */
int exact; /* Non-zero means that only the particular
* version given is acceptable. Zero means use
* the latest compatible version. */
{
return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL);
}
CONST char *
Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of desired package. */
CONST char *version; /* Version string for desired version;
* NULL means use the latest version
* available. */
int exact; /* Non-zero means that only the particular
* version given is acceptable. Zero means
* use the latest compatible version. */
ClientData *clientDataPtr; /* Used to return the client data for this
* package. If it is NULL then the client
* data is not returned. This is unchanged
* if this call fails for any reason. */
{
#ifndef TCL_TIP268
Package *pkgPtr;
PkgAvail *availPtr, *bestPtr;
char *script;
int code, satisfies, result, pass;
Tcl_DString command;
#else
Tcl_Obj *ov;
CONST char *result = NULL;
#endif
/*
* If an attempt is being made to load this into a standalone executable
* on a platform where backlinking is not supported then this must be
* a shared version of Tcl (Otherwise the load would have failed).
* Detect this situation by checking that this library has been correctly
* initialised. If it has not been then return immediately as nothing will
* work.
*/
if (tclEmptyStringRep == NULL) {
/*
* OK, so what's going on here?
*
* First, what are we doing? We are performing a check on behalf of
* one particular caller, Tcl_InitStubs(). When a package is
* stub-enabled, it is statically linked to libtclstub.a, which
* contains a copy of Tcl_InitStubs(). When a stub-enabled package
* is loaded, its *_Init() function is supposed to call
* Tcl_InitStubs() before calling any other functions in the Tcl
* library. The first Tcl function called by Tcl_InitStubs() through
* the stub table is Tcl_PkgRequireEx(), so this code right here is
* the first code that is part of the original Tcl library in the
* executable that gets executed on behalf of a newly loaded
* stub-enabled package.
*
* One easy error for the developer/builder of a stub-enabled package
* to make is to forget to define USE_TCL_STUBS when compiling the
* package. When that happens, the package will contain symbols
* that are references to the Tcl library, rather than function
* pointers referencing the stub table. On platforms that lack
* backlinking, those unresolved references may cause the loading
* of the package to also load a second copy of the Tcl library,
* leading to all kinds of trouble. We would like to catch that
* error and report a useful message back to the user. That's
* what we're doing.
*
* Second, how does this work? If we reach this point, then the
* global variable tclEmptyStringRep has the value NULL. Compare
* that with the definition of tclEmptyStringRep near the top of
* the file generic/tclObj.c. It clearly should not have the value
* NULL; it should point to the char tclEmptyString. If we see it
* having the value NULL, then somehow we are seeing a Tcl library
* that isn't completely initialized, and that's an indicator for the
* error condition described above. (Further explanation is welcome.)
*
* Third, so what do we do about it? This situation indicates
* the package we just loaded wasn't properly compiled to be
* stub-enabled, yet it thinks it is stub-enabled (it called
* Tcl_InitStubs()). We want to report that the package just
* loaded is broken, so we want to place an error message in
* the interpreter result and return NULL to indicate failure
* to Tcl_InitStubs() so that it will also fail. (Further
* explanation why we don't want to Tcl_Panic() is welcome.
* After all, two Tcl libraries can't be a good thing!)
*
* Trouble is that's going to be tricky. We're now using a Tcl
* library that's not fully initialized. In particular, it
* doesn't have a proper value for tclEmptyStringRep. The
* Tcl_Obj system heavily depends on the value of tclEmptyStringRep
* and all of Tcl depends (increasingly) on the Tcl_Obj system, we
* need to correct that flaw before making the calls to set the
* interpreter result to the error message. That's the only flaw
* corrected; other problems with initialization of the Tcl library
* are not remedied, so be very careful about adding any other calls
* here without checking how they behave when initialization is
* incomplete.
*/
tclEmptyStringRep = &tclEmptyString;
Tcl_AppendResult(interp, "Cannot load package \"", name,
"\" in standalone executable: This package is not ",
"compiled with stub support", NULL);
return NULL;
}
#ifdef TCL_TIP268
/* Translate between old and new API, and defer to the new function. */
if (version == NULL) {
result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr);
} else {
if (exact && TCL_OK
!= CheckVersionAndConvert(interp, version, NULL, NULL)) {
return NULL;
}
ov = Tcl_NewStringObj(version, -1);
if (exact) {
Tcl_AppendStringsToObj(ov, "-", version, NULL);
}
Tcl_IncrRefCount (ov);
result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr);
Tcl_DecrRefCount (ov);
}
return result;
}
int
Tcl_PkgRequireProc(
Tcl_Interp *interp, /* Interpreter in which package is now
* available. */
CONST char *name, /* Name of desired package. */
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *CONST reqv[], /* 0 means to use the latest version
* available. */
ClientData *clientDataPtr)
{
CONST char *result =
PkgRequireCore(interp, name, reqc, reqv, clientDataPtr);
if (result == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
return TCL_OK;
}
static CONST char *
PkgRequireCore(
Tcl_Interp *interp, /* Interpreter in which package is now
* available. */
CONST char *name, /* Name of desired package. */
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *CONST reqv[], /* 0 means to use the latest version
* available. */
ClientData *clientDataPtr)
{
Interp *iPtr = (Interp *) interp;
Package *pkgPtr;
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion; /* Internal rep. of versions */
int availStable;
char *script;
int code, satisfies, pass;
Tcl_DString command;
char* pkgVersionI;
#endif
/*
* It can take up to three passes to find the package: one pass to run the
* "package unknown" script, one to run the "package ifneeded" script for
* a specific version, and a final pass to lookup the package loaded by
* the "package ifneeded" script.
*/
for (pass = 1; ; pass++) {
pkgPtr = FindPackage(interp, name);
if (pkgPtr->version != NULL) {
break;
}
/*
* Check whether we're already attempting to load some version
* of this package (circular dependency detection).
*/
if (pkgPtr->clientData != NULL) {
Tcl_AppendResult(interp, "circular package dependency: ",
"attempt to provide ", name, " ",
(char *)(pkgPtr->clientData), " requires ", name, NULL);
#ifndef TCL_TIP268
if (version != NULL) {
Tcl_AppendResult(interp, " ", version, NULL);
}
#else
AddRequirementsToResult (interp, reqc, reqv);
#endif
return NULL;
}
/*
* The package isn't yet present. Search the list of available
* versions and invoke the script for the best available version.
*
* For TIP 268 we are actually locating the best, and the best stable
* version. One of them is then chosen based on the selection mode.
*/
#ifndef TCL_TIP268
bestPtr = NULL;
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
bestPtr->version, (int *) NULL) <= 0)) {
#else
bestPtr = NULL;
bestStablePtr = NULL;
bestVersion = NULL;
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert(interp, availPtr->version,
&availVersion, &availStable) != TCL_OK) {
/* The provided version number has invalid syntax. This
* should not happen. This should have been caught by the
* 'package ifneeded' registering the package.
*/
#endif
continue;
}
#ifndef TCL_TIP268
if (version != NULL) {
result = ComparePkgVersions(availPtr->version, version,
&satisfies);
if ((result != 0) && exact) {
#else
if (bestPtr != NULL) {
int res = CompareVersions (availVersion, bestVersion, NULL);
/* Note: Use internal reps! */
if (res <= 0) {
/*
* The version of the package sought is not as good as the
* currently selected version. Ignore it.
*/
ckfree(availVersion);
availVersion = NULL;
#endif
continue;
}
#ifdef TCL_TIP268
}
/* We have found a version which is better than our max. */
if (reqc > 0) {
/* Check satisfaction of requirements. */
satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
#endif
if (!satisfies) {
#ifdef TCL_TIP268
ckfree(availVersion);
availVersion = NULL;
#endif
continue;
}
}
bestPtr = availPtr;
#ifdef TCL_TIP268
if (bestVersion != NULL) {
ckfree(bestVersion);
}
bestVersion = availVersion;
availVersion = NULL;
/*
* If this new best version is stable then it also has to be
* better than the max stable version found so far.
*/
if (availStable) {
bestStablePtr = availPtr;
}
}
if (bestVersion != NULL) {
ckfree(bestVersion);
}
/* Now choose a version among the two best. For 'latest' we simply
* take (actually keep) the best. For 'stable' we take the best
* stable, if there is any, or the best if there is nothing stable.
*/
if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
&& (bestStablePtr != NULL)) {
bestPtr = bestStablePtr;
#endif
}
if (bestPtr != NULL) {
/*
* We found an ifneeded script for the package. Be careful while
* executing it: this could cause reentrancy, so (a) protect the
* script itself from deletion and (b) don't assume that bestPtr
* will still exist when the script completes.
*/
CONST char *versionToProvide = bestPtr->version;
script = bestPtr->script;
pkgPtr->clientData = (ClientData) versionToProvide;
Tcl_Preserve((ClientData) script);
Tcl_Preserve((ClientData) versionToProvide);
code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
Tcl_Release((ClientData) script);
pkgPtr = FindPackage(interp, name);
if (code == TCL_OK) {
#ifdef TCL_TIP268
Tcl_ResetResult(interp);
#endif
if (pkgPtr->version == NULL) {
#ifndef TCL_TIP268
Tcl_ResetResult(interp);
#endif
code = TCL_ERROR;
Tcl_AppendResult(interp, "attempt to provide package ",
name, " ", versionToProvide,
" failed: no version of package ", name,
" provided", NULL);
#ifndef TCL_TIP268
} else if (0 != ComparePkgVersions(
pkgPtr->version, versionToProvide, NULL)) {
/* At this point, it is clear that a prior
* [package ifneeded] command lied to us. It said
* that to get a particular version of a particular
* package, we needed to evaluate a particular script.
* However, we evaluated that script and got a different
* version than we were told. This is an error, and we
* ought to report it.
*
* However, we've been letting this type of error slide
* for a long time, and as a result, a lot of packages
* suffer from them.
*
* It's a bit too harsh to make a large number of
* existing packages start failing by releasing a
* new patch release, so we forgive this type of error
* for the rest of the Tcl 8.4 series.
*
* We considered reporting a warning, but in practice
* even that appears too harsh a change for a patch release.
*
* We limit the error reporting to only
* the situation where a broken ifneeded script leads
* to a failure to satisfy the requirement.
*/
if (version) {
result = ComparePkgVersions(
pkgPtr->version, version, &satisfies);
if (result && (exact || !satisfies)) {
Tcl_ResetResult(interp);
code = TCL_ERROR;
Tcl_AppendResult(interp,
"attempt to provide package ", name, " ",
versionToProvide, " failed: package ",
name, " ", pkgPtr->version,
" provided instead", NULL);
#else
} else {
char *pvi, *vi;
int res;
if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
NULL) != TCL_OK) {
code = TCL_ERROR;
} else if (CheckVersionAndConvert(interp,
versionToProvide, &vi, NULL) != TCL_OK) {
ckfree(pvi);
code = TCL_ERROR;
} else {
res = CompareVersions(pvi, vi, NULL);
ckfree(vi);
if (res != 0) {
/* At this point, it is clear that a prior
* [package ifneeded] command lied to us. It said
* that to get a particular version of a particular
* package, we needed to evaluate a particular
* script. However, we evaluated that script and
* got a different version than we were told.
* This is an error, and we ought to report it.
*
* However, we've been letting this type of error
* slide for a long time, and as a result, a lot
* of packages suffer from them.
*
* It's a bit too harsh to make a large number of
* existing packages start failing by releasing a
* new patch release, so we forgive this type of
* error for the rest of the Tcl 8.4 series.
*
* We considered reporting a warning, but in
* practice even that appears too harsh a change
* for a patch release.
*
* We limit the error reporting to only the
* situation where a broken ifneeded script leads
* to a failure to satisfy the requirement.
*/
if (reqc > 0) {
satisfies = SomeRequirementSatisfied(pvi,
reqc, reqv);
if (!satisfies) {
code = TCL_ERROR;
Tcl_AppendResult(interp,
"attempt to provide package ",
name, " ", versionToProvide,
" failed: package ", name, " ",
pkgPtr->version,
" provided instead", NULL);
}
}
#endif
}
#ifdef TCL_TIP268
ckfree(pvi);
#endif
}
}
} else if (code != TCL_ERROR) {
Tcl_Obj *codePtr = Tcl_NewIntObj(code);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "attempt to provide package ",
name, " ", versionToProvide, " failed: ",
"bad return code: ", Tcl_GetString(codePtr), NULL);
Tcl_DecrRefCount(codePtr);
code = TCL_ERROR;
}
Tcl_Release((ClientData) versionToProvide);
if (code != TCL_OK) {
/*
* Take a non-TCL_OK code from the script as an indication the
* package wasn't loaded properly, so the package system
* should not remember an improper load.
*
* This is consistent with our returning NULL. If we're not
* willing to tell our caller we got a particular version, we
* shouldn't store that version for telling future callers
* either.
*/
Tcl_AddErrorInfo(interp, "\n (\"package ifneeded\" script)");
if (pkgPtr->version != NULL) {
ckfree(pkgPtr->version);
pkgPtr->version = NULL;
}
pkgPtr->clientData = NULL;
return NULL;
}
break;
}
/*
* The package is not in the database. If there is a "package unknown"
* command, invoke it (but only on the first pass; after that, we
* should not get here in the first place).
*/
if (pass > 1) {
break;
}
script = ((Interp *) interp)->packageUnknown;
if (script != NULL) {
Tcl_DStringInit(&command);
Tcl_DStringAppend(&command, script, -1);
Tcl_DStringAppendElement(&command, name);
#ifndef TCL_TIP268
Tcl_DStringAppend(&command, " ", 1);
Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
-1);
if (exact) {
Tcl_DStringAppend(&command, " -exact", 7);
}
#else
AddRequirementsToDString(&command, reqc, reqv);
#endif
code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
Tcl_DStringFree(&command);
if ((code != TCL_OK) && (code != TCL_ERROR)) {
Tcl_Obj *codePtr = Tcl_NewIntObj(code);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad return code: ",
Tcl_GetString(codePtr), NULL);
Tcl_DecrRefCount(codePtr);
code = TCL_ERROR;
}
if (code == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)");
return NULL;
}
Tcl_ResetResult(interp);
}
}
if (pkgPtr->version == NULL) {
Tcl_AppendResult(interp, "can't find package ", name, (char *) NULL);
#ifndef TCL_TIP268
if (version != NULL) {
Tcl_AppendResult(interp, " ", version, (char *) NULL);
}
#else
AddRequirementsToResult(interp, reqc, reqv);
#endif
return NULL;
}
/*
* At this point we know that the package is present. Make sure that the
* provided version meets the current requirements.
*/
#ifndef TCL_TIP268
if (version == NULL) {
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
return pkgPtr->version;
#else
if (reqc == 0) {
satisfies = 1;
} else {
CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
ckfree(pkgVersionI);
#endif
}
#ifndef TCL_TIP268
result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
if ((satisfies && !exact) || (result == 0)) {
#else
if (satisfies) {
#endif
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
return pkgPtr->version;
}
Tcl_AppendResult(interp, "version conflict for package \"", name,
"\": have ", pkgPtr->version,
#ifndef TCL_TIP268
", need ", version, (char *) NULL);
#else
", need", (char*) NULL);
AddRequirementsToResult (interp, reqc, reqv);
#endif
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PkgPresent / Tcl_PkgPresentEx --
*
* Checks to see whether the specified package is present. If it
* is not then no additional action is taken.
*
* Results:
* If successful, returns the version string for the currently
* provided version of the package, which may be different from
* the "version" argument. If the caller's requirements
* cannot be met (e.g. the version requested conflicts with
* a currently provided version), NULL is returned and an error
* message is left in interp->result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#undef Tcl_PkgPresent
CONST char *
Tcl_PkgPresent(interp, name, version, exact)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of desired package. */
CONST char *version; /* Version string for desired version;
* NULL means use the latest version
* available. */
int exact; /* Non-zero means that only the particular
* version given is acceptable. Zero means
* use the latest compatible version. */
{
return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL);
}
CONST char *
Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of desired package. */
CONST char *version; /* Version string for desired version;
* NULL means use the latest version
* available. */
int exact; /* Non-zero means that only the particular
* version given is acceptable. Zero means
* use the latest compatible version. */
ClientData *clientDataPtr; /* Used to return the client data for this
* package. If it is NULL then the client
* data is not returned. This is unchanged
* if this call fails for any reason. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
Package *pkgPtr;
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
/*
* At this point we know that the package is present. Make sure
* that the provided version meets the current requirement by
* calling Tcl_PkgRequireEx() to check for us.
*/
return Tcl_PkgRequireEx(interp, name, version, exact,
clientDataPtr);
}
}
if (version != NULL) {
Tcl_AppendResult(interp, "package ", name, " ", version,
" is not present", NULL);
} else {
Tcl_AppendResult(interp, "package ", name, " is not present", NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PackageObjCmd --
*
* This procedure is invoked to process the "package" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_PackageObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *pkgOptions[] = {
"forget", "ifneeded", "names",
#ifdef TCL_TIP268
"prefer",
#endif
"present", "provide", "require", "unknown", "vcompare",
"versions", "vsatisfies", (char *) NULL
};
enum pkgOptions {
PKG_FORGET, PKG_IFNEEDED, PKG_NAMES,
#ifdef TCL_TIP268
PKG_PREFER,
#endif
PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
PKG_VERSIONS, PKG_VSATISFIES
};
Interp *iPtr = (Interp *) interp;
int optionIndex, exact, i, satisfies;
PkgAvail *availPtr, *prevPtr;
Package *pkgPtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable *tablePtr;
CONST char *version;
char *argv2, *argv3, *argv4;
#ifdef TCL_TIP268
char* iva = NULL;
char* ivb = NULL;
#endif
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum pkgOptions) optionIndex) {
case PKG_FORGET: {
char *keyString;
for (i = 2; i < objc; i++) {
keyString = Tcl_GetString(objv[i]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
if (hPtr == NULL) {
continue;
}
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (pkgPtr->version != NULL) {
ckfree(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
ckfree((char *) availPtr);
}
ckfree((char *) pkgPtr);
}
break;
}
case PKG_IFNEEDED: {
int length;
#ifdef TCL_TIP268
int res;
char *argv3i, *avi;
#endif
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
return TCL_ERROR;
}
argv3 = Tcl_GetString(objv[3]);
#ifdef TCL_TIP268
if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) {
#else
if (CheckVersion(interp, argv3) != TCL_OK) {
#endif
return TCL_ERROR;
}
argv2 = Tcl_GetString(objv[2]);
if (objc == 4) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr == NULL) {
#ifdef TCL_TIP268
ckfree(argv3i);
#endif
return TCL_OK;
}
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
argv3 = Tcl_GetStringFromObj(objv[3], &length);
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
#ifdef TCL_TIP268
if (CheckVersionAndConvert(interp, availPtr->version, &avi,
NULL) != TCL_OK) {
ckfree(argv3i);
return TCL_ERROR;
}
res = CompareVersions(avi, argv3i, NULL);
ckfree(avi);
if (res == 0){
#else
if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)
== 0) {
#endif
if (objc == 4) {
#ifdef TCL_TIP268
ckfree(argv3i);
#endif
Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
return TCL_OK;
}
Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
break;
}
}
#ifdef TCL_TIP268
ckfree(argv3i);
#endif
if (objc == 4) {
return TCL_OK;
}
if (availPtr == NULL) {
availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
DupBlock(availPtr->version, argv3, (unsigned) length + 1);
if (prevPtr == NULL) {
availPtr->nextPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr;
} else {
availPtr->nextPtr = prevPtr->nextPtr;
prevPtr->nextPtr = availPtr;
}
}
argv4 = Tcl_GetStringFromObj(objv[4], &length);
DupBlock(availPtr->script, argv4, (unsigned) length + 1);
break;
}
case PKG_NAMES: {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
tablePtr = &iPtr->packageTable;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
}
}
break;
}
case PKG_PRESENT: {
CONST char *name;
if (objc < 3) {
goto require;
}
argv2 = Tcl_GetString(objv[2]);
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
if (objc != 5) {
goto requireSyntax;
}
exact = 1;
name = TclGetString(objv[3]);
} else {
exact = 0;
name = argv2;
}
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
goto require;
}
}
#ifndef TCL_TIP268
version = NULL;
if (objc == (4 + exact)) {
version = Tcl_GetString(objv[3 + exact]);
if (CheckVersion(interp, version) != TCL_OK) {
return TCL_ERROR;
}
} else if ((objc != 3) || exact) {
goto requireSyntax;
}
#else
version = NULL;
if (exact) {
version = Tcl_GetString(objv[4]);
if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
} else {
if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
return TCL_ERROR;
}
if ((objc > 3) && (CheckVersionAndConvert(interp,
TclGetString(objv[3]), NULL, NULL) == TCL_OK)) {
version = TclGetString(objv[3]);
}
}
#endif
Tcl_PkgPresentEx(interp, name, version, exact, NULL);
return TCL_ERROR;
break;
}
case PKG_PROVIDE: {
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
return TCL_ERROR;
}
argv2 = Tcl_GetString(objv[2]);
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
}
}
return TCL_OK;
}
argv3 = Tcl_GetString(objv[3]);
#ifndef TCL_TIP268
if (CheckVersion(interp, argv3) != TCL_OK) {
#else
if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
#endif
return TCL_ERROR;
}
return Tcl_PkgProvideEx(interp, argv2, argv3, NULL);
}
case PKG_REQUIRE: {
require:
if (objc < 3) {
requireSyntax:
#ifndef TCL_TIP268
Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
#else
Tcl_WrongNumArgs(interp, 2, objv,
"?-exact? package ?requirement...?");
#endif
return TCL_ERROR;
}
#ifndef TCL_TIP268
argv2 = Tcl_GetString(objv[2]);
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
exact = 1;
} else {
exact = 0;
}
version = NULL;
if (objc == (4 + exact)) {
version = Tcl_GetString(objv[3 + exact]);
if (CheckVersion(interp, version) != TCL_OK) {
return TCL_ERROR;
}
} else if ((objc != 3) || exact) {
goto requireSyntax;
}
if (exact) {
argv3 = Tcl_GetString(objv[3]);
version = Tcl_PkgRequireEx(interp, argv3, version, exact, NULL);
} else {
version = Tcl_PkgRequireEx(interp, argv2, version, exact, NULL);
}
if (version == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
#else
version = NULL;
argv2 = Tcl_GetString(objv[2]);
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
Tcl_Obj* ov;
int res;
if (objc != 5) {
goto requireSyntax;
}
version = Tcl_GetString(objv[4]);
if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
/* Create a new-style requirement for the exact version. */
ov = Tcl_NewStringObj(version, -1);
Tcl_AppendStringsToObj(ov, "-", version, NULL);
version = NULL;
argv3 = Tcl_GetString(objv[3]);
Tcl_IncrRefCount (ov);
res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL);
Tcl_DecrRefCount (ov);
return res;
} else {
if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL);
}
#endif
break;
}
case PKG_UNKNOWN: {
int length;
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
}
} else if (objc == 3) {
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
argv2 = Tcl_GetStringFromObj(objv[2], &length);
if (argv2[0] == 0) {
iPtr->packageUnknown = NULL;
} else {
DupBlock(iPtr->packageUnknown, argv2, (unsigned) length + 1);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?command?");
return TCL_ERROR;
}
break;
}
#ifdef TCL_TIP268
case PKG_PREFER: {
/* See tclInt.h for the enum, just before Interp */
static CONST char *pkgPreferOptions[] = {
"latest", "stable", NULL
};
if (objc > 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?");
return TCL_ERROR;
} else if (objc == 3) {
/* Set value. */
int new;
if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions,
"preference", 0, &new) != TCL_OK) {
return TCL_ERROR;
}
if (new < iPtr->packagePrefer) {
iPtr->packagePrefer = new;
}
}
/* Always return current value. */
Tcl_SetObjResult(interp,
Tcl_NewStringObj(pkgPreferOptions[iPtr->packagePrefer], -1));
break;
}
#endif
case PKG_VCOMPARE: {
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
return TCL_ERROR;
}
argv3 = Tcl_GetString(objv[3]);
argv2 = Tcl_GetString(objv[2]);
#ifndef TCL_TIP268
if ((CheckVersion(interp, argv2) != TCL_OK)
|| (CheckVersion(interp, argv3) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(
ComparePkgVersions(argv2, argv3, (int *) NULL)));
#else
if ((CheckVersionAndConvert (interp, argv2, &iva, NULL) != TCL_OK)
|| (CheckVersionAndConvert (interp, argv3, &ivb, NULL)
!= TCL_OK)) {
if (iva != NULL) {
ckfree(iva);
}
/* ivb cannot be set in this branch */
return TCL_ERROR;
}
/* Comparison is done on the internal representation */
Tcl_SetObjResult(interp,
Tcl_NewIntObj(CompareVersions(iva, ivb, NULL)));
ckfree(iva);
ckfree(ivb);
#endif
break;
}
case PKG_VERSIONS: {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
}
argv2 = Tcl_GetString(objv[2]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
Tcl_AppendElement(interp, availPtr->version);
}
}
break;
}
case PKG_VSATISFIES: {
#ifdef TCL_TIP268
char* argv2i = NULL;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv,
"version requirement requirement...");
return TCL_ERROR;
}
argv2 = Tcl_GetString(objv[2]);
if ((CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK)) {
return TCL_ERROR;
} else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
ckfree(argv2i);
return TCL_ERROR;
}
satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3);
ckfree (argv2i);
#else
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
return TCL_ERROR;
}
argv3 = Tcl_GetString(objv[3]);
argv2 = Tcl_GetString(objv[2]);
if ((CheckVersion(interp, argv2) != TCL_OK)
|| (CheckVersion(interp, argv3) != TCL_OK)) {
return TCL_ERROR;
}
ComparePkgVersions(argv2, argv3, &satisfies);
#endif
Tcl_SetObjResult(interp, Tcl_NewIntObj(satisfies));
break;
}
default: {
panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FindPackage --
*
* This procedure finds the Package record for a particular package
* in a particular interpreter, creating a record if one doesn't
* already exist.
*
* Results:
* The return value is a pointer to the Package record for the
* package.
*
* Side effects:
* A new Package record may be created.
*
*----------------------------------------------------------------------
*/
static Package *
FindPackage(interp, name)
Tcl_Interp *interp; /* Interpreter to use for package lookup. */
CONST char *name; /* Name of package to fine. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
int new;
Package *pkgPtr;
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new);
if (new) {
pkgPtr = (Package *) ckalloc(sizeof(Package));
pkgPtr->version = NULL;
pkgPtr->availPtr = NULL;
pkgPtr->clientData = NULL;
Tcl_SetHashValue(hPtr, pkgPtr);
} else {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
}
return pkgPtr;
}
/*
*----------------------------------------------------------------------
*
* TclFreePackageInfo --
*
* This procedure is called during interpreter deletion to
* free all of the package-related information for the
* interpreter.
*
* Results:
* None.
*
* Side effects:
* Memory is freed.
*
*----------------------------------------------------------------------
*/
void
TclFreePackageInfo(iPtr)
Interp *iPtr; /* Interpreter that is being deleted. */
{
Package *pkgPtr;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
PkgAvail *availPtr;
for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
ckfree(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
ckfree((char *) availPtr);
}
ckfree((char *) pkgPtr);
}
Tcl_DeleteHashTable(&iPtr->packageTable);
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
}
/*
*----------------------------------------------------------------------
*
* CheckVersion / CheckVersionAndConvert --
*
* This procedure checks to see whether a version number has
* valid syntax.
*
* Results:
* If string is a properly formed version number the TCL_OK
* is returned. Otherwise TCL_ERROR is returned and an error
* message is left in the interp's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_TIP268
static int
CheckVersion(interp, string)
Tcl_Interp *interp; /* Used for error reporting. */
CONST char *string; /* Supposedly a version number, which is
* groups of decimal digits separated
* by dots. */
{
CONST char *p = string;
char prevChar;
if (!isdigit(UCHAR(*p))) { /* INTL: digit */
goto error;
}
for (prevChar = *p, p++; *p != 0; p++) {
if (!isdigit(UCHAR(*p)) &&
((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
goto error;
}
prevChar = *p;
}
if (prevChar != '.') {
return TCL_OK;
}
error:
Tcl_AppendResult(interp, "expected version number but got \"",
string, "\"", (char *) NULL);
return TCL_ERROR;
}
#else
static int
CheckVersionAndConvert(interp, string, internal, stable)
Tcl_Interp *interp; /* Used for error reporting. */
CONST char *string; /* Supposedly a version number, which is
* groups of decimal digits separated by
* dots. */
char** internal; /* Internal normalized representation */
int* stable; /* Flag: Version is (un)stable. */
{
CONST char *p = string;
char prevChar;
int hasunstable = 0;
/*
* 4* assuming that each char is a separator (a,b become ' -x ').
* 4+ to have spce for an additional -2 at the end
*/
char* ibuf = ckalloc(4+4*strlen(string));
char* ip = ibuf;
/* Basic rules
* (1) First character has to be a digit.
* (2) All other characters have to be a digit or '.'
* (3) Two '.'s may not follow each other.
* TIP 268, Modified rules
* (1) s.a.
* (2) All other characters have to be a digit, 'a', 'b', or '.'
* (3) s.a.
* (4) Only one of 'a' or 'b' may occur.
* (5) Neither 'a', nor 'b' may occur before or after a '.'
*/
if (!isdigit(UCHAR(*p))) { /* INTL: digit */
goto error;
}
*ip++ = *p;
for (prevChar = *p, p++; *p != 0; p++) {
if ((!isdigit(UCHAR(*p))) && (((*p != '.') && (*p != 'a')
&& (*p != 'b')) || ((hasunstable && ((*p == 'a')
|| (*p == 'b'))) || (((prevChar == 'a') || (prevChar == 'b')
|| (prevChar == '.')) && (*p == '.')) || (((*p == 'a')
|| (*p == 'b') || (*p == '.')) && (prevChar == '.'))))) {
/* INTL: digit */
goto error;
}
if ((*p == 'a') || (*p == 'b')) {
hasunstable = 1;
}
/*
* Translation to the internal rep. Regular version chars are copied
* as is. The separators are translated to numerics. The new separator
* for all parts is space.
*/
if (*p == '.') {
*ip++ = ' ';
*ip++ = '0';
*ip++ = ' ';
} else if (*p == 'a') {
*ip++ = ' ';
*ip++ = '-';
*ip++ = '2';
*ip++ = ' ';
} else if (*p == 'b') {
*ip++ = ' ';
*ip++ = '-';
*ip++ = '1';
*ip++ = ' ';
} else {
*ip++ = *p;
}
prevChar = *p;
}
if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) {
*ip = '\0';
if (internal != NULL) {
*internal = ibuf;
} else {
ckfree(ibuf);
}
if (stable != NULL) {
*stable = !hasunstable;
}
return TCL_OK;
}
error:
ckfree(ibuf);
Tcl_AppendResult(interp, "expected version number but got \"",
string, "\"", (char *) NULL);
return TCL_ERROR;
}
#endif
/*
*----------------------------------------------------------------------
*
* ComparePkgVersions / CompareVersions --
*
* This procedure compares two version numbers. (268: in internal rep).
*
* Results:
* The return value is -1 if v1 is less than v2, 0 if the two
* version numbers are the same, and 1 if v1 is greater than v2.
* If *satPtr is non-NULL, the word it points to is filled in
* with 1 if v2 >= v1 and both numbers have the same major number
* or 0 otherwise.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_TIP268
static int
ComparePkgVersions(v1, v2, satPtr)
CONST char *v1;
CONST char *v2; /* Versions strings, of form 2.1.3 (any
* number of version numbers). */
int *satPtr; /* If non-null, the word pointed to is
* filled in with a 0/1 value. 1 means
* v1 "satisfies" v2: v1 is greater than
* or equal to v2 and both version numbers
* have the same major number. */
{
int thisIsMajor, n1, n2;
/*
* Each iteration of the following loop processes one number from each
* string, terminated by a " " (space). If those numbers don't match then
* the comparison is over; otherwise, we loop back for the next number.
*/
thisIsMajor = 1;
while (1) {
/* Parse one decimal number from the front of each string. */
n1 = n2 = 0;
while ((*v1 != 0) && (*v1 != '.')) {
n1 = 10*n1 + (*v1 - '0');
v1++;
}
while ((*v2 != 0) && (*v2 != '.')) {
n2 = 10*n2 + (*v2 - '0');
v2++;
}
/*
* Compare and go on to the next version number if the current numbers
* match.
*/
if (n1 != n2) {
break;
}
if (*v1 != 0) {
v1++;
} else if (*v2 == 0) {
break;
}
if (*v2 != 0) {
v2++;
}
thisIsMajor = 0;
}
if (satPtr != NULL) {
*satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
}
if (n1 > n2) {
return 1;
} else if (n1 == n2) {
return 0;
} else {
return -1;
}
}
#else
static int
CompareVersions(v1, v2, isMajorPtr)
CONST char *v1; /* Versions strings, of form 2.1.3 (any number */
CONST char *v2; /* of version numbers). */
int *isMajorPtr; /* If non-null, the word pointed to is filled
* in with a 0/1 value. 1 means that the difference
* occured in the first element. */
{
int thisIsMajor, n1, n2;
int res, flip;
/*
* Each iteration of the following loop processes one number from each
* string, terminated by a " " (space). If those numbers don't match then
* the comparison is over; otherwise, we loop back for the next number.
*
* TIP 268.
* This is identical the function 'ComparePkgVersion', but using the new
* space separator as used by the internal rep of version numbers. The
* special separators 'a' and 'b' have already been dealt with in
* 'CheckVersionAndConvert', they were translated into numbers as
* well. This keeps the comparison sane. Otherwise we would have to
* compare numerics, the separators, and also deal with the special case
* of end-of-string compared to separators. The semi-list rep we get here
* is much easier to handle, as it is still regular.
*/
thisIsMajor = 1;
while (1) {
/* Parse one decimal number from the front of each string. */
n1 = n2 = 0;
flip = 0;
while ((*v1 != 0) && (*v1 != ' ')) {
if (*v1 == '-') {flip = 1 ; v1++ ; continue;}
n1 = 10*n1 + (*v1 - '0');
v1++;
}
if (flip) n1 = -n1;
flip = 0;
while ((*v2 != 0) && (*v2 != ' ')) {
if (*v2 == '-') {flip = 1; v2++ ; continue;}
n2 = 10*n2 + (*v2 - '0');
v2++;
}
if (flip) n2 = -n2;
/*
* Compare and go on to the next version number if the current numbers
* match.
*/
if (n1 != n2) {
break;
}
if (*v1 != 0) {
v1++;
} else if (*v2 == 0) {
break;
}
if (*v2 != 0) {
v2++;
}
thisIsMajor = 0;
}
if (n1 > n2) {
res = 1;
} else if (n1 == n2) {
res = 0;
} else {
res = -1;
}
if (isMajorPtr != NULL) {
*isMajorPtr = thisIsMajor;
}
return res;
}
/*
*----------------------------------------------------------------------
*
* CheckAllRequirements --
*
* This function checks to see whether all requirements in a set
* have valid syntax.
*
* Results:
* TCL_OK is returned if all requirements are valid.
* Otherwise TCL_ERROR is returned and an error message
* is left in the interp's result.
*
* Side effects:
* May modify the interpreter result.
*
*----------------------------------------------------------------------
*/
static int
CheckAllRequirements(interp, reqc, reqv)
Tcl_Interp* interp;
int reqc; /* Requirements to check. */
Tcl_Obj *CONST reqv[];
{
int i;
for (i = 0; i < reqc; i++) {
if ((CheckRequirement(interp, Tcl_GetString(reqv[i])) != TCL_OK)) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* CheckRequirement --
*
* This function checks to see whether a requirement has valid syntax.
*
* Results:
* If string is a properly formed requirement then TCL_OK is returned.
* Otherwise TCL_ERROR is returned and an error message is left in the
* interp's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CheckRequirement(interp, string)
Tcl_Interp *interp; /* Used for error reporting. */
CONST char *string; /* Supposedly a requirement. */
{
/* Syntax of requirement = version
* = version-version
* = version-
*/
char* dash = NULL;
char* buf;
dash = strchr (string, '-');
if (dash == NULL) {
/* no dash found, has to be a simple version */
return CheckVersionAndConvert (interp, string, NULL, NULL);
}
if (strchr (dash+1, '-') != NULL) {
/* More dashes found after the first. This is wrong. */
Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"",
string, "\"", NULL);
return TCL_ERROR;
}
/* Exactly one dash is present. Copy the string, split at the location of
* dash and check that both parts are versions. Note that the max part can
* be empty.
*/
DupString(buf, string);
dash = buf + (dash - string);
*dash = '\0'; /* buf now <=> min part */
dash ++; /* dash now <=> max part */
if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK)
|| ((*dash != '\0')
&& (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) {
ckfree(buf);
return TCL_ERROR;
}
ckfree(buf);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AddRequirementsToResult --
*
* This function accumulates requirements in the interpreter result.
*
* Results:
* None.
*
* Side effects:
* The interpreter result is extended.
*
*----------------------------------------------------------------------
*/
static void
AddRequirementsToResult(interp, reqc, reqv)
Tcl_Interp* interp;
int reqc; /* Requirements constraining the desired version. */
Tcl_Obj *CONST reqv[]; /* 0 means use the latest version available. */
{
if (reqc > 0) {
int i;
for (i = 0; i < reqc; i++) {
int length;
char *v = Tcl_GetStringFromObj(reqv[i], &length);
if ((length & 0x1) && (v[length/2] == '-')
&& (strncmp(v, v+((length+1)/2), length/2) == 0)) {
Tcl_AppendResult(interp, " ", v+((length+1)/2), NULL);
} else {
Tcl_AppendResult(interp, " ", v, NULL);
}
}
}
}
/*
*----------------------------------------------------------------------
*
* AddRequirementsToDString --
*
* This function accumulates requirements in a DString.
*
* Results:
* None.
*
* Side effects:
* The DString argument is extended.
*
*----------------------------------------------------------------------
*/
static void
AddRequirementsToDString(dstring, reqc, reqv)
Tcl_DString* dstring;
int reqc; /* Requirements constraining the desired version. */
Tcl_Obj *CONST reqv[]; /* 0 means use the latest version available. */
{
if (reqc > 0) {
int i;
for (i = 0; i < reqc; i++) {
Tcl_DStringAppend(dstring, " ", 1);
Tcl_DStringAppend(dstring, TclGetString(reqv[i]), -1);
}
} else {
Tcl_DStringAppend(dstring, " 0-", -1);
}
}
/*
*----------------------------------------------------------------------
*
* SomeRequirementSatisfied --
*
* This function checks to see whether a version satisfies at
* least one of a set of requirements.
*
* Results:
* If the requirements are satisfied 1 is returned.
* Otherwise 0 is returned. The function assumes
* that all pieces have valid syntax. And is allowed
* to make that assumption.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
SomeRequirementSatisfied(availVersionI, reqc, reqv)
char *availVersionI; /* Candidate version to check against the
* requirements. */
int reqc; /* Requirements constraining the desired
* version. */
Tcl_Obj *CONST reqv[]; /* 0 means use the latest version available. */
{
int i;
for (i = 0; i < reqc; i++) {
if (RequirementSatisfied(availVersionI, Tcl_GetString(reqv[i]))) {
return 1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* RequirementSatisfied --
*
* This function checks to see whether a version satisfies a requirement.
*
* Results:
* If the requirement is satisfied 1 is returned.
* Otherwise 0 is returned. The function assumes
* that all pieces have valid syntax. And is allowed
* to make that assumption.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
RequirementSatisfied(havei, req)
char *havei; /* Version string, of candidate package we have */
CONST char *req; /* Requirement string the candidate has to satisfy */
{
/* The have candidate is already in internal rep. */
int satisfied, res;
char* dash = NULL;
char* buf, *min, *max;
dash = strchr (req, '-');
if (dash == NULL) {
/* No dash found, is a simple version, fallback to regular check.
* The 'CheckVersionAndConvert' cannot fail. We pad the requirement with
* 'a0', i.e '-2' before doing the comparison to properly accept
* unstables as well.
*/
char* reqi = NULL;
int thisIsMajor;
CheckVersionAndConvert (NULL, req, &reqi, NULL);
strcat (reqi, " -2");
res = CompareVersions(havei, reqi, &thisIsMajor);
satisfied = (res == 0) || ((res == 1) && !thisIsMajor);
ckfree(reqi);
return satisfied;
}
/* Exactly one dash is present (Assumption of valid syntax). Copy the req,
* split at the location of dash and check that both parts are
* versions. Note that the max part can be empty.
*/
DupString(buf, req);
dash = buf + (dash - req);
*dash = '\0'; /* buf now <=> min part */
dash ++; /* dash now <=> max part */
if (*dash == '\0') {
/* We have a min, but no max. For the comparison we generate the
* internal rep, padded with 'a0' i.e. '-2'.
*/
/* No max part, unbound */
CheckVersionAndConvert (NULL, buf, &min, NULL);
strcat (min, " -2");
satisfied = (CompareVersions(havei, min, NULL) >= 0);
ckfree(min);
ckfree(buf);
return satisfied;
}
/* We have both min and max, and generate their internal reps.
* When identical we compare as is, otherwise we pad with 'a0'
* to ove the range a bit.
*/
CheckVersionAndConvert (NULL, buf, &min, NULL);
CheckVersionAndConvert (NULL, dash, &max, NULL);
if (CompareVersions(min, max, NULL) == 0) {
satisfied = (CompareVersions(min, havei, NULL) == 0);
} else {
strcat (min, " -2");
strcat (max, " -2");
satisfied = ((CompareVersions(min, havei, NULL) <= 0) &&
(CompareVersions(havei, max, NULL) < 0));
}
ckfree(min);
ckfree(max);
ckfree(buf);
return satisfied;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
#endif
tcl8.4.20/generic/tcl.decls 0000644 0036047 0045461 00000140706 12133546537 014140 0 ustar dgp 771div # tcl.decls --
#
# This file contains the declarations for all supported public
# functions that are exported by the Tcl library via the stubs table.
# This file is used to generate the tclDecls.h, tclPlatDecls.h,
# tclStub.c, and tclPlatStub.c files.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
library tcl
# Define the tcl interface with several sub interfaces:
# tclPlat - platform specific public
# tclInt - generic private
# tclPlatInt - platform specific private
interface tcl
hooks {tclPlat tclInt tclIntPlat}
# Declare each of the functions in the public Tcl interface. Note that
# the an index should never be reused for a different function in order
# to preserve backwards compatibility.
declare 0 {
int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name,
const char *version, ClientData clientData)
}
declare 1 {
CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
ClientData *clientDataPtr)
}
declare 2 {
void Tcl_Panic(const char *format, ...)
}
declare 3 {
char *Tcl_Alloc(unsigned int size)
}
declare 4 {
void Tcl_Free(char *ptr)
}
declare 5 {
char *Tcl_Realloc(char *ptr, unsigned int size)
}
declare 6 {
char *Tcl_DbCkalloc(unsigned int size, const char *file, int line)
}
declare 7 {
void Tcl_DbCkfree(char *ptr, const char *file, int line)
}
declare 8 {
char *Tcl_DbCkrealloc(char *ptr, unsigned int size,
const char *file, int line)
}
# Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on unix,
# but they are part of the old generic interface, so we include them here for
# compatibility reasons.
declare 9 unix {
void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc,
ClientData clientData)
}
declare 10 unix {
void Tcl_DeleteFileHandler(int fd)
}
declare 11 {
void Tcl_SetTimer(Tcl_Time *timePtr)
}
declare 12 {
void Tcl_Sleep(int ms)
}
declare 13 {
int Tcl_WaitForEvent(Tcl_Time *timePtr)
}
declare 14 {
int Tcl_AppendAllObjTypes(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 15 {
void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
}
declare 16 {
void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, int length)
}
declare 17 {
Tcl_Obj *Tcl_ConcatObj(int objc, Tcl_Obj *const objv[])
}
declare 18 {
int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_ObjType *typePtr)
}
declare 19 {
void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
declare 20 {
void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
declare 21 {
int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
declare 22 {
Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line)
}
declare 23 {
Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, int length,
const char *file, int line)
}
declare 24 {
Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file,
int line)
}
declare 25 {
Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
const char *file, int line)
}
declare 26 {
Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line)
}
declare 27 {
Tcl_Obj *Tcl_DbNewObj(const char *file, int line)
}
declare 28 {
Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, int length,
const char *file, int line)
}
declare 29 {
Tcl_Obj *Tcl_DuplicateObj(Tcl_Obj *objPtr)
}
declare 30 {
void TclFreeObj(Tcl_Obj *objPtr)
}
declare 31 {
int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr)
}
declare 32 {
int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int *boolPtr)
}
declare 33 {
unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
declare 34 {
int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr)
}
declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
declare 36 {
int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
CONST84 char **tablePtr, const char *msg, int flags, int *indexPtr)
}
declare 37 {
int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr)
}
declare 38 {
int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
}
declare 39 {
int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)
}
declare 40 {
Tcl_ObjType *Tcl_GetObjType(const char *typeName)
}
declare 41 {
char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
declare 42 {
void Tcl_InvalidateStringRep(Tcl_Obj *objPtr)
}
declare 43 {
int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *elemListPtr)
}
declare 44 {
int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *objPtr)
}
declare 45 {
int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *objcPtr, Tcl_Obj ***objvPtr)
}
declare 46 {
int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index,
Tcl_Obj **objPtrPtr)
}
declare 47 {
int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *lengthPtr)
}
declare 48 {
int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first,
int count, int objc, Tcl_Obj *const objv[])
}
declare 49 {
Tcl_Obj *Tcl_NewBooleanObj(int boolValue)
}
declare 50 {
Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int length)
}
declare 51 {
Tcl_Obj *Tcl_NewDoubleObj(double doubleValue)
}
declare 52 {
Tcl_Obj *Tcl_NewIntObj(int intValue)
}
declare 53 {
Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[])
}
declare 54 {
Tcl_Obj *Tcl_NewLongObj(long longValue)
}
declare 55 {
Tcl_Obj *Tcl_NewObj(void)
}
declare 56 {
Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length)
}
declare 57 {
void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue)
}
declare 58 {
unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length)
}
declare 59 {
void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes,
int length)
}
declare 60 {
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
}
declare 61 {
void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
}
declare 62 {
void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[])
}
declare 63 {
void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
}
declare 64 {
void Tcl_SetObjLength(Tcl_Obj *objPtr, int length)
}
declare 65 {
void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length)
}
declare 66 {
void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message)
}
declare 67 {
void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message,
int length)
}
declare 68 {
void Tcl_AllowExceptions(Tcl_Interp *interp)
}
declare 69 {
void Tcl_AppendElement(Tcl_Interp *interp, const char *element)
}
declare 70 {
void Tcl_AppendResult(Tcl_Interp *interp, ...)
}
declare 71 {
Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
ClientData clientData)
}
declare 72 {
void Tcl_AsyncDelete(Tcl_AsyncHandler async)
}
declare 73 {
int Tcl_AsyncInvoke(Tcl_Interp *interp, int code)
}
declare 74 {
void Tcl_AsyncMark(Tcl_AsyncHandler async)
}
declare 75 {
int Tcl_AsyncReady(void)
}
declare 76 {
void Tcl_BackgroundError(Tcl_Interp *interp)
}
declare 77 {
char Tcl_Backslash(const char *src, int *readPtr)
}
declare 78 {
int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName,
const char *optionList)
}
declare 79 {
void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
ClientData clientData)
}
declare 80 {
void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData)
}
declare 81 {
int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 82 {
int Tcl_CommandComplete(const char *cmd)
}
declare 83 {
char *Tcl_Concat(int argc, CONST84 char *const *argv)
}
declare 84 {
int Tcl_ConvertElement(const char *src, char *dst, int flags)
}
declare 85 {
int Tcl_ConvertCountedElement(const char *src, int length, char *dst,
int flags)
}
declare 86 {
int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd,
Tcl_Interp *target, const char *targetCmd, int argc,
CONST84 char *const *argv)
}
declare 87 {
int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd,
Tcl_Interp *target, const char *targetCmd, int objc,
Tcl_Obj *const objv[])
}
declare 88 {
Tcl_Channel Tcl_CreateChannel(Tcl_ChannelType *typePtr,
const char *chanName, ClientData instanceData, int mask)
}
declare 89 {
void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask,
Tcl_ChannelProc *proc, ClientData clientData)
}
declare 90 {
void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
ClientData clientData)
}
declare 91 {
Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName,
Tcl_CmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 92 {
void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc, ClientData clientData)
}
declare 93 {
void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
declare 95 {
void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name,
int numArgs, Tcl_ValueType *argTypes,
Tcl_MathProc *proc, ClientData clientData)
}
declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName,
Tcl_ObjCmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 {
Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *slaveName,
int isSafe)
}
declare 98 {
Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
Tcl_TimerProc *proc, ClientData clientData)
}
declare 99 {
Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level,
Tcl_CmdTraceProc *proc, ClientData clientData)
}
declare 100 {
void Tcl_DeleteAssocData(Tcl_Interp *interp, const char *name)
}
declare 101 {
void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc,
ClientData clientData)
}
declare 102 {
void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
ClientData clientData)
}
declare 103 {
int Tcl_DeleteCommand(Tcl_Interp *interp, const char *cmdName)
}
declare 104 {
int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command)
}
declare 105 {
void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, ClientData clientData)
}
declare 106 {
void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc, ClientData clientData)
}
declare 107 {
void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 108 {
void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr)
}
declare 109 {
void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr)
}
declare 110 {
void Tcl_DeleteInterp(Tcl_Interp *interp)
}
declare 111 {
void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr)
}
declare 112 {
void Tcl_DeleteTimerHandler(Tcl_TimerToken token)
}
declare 113 {
void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace)
}
declare 114 {
void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc, ClientData clientData)
}
declare 115 {
int Tcl_DoOneEvent(int flags)
}
declare 116 {
void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData)
}
declare 117 {
char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, int length)
}
declare 118 {
char *Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element)
}
declare 119 {
void Tcl_DStringEndSublist(Tcl_DString *dsPtr)
}
declare 120 {
void Tcl_DStringFree(Tcl_DString *dsPtr)
}
declare 121 {
void Tcl_DStringGetResult(Tcl_Interp *interp, Tcl_DString *dsPtr)
}
declare 122 {
void Tcl_DStringInit(Tcl_DString *dsPtr)
}
declare 123 {
void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr)
}
declare 124 {
void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length)
}
declare 125 {
void Tcl_DStringStartSublist(Tcl_DString *dsPtr)
}
declare 126 {
int Tcl_Eof(Tcl_Channel chan)
}
declare 127 {
CONST84_RETURN char *Tcl_ErrnoId(void)
}
declare 128 {
CONST84_RETURN char *Tcl_ErrnoMsg(int err)
}
declare 129 {
int Tcl_Eval(Tcl_Interp *interp, const char *script)
}
# This is obsolete, use Tcl_FSEvalFile
declare 130 {
int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
}
declare 131 {
int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 132 {
void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc)
}
declare 133 {
void Tcl_Exit(int status)
}
declare 134 {
int Tcl_ExposeCommand(Tcl_Interp *interp, const char *hiddenCmdToken,
const char *cmdName)
}
declare 135 {
int Tcl_ExprBoolean(Tcl_Interp *interp, const char *expr, int *ptr)
}
declare 136 {
int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr)
}
declare 137 {
int Tcl_ExprDouble(Tcl_Interp *interp, const char *expr, double *ptr)
}
declare 138 {
int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr)
}
declare 139 {
int Tcl_ExprLong(Tcl_Interp *interp, const char *expr, long *ptr)
}
declare 140 {
int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr)
}
declare 141 {
int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_Obj **resultPtrPtr)
}
declare 142 {
int Tcl_ExprString(Tcl_Interp *interp, const char *expr)
}
declare 143 {
void Tcl_Finalize(void)
}
declare 144 {
void Tcl_FindExecutable(const char *argv0)
}
declare 145 {
Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr)
}
declare 146 {
int Tcl_Flush(Tcl_Channel chan)
}
declare 147 {
void Tcl_FreeResult(Tcl_Interp *interp)
}
declare 148 {
int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd,
Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
int *argcPtr, CONST84 char ***argvPtr)
}
declare 149 {
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd,
Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
declare 150 {
ClientData Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc **procPtr)
}
declare 151 {
Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName,
int *modePtr)
}
declare 152 {
int Tcl_GetChannelBufferSize(Tcl_Channel chan)
}
declare 153 {
int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
ClientData *handlePtr)
}
declare 154 {
ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan)
}
declare 155 {
int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 {
CONST84_RETURN char *Tcl_GetChannelName(Tcl_Channel chan)
}
declare 157 {
int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
const char *optionName, Tcl_DString *dsPtr)
}
declare 158 {
Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan)
}
declare 159 {
int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName,
Tcl_CmdInfo *infoPtr)
}
declare 160 {
CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command)
}
declare 161 {
int Tcl_GetErrno(void)
}
declare 162 {
CONST84_RETURN char *Tcl_GetHostName(void)
}
declare 163 {
int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp)
}
declare 164 {
Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp)
}
declare 165 {
const char *Tcl_GetNameOfExecutable(void)
}
declare 166 {
Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp)
}
# Tcl_GetOpenFile is only available on unix, but it is a part of the old
# generic interface, so we inlcude it here for compatibility reasons.
declare 167 unix {
int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting,
int checkUsage, ClientData *filePtr)
}
# Obsolete. Should now use Tcl_FSGetPathType which is objectified
# and therefore usually faster.
declare 168 {
Tcl_PathType Tcl_GetPathType(const char *path)
}
declare 169 {
int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr)
}
declare 170 {
int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 171 {
int Tcl_GetServiceMode(void)
}
declare 172 {
Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 {
CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp)
}
declare 175 {
CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags)
}
declare 176 {
CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 177 {
int Tcl_GlobalEval(Tcl_Interp *interp, const char *command)
}
declare 178 {
int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 179 {
int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName,
const char *hiddenCmdToken)
}
declare 180 {
int Tcl_Init(Tcl_Interp *interp)
}
declare 181 {
void Tcl_InitHashTable(Tcl_HashTable *tablePtr, int keyType)
}
declare 182 {
int Tcl_InputBlocked(Tcl_Channel chan)
}
declare 183 {
int Tcl_InputBuffered(Tcl_Channel chan)
}
declare 184 {
int Tcl_InterpDeleted(Tcl_Interp *interp)
}
declare 185 {
int Tcl_IsSafe(Tcl_Interp *interp)
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
char *Tcl_JoinPath(int argc, CONST84 char *const *argv,
Tcl_DString *resultPtr)
}
declare 187 {
int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, char *addr,
int type)
}
# This slot is reserved for use by the plus patch:
# declare 188 {
# Tcl_MainLoop
# }
declare 189 {
Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode)
}
declare 190 {
int Tcl_MakeSafe(Tcl_Interp *interp)
}
declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket)
}
declare 192 {
char *Tcl_Merge(int argc, CONST84 char *const *argv)
}
declare 193 {
Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr)
}
declare 194 {
void Tcl_NotifyChannel(Tcl_Channel channel, int mask)
}
declare 195 {
Tcl_Obj *Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags)
}
declare 196 {
Tcl_Obj *Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags)
}
declare 197 {
Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
CONST84 char **argv, int flags)
}
# This is obsolete, use Tcl_FSOpenFileChannel
declare 198 {
Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName,
const char *modeString, int permissions)
}
declare 199 {
Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port,
const char *address, const char *myaddr, int myport, int async)
}
declare 200 {
Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
const char *host, Tcl_TcpAcceptProc *acceptProc,
ClientData callbackData)
}
declare 201 {
void Tcl_Preserve(ClientData data)
}
declare 202 {
void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
}
declare 203 {
int Tcl_PutEnv(const char *assignment)
}
declare 204 {
CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 {
void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
}
declare 206 {
int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
}
declare 207 {
void Tcl_ReapDetachedProcs(void)
}
declare 208 {
int Tcl_RecordAndEval(Tcl_Interp *interp, const char *cmd, int flags)
}
declare 209 {
int Tcl_RecordAndEvalObj(Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags)
}
declare 210 {
void Tcl_RegisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 211 {
void Tcl_RegisterObjType(Tcl_ObjType *typePtr)
}
declare 212 {
Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, const char *pattern)
}
declare 213 {
int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp,
const char *text, const char *start)
}
declare 214 {
int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text,
const char *pattern)
}
declare 215 {
void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
CONST84 char **startPtr, CONST84 char **endPtr)
}
declare 216 {
void Tcl_Release(ClientData clientData)
}
declare 217 {
void Tcl_ResetResult(Tcl_Interp *interp)
}
declare 218 {
int Tcl_ScanElement(const char *src, int *flagPtr)
}
declare 219 {
int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr)
}
# Obsolete
declare 220 {
int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode)
}
declare 221 {
int Tcl_ServiceAll(void)
}
declare 222 {
int Tcl_ServiceEvent(int flags)
}
declare 223 {
void Tcl_SetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc *proc, ClientData clientData)
}
declare 224 {
void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz)
}
declare 225 {
int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
const char *optionName, const char *newValue)
}
declare 226 {
int Tcl_SetCommandInfo(Tcl_Interp *interp, const char *cmdName,
const Tcl_CmdInfo *infoPtr)
}
declare 227 {
void Tcl_SetErrno(int err)
}
declare 228 {
void Tcl_SetErrorCode(Tcl_Interp *interp, ...)
}
declare 229 {
void Tcl_SetMaxBlockTime(Tcl_Time *timePtr)
}
declare 230 {
void Tcl_SetPanicProc(Tcl_PanicProc *panicProc)
}
declare 231 {
int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth)
}
declare 232 {
void Tcl_SetResult(Tcl_Interp *interp, char *result,
Tcl_FreeProc *freeProc)
}
declare 233 {
int Tcl_SetServiceMode(int mode)
}
declare 234 {
void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr)
}
declare 235 {
void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr)
}
declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
declare 237 {
CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags)
}
declare 238 {
CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, const char *newValue, int flags)
}
declare 239 {
CONST84_RETURN char *Tcl_SignalId(int sig)
}
declare 240 {
CONST84_RETURN char *Tcl_SignalMsg(int sig)
}
declare 241 {
void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 {
int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
CONST84 char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr)
}
declare 244 {
void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName,
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
}
declare 245 {
int Tcl_StringMatch(const char *str, const char *pattern)
}
# Obsolete
declare 246 {
int Tcl_TellOld(Tcl_Channel chan)
}
declare 247 {
int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 248 {
int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 249 {
char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name,
Tcl_DString *bufferPtr)
}
declare 250 {
int Tcl_Ungets(Tcl_Channel chan, const char *str, int len, int atHead)
}
declare 251 {
void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName)
}
declare 252 {
int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 253 {
int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags)
}
declare 254 {
int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
declare 255 {
void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 256 {
void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *proc,
ClientData clientData)
}
declare 257 {
void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName)
}
declare 258 {
int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
const char *varName, const char *localName, int flags)
}
declare 259 {
int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1,
const char *part2, const char *localName, int flags)
}
declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
declare 261 {
ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
}
declare 262 {
ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *procPtr,
ClientData prevClientData)
}
declare 263 {
int Tcl_Write(Tcl_Channel chan, const char *s, int slen)
}
declare 264 {
void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], const char *message)
}
declare 265 {
int Tcl_DumpActiveMemory(const char *fileName)
}
declare 266 {
void Tcl_ValidateAllMemory(const char *file, int line)
}
declare 267 {
void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
declare 268 {
void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 {
CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
CONST84 char **termPtr)
}
declare 271 {
CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
declare 272 {
CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
ClientData *clientDataPtr)
}
declare 273 {
int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
const char *version)
}
# TIP #268: The internally used new Require function is in slot 573.
declare 274 {
CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
declare 275 {
void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
}
declare 276 {
int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList)
}
declare 277 {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
declare 278 {
void Tcl_PanicVA(const char *format, va_list argList)
}
declare 279 {
void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type)
}
declare 280 {
void Tcl_InitMemory(Tcl_Interp *interp)
}
# Andreas Kupries , 03/21/1999
# "Trf-Patch for filtering channels"
#
# C-Level API for (un)stacking of channels. This allows the introduction
# of filtering channels with relatively little changes to the core.
# This patch was created in cooperation with Jan Nijtmans j.nijtmans@chello.nl
# and is therefore part of his plus-patches too.
#
# It would have been possible to place the following definitions according
# to the alphabetical order used elsewhere in this file, but I decided
# against that to ease the maintenance of the patch across new tcl versions
# (patch usually has no problems to integrate the patch file for the last
# version into the new one).
declare 281 {
Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
Tcl_ChannelType *typePtr, ClientData instanceData,
int mask, Tcl_Channel prevChan)
}
declare 282 {
int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 283 {
Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan)
}
# 284 was reserved, but added in 8.4a2
declare 284 {
void Tcl_SetMainLoop(Tcl_MainLoopProc *proc)
}
# Reserved for future use (8.0.x vs. 8.1)
# declare 285 {
# }
# Added in 8.1:
declare 286 {
void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr)
}
declare 287 {
Tcl_Encoding Tcl_CreateEncoding(Tcl_EncodingType *typePtr)
}
declare 288 {
void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 289 {
void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 290 {
void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
}
declare 291 {
int Tcl_EvalEx(Tcl_Interp *interp, const char *script, int numBytes,
int flags)
}
declare 292 {
int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
declare 293 {
int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
declare 294 {
void Tcl_ExitThread(int status)
}
declare 295 {
int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 296 {
char *Tcl_ExternalToUtfDString(Tcl_Encoding encoding,
const char *src, int srcLen, Tcl_DString *dsPtr)
}
declare 297 {
void Tcl_FinalizeThread(void)
}
declare 298 {
void Tcl_FinalizeNotifier(ClientData clientData)
}
declare 299 {
void Tcl_FreeEncoding(Tcl_Encoding encoding)
}
declare 300 {
Tcl_ThreadId Tcl_GetCurrentThread(void)
}
declare 301 {
Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name)
}
declare 302 {
CONST84_RETURN char *Tcl_GetEncodingName(Tcl_Encoding encoding)
}
declare 303 {
void Tcl_GetEncodingNames(Tcl_Interp *interp)
}
declare 304 {
int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr,
const void *tablePtr, int offset, const char *msg, int flags,
int *indexPtr)
}
declare 305 {
void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size)
}
declare 306 {
Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 307 {
ClientData Tcl_InitNotifier(void)
}
declare 308 {
void Tcl_MutexLock(Tcl_Mutex *mutexPtr)
}
declare 309 {
void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr)
}
declare 310 {
void Tcl_ConditionNotify(Tcl_Condition *condPtr)
}
declare 311 {
void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr,
Tcl_Time *timePtr)
}
declare 312 {
int Tcl_NumUtfChars(const char *src, int length)
}
declare 313 {
int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead,
int appendFlag)
}
declare 314 {
void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
declare 315 {
void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
declare 316 {
int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name)
}
declare 317 {
Tcl_Obj *Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, Tcl_Obj *newValuePtr, int flags)
}
declare 318 {
void Tcl_ThreadAlert(Tcl_ThreadId threadId)
}
declare 319 {
void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr,
Tcl_QueuePosition position)
}
declare 320 {
Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index)
}
declare 321 {
Tcl_UniChar Tcl_UniCharToLower(int ch)
}
declare 322 {
Tcl_UniChar Tcl_UniCharToTitle(int ch)
}
declare 323 {
Tcl_UniChar Tcl_UniCharToUpper(int ch)
}
declare 324 {
int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 {
CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index)
}
declare 326 {
int Tcl_UtfCharComplete(const char *src, int length)
}
declare 327 {
int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst)
}
declare 328 {
CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch)
}
declare 329 {
CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch)
}
declare 330 {
CONST84_RETURN char *Tcl_UtfNext(const char *src)
}
declare 331 {
CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start)
}
declare 332 {
int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 333 {
char *Tcl_UtfToExternalDString(Tcl_Encoding encoding,
const char *src, int srcLen, Tcl_DString *dsPtr)
}
declare 334 {
int Tcl_UtfToLower(char *src)
}
declare 335 {
int Tcl_UtfToTitle(char *src)
}
declare 336 {
int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr)
}
declare 337 {
int Tcl_UtfToUpper(char *src)
}
declare 338 {
int Tcl_WriteChars(Tcl_Channel chan, const char *src, int srcLen)
}
declare 339 {
int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
declare 341 {
CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void)
}
declare 342 {
void Tcl_SetDefaultEncodingDir(const char *path)
}
declare 343 {
void Tcl_AlertNotifier(ClientData clientData)
}
declare 344 {
void Tcl_ServiceModeHook(int mode)
}
declare 345 {
int Tcl_UniCharIsAlnum(int ch)
}
declare 346 {
int Tcl_UniCharIsAlpha(int ch)
}
declare 347 {
int Tcl_UniCharIsDigit(int ch)
}
declare 348 {
int Tcl_UniCharIsLower(int ch)
}
declare 349 {
int Tcl_UniCharIsSpace(int ch)
}
declare 350 {
int Tcl_UniCharIsUpper(int ch)
}
declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
declare 352 {
int Tcl_UniCharLen(const Tcl_UniChar *uniStr)
}
declare 353 {
int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
unsigned long numChars)
}
declare 354 {
char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr,
int uniLength, Tcl_DString *dsPtr)
}
declare 355 {
Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src,
int length, Tcl_DString *dsPtr)
}
declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
declare 357 {
Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count)
}
declare 358 {
void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 {
void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script,
const char *command, int length)
}
declare 360 {
int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes,
Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)
}
declare 361 {
int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes,
int nested, Tcl_Parse *parsePtr)
}
declare 362 {
int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, int numBytes,
Tcl_Parse *parsePtr)
}
declare 363 {
int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start,
int numBytes, Tcl_Parse *parsePtr, int append,
CONST84 char **termPtr)
}
declare 364 {
int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes,
Tcl_Parse *parsePtr, int append)
}
# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
# Tcl_FSAccess and Tcl_FSStat
declare 365 {
char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 366 {
int Tcl_Chdir(const char *dirName)
}
declare 367 {
int Tcl_Access(const char *path, int mode)
}
declare 368 {
int Tcl_Stat(const char *path, struct stat *bufPtr)
}
declare 369 {
int Tcl_UtfNcmp(const char *s1, const char *s2, unsigned long n)
}
declare 370 {
int Tcl_UtfNcasecmp(const char *s1, const char *s2, unsigned long n)
}
declare 371 {
int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase)
}
declare 372 {
int Tcl_UniCharIsControl(int ch)
}
declare 373 {
int Tcl_UniCharIsGraph(int ch)
}
declare 374 {
int Tcl_UniCharIsPrint(int ch)
}
declare 375 {
int Tcl_UniCharIsPunct(int ch)
}
declare 376 {
int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp,
Tcl_Obj *textObj, int offset, int nmatches, int flags)
}
declare 377 {
void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr)
}
declare 378 {
Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars)
}
declare 379 {
void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
int numChars)
}
declare 380 {
int Tcl_GetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
}
declare 382 {
Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
}
declare 383 {
Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last)
}
declare 384 {
void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
int length)
}
declare 385 {
int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj,
Tcl_Obj *patternObj)
}
declare 386 {
void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr)
}
declare 387 {
Tcl_Mutex *Tcl_GetAllocMutex(void)
}
declare 388 {
int Tcl_GetChannelNames(Tcl_Interp *interp)
}
declare 389 {
int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern)
}
declare 390 {
int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 391 {
void Tcl_ConditionFinalize(Tcl_Condition *condPtr)
}
declare 392 {
void Tcl_MutexFinalize(Tcl_Mutex *mutex)
}
declare 393 {
int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc,
ClientData clientData, int stackSize, int flags)
}
# Introduced in 8.3.2
declare 394 {
int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead)
}
declare 395 {
int Tcl_WriteRaw(Tcl_Channel chan, const char *src, int srcLen)
}
declare 396 {
Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan)
}
declare 397 {
int Tcl_ChannelBuffered(Tcl_Channel chan)
}
declare 398 {
CONST84_RETURN char *Tcl_ChannelName(Tcl_ChannelType *chanTypePtr)
}
declare 399 {
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
Tcl_ChannelType *chanTypePtr)
}
declare 400 {
Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc(
Tcl_ChannelType *chanTypePtr)
}
declare 401 {
Tcl_DriverCloseProc *Tcl_ChannelCloseProc(
Tcl_ChannelType *chanTypePtr)
}
declare 402 {
Tcl_DriverClose2Proc *Tcl_ChannelClose2Proc(
Tcl_ChannelType *chanTypePtr)
}
declare 403 {
Tcl_DriverInputProc *Tcl_ChannelInputProc(
Tcl_ChannelType *chanTypePtr)
}
declare 404 {
Tcl_DriverOutputProc *Tcl_ChannelOutputProc(
Tcl_ChannelType *chanTypePtr)
}
declare 405 {
Tcl_DriverSeekProc *Tcl_ChannelSeekProc(
Tcl_ChannelType *chanTypePtr)
}
declare 406 {
Tcl_DriverSetOptionProc *Tcl_ChannelSetOptionProc(
Tcl_ChannelType *chanTypePtr)
}
declare 407 {
Tcl_DriverGetOptionProc *Tcl_ChannelGetOptionProc(
Tcl_ChannelType *chanTypePtr)
}
declare 408 {
Tcl_DriverWatchProc *Tcl_ChannelWatchProc(
Tcl_ChannelType *chanTypePtr)
}
declare 409 {
Tcl_DriverGetHandleProc *Tcl_ChannelGetHandleProc(
Tcl_ChannelType *chanTypePtr)
}
declare 410 {
Tcl_DriverFlushProc *Tcl_ChannelFlushProc(
Tcl_ChannelType *chanTypePtr)
}
declare 411 {
Tcl_DriverHandlerProc *Tcl_ChannelHandlerProc(
Tcl_ChannelType *chanTypePtr)
}
# Introduced in 8.4a2
declare 412 {
int Tcl_JoinThread(Tcl_ThreadId threadId, int *result)
}
declare 413 {
int Tcl_IsChannelShared(Tcl_Channel channel)
}
declare 414 {
int Tcl_IsChannelRegistered(Tcl_Interp *interp, Tcl_Channel channel)
}
declare 415 {
void Tcl_CutChannel(Tcl_Channel channel)
}
declare 416 {
void Tcl_SpliceChannel(Tcl_Channel channel)
}
declare 417 {
void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
declare 419 {
int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
unsigned long numChars)
}
declare 420 {
int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
const Tcl_UniChar *uniPattern, int nocase)
}
declare 421 {
Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const char *key)
}
declare 422 {
Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr,
const char *key, int *newPtr)
}
declare 423 {
void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType,
Tcl_HashKeyType *typePtr)
}
declare 424 {
void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr)
}
declare 425 {
ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *procPtr,
ClientData prevClientData)
}
declare 426 {
int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags,
Tcl_CommandTraceProc *proc, ClientData clientData)
}
declare 427 {
void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *proc, ClientData clientData)
}
declare 428 {
char *Tcl_AttemptAlloc(unsigned int size)
}
declare 429 {
char *Tcl_AttemptDbCkalloc(unsigned int size, const char *file, int line)
}
declare 430 {
char *Tcl_AttemptRealloc(char *ptr, unsigned int size)
}
declare 431 {
char *Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size,
const char *file, int line)
}
declare 432 {
int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length)
}
# TIP#10 (thread-aware channels) akupries
declare 433 {
Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel)
}
# introduced in 8.4a3
declare 434 {
Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
# TIP#15 (math function introspection) dkf
declare 435 {
int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name,
int *numArgsPtr, Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr, ClientData *clientDataPtr)
}
declare 436 {
Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern)
}
# TIP#36 (better access to 'subst') dkf
declare 437 {
Tcl_Obj *Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
# TIP#17 (virtual filesystem layer) vdarley
declare 438 {
int Tcl_DetachChannel(Tcl_Interp *interp, Tcl_Channel channel)
}
declare 439 {
int Tcl_IsStandardChannel(Tcl_Channel channel)
}
declare 440 {
int Tcl_FSCopyFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
}
declare 441 {
int Tcl_FSCopyDirectory(Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)
}
declare 442 {
int Tcl_FSCreateDirectory(Tcl_Obj *pathPtr)
}
declare 443 {
int Tcl_FSDeleteFile(Tcl_Obj *pathPtr)
}
declare 444 {
int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1,
const char *sym2, Tcl_PackageInitProc **proc1Ptr,
Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr)
}
declare 445 {
int Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *result,
Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types)
}
declare 446 {
Tcl_Obj *Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction)
}
declare 447 {
int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr,
int recursive, Tcl_Obj **errorPtr)
}
declare 448 {
int Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
}
declare 449 {
int Tcl_FSLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf)
}
declare 450 {
int Tcl_FSUtime(Tcl_Obj *pathPtr, struct utimbuf *tval)
}
declare 451 {
int Tcl_FSFileAttrsGet(Tcl_Interp *interp,
int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)
}
declare 452 {
int Tcl_FSFileAttrsSet(Tcl_Interp *interp,
int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr)
}
declare 453 {
const char **Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef)
}
declare 454 {
int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf)
}
declare 455 {
int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode)
}
declare 456 {
Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr,
const char *modeString, int permissions)
}
declare 457 {
Tcl_Obj *Tcl_FSGetCwd(Tcl_Interp *interp)
}
declare 458 {
int Tcl_FSChdir(Tcl_Obj *pathPtr)
}
declare 459 {
int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 460 {
Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, int elements)
}
declare 461 {
Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr)
}
declare 462 {
int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, Tcl_Obj *secondPtr)
}
declare 463 {
Tcl_Obj *Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 464 {
Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
Tcl_Obj *const objv[])
}
declare 465 {
ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
Tcl_Filesystem *fsPtr)
}
declare 466 {
Tcl_Obj *Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 467 {
int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName)
}
declare 468 {
Tcl_Obj *Tcl_FSNewNativePath(Tcl_Filesystem *fromFilesystem,
ClientData clientData)
}
declare 469 {
const char *Tcl_FSGetNativePath(Tcl_Obj *pathPtr)
}
declare 470 {
Tcl_Obj *Tcl_FSFileSystemInfo(Tcl_Obj *pathPtr)
}
declare 471 {
Tcl_Obj *Tcl_FSPathSeparator(Tcl_Obj *pathPtr)
}
declare 472 {
Tcl_Obj *Tcl_FSListVolumes(void)
}
declare 473 {
int Tcl_FSRegister(ClientData clientData, Tcl_Filesystem *fsPtr)
}
declare 474 {
int Tcl_FSUnregister(Tcl_Filesystem *fsPtr)
}
declare 475 {
ClientData Tcl_FSData(Tcl_Filesystem *fsPtr)
}
declare 476 {
const char *Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp,
Tcl_Obj *pathPtr)
}
declare 477 {
Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr)
}
declare 478 {
Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr)
}
# TIP#49 (detection of output buffering) akupries
declare 479 {
int Tcl_OutputBuffered(Tcl_Channel chan)
}
declare 480 {
void Tcl_FSMountsChanged(Tcl_Filesystem *fsPtr)
}
# TIP#56 (evaluate a parsed script) msofer
declare 481 {
int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count)
}
# TIP#73 (access to current time) kbk
declare 482 {
void Tcl_GetTime(Tcl_Time *timeBuf)
}
# TIP#32 (object-enabled traces) kbk
declare 483 {
Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags,
Tcl_CmdObjTraceProc *objProc, ClientData clientData,
Tcl_CmdObjTraceDeleteProc *delProc)
}
declare 484 {
int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr)
}
declare 485 {
int Tcl_SetCommandInfoFromToken(Tcl_Command token,
const Tcl_CmdInfo *infoPtr)
}
### New functions on 64-bit dev branch ###
# TIP#72 (64-bit values) dkf
declare 486 {
Tcl_Obj *Tcl_DbNewWideIntObj(Tcl_WideInt wideValue,
const char *file, int line)
}
declare 487 {
int Tcl_GetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_WideInt *widePtr)
}
declare 488 {
Tcl_Obj *Tcl_NewWideIntObj(Tcl_WideInt wideValue)
}
declare 489 {
void Tcl_SetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt wideValue)
}
declare 490 {
Tcl_StatBuf *Tcl_AllocStatBuf(void)
}
declare 491 {
Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset, int mode)
}
declare 492 {
Tcl_WideInt Tcl_Tell(Tcl_Channel chan)
}
# TIP#91 (back-compat enhancements for channels) dkf
declare 493 {
Tcl_DriverWideSeekProc *Tcl_ChannelWideSeekProc(
Tcl_ChannelType *chanTypePtr)
}
# Slots 494 to 553 are taken already by 8.5
# #111 - Dicts (494 ... 504)
# #59 - Config (505)
# #139 - Namespace API (506 ... 517)
# #137 - source -encoding (518)
# #121 - ExitProc (519)
# #121 - Resource Limits (520 ... 534)
# #226 - S/R Interp State (535 ... 537)
# #227 - S/G Return Opts (538 ... 539)
# #235 - Ensemble C API (540 ... 551)
# #233 - Virtualized Time (552 ... 553)
# TIP#218 (driver thread actions) davygrvy/akupries ChannelType ver 4
declare 554 {
Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(
Tcl_ChannelType *chanTypePtr)
}
# Slots 555 to 572 are taken already by 8.5
# TIP #237: Arbitrary-prec Integers (555 ... 559)
# TIP #208: 'chan' Command (560 ... 561)
# TIP #219: Channel Reflection (562 ... 565)
# TIP #237: Add. bignum support (566)
# TIP #181: 'namespace unknown' Cmd (567 ... 568)
# TIP #258: Enhanced Encodings API (569 ... 572)
# TIP#268 (extended version numbers and requirements) akupries
declare 573 {
int Tcl_PkgRequireProc(Tcl_Interp *interp, const char *name,
int objc, Tcl_Obj *const objv[], ClientData *clientDataPtr)
}
declare 630 {
void TclUnusedStubEntry(void)
}
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
interface tclPlat
################################
# Unix specific functions
# (none)
################################
# Windows specific functions
# Added in Tcl 8.1
declare 0 win {
TCHAR *Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr)
}
declare 1 win {
char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr)
}
################################
# Mac OS X specific functions
declare 0 macosx {
int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
int maxPathLen, char *libraryPath)
}
declare 1 macosx {
int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp,
const char *bundleName, const char *bundleVersion,
int hasResourceFile, int maxPathLen, char *libraryPath)
}
# Local Variables:
# mode: tcl
# End:
tcl8.4.20/generic/regc_nfa.c 0000644 0036047 0045461 00000125271 12133546537 014252 0 ustar dgp 771div /*
* NFA utilities.
* This file is #included by regcomp.c.
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*
*
* One or two things that technically ought to be in here
* are actually in color.c, thanks to some incestuous relationships in
* the color chains.
*/
#define NISERR() VISERR(nfa->v)
#define NERR(e) VERR(nfa->v, (e))
/*
- newnfa - set up an NFA
^ static struct nfa *newnfa(struct vars *, struct colormap *, struct nfa *);
*/
static struct nfa * /* the NFA, or NULL */
newnfa(v, cm, parent)
struct vars *v;
struct colormap *cm;
struct nfa *parent; /* NULL if primary NFA */
{
struct nfa *nfa;
nfa = (struct nfa *)MALLOC(sizeof(struct nfa));
if (nfa == NULL)
return NULL;
nfa->states = NULL;
nfa->slast = NULL;
nfa->free = NULL;
nfa->nstates = 0;
nfa->cm = cm;
nfa->v = v;
nfa->size = 0;
nfa->bos[0] = nfa->bos[1] = COLORLESS;
nfa->eos[0] = nfa->eos[1] = COLORLESS;
nfa->parent = parent;
nfa->post = newfstate(nfa, '@'); /* number 0 */
nfa->pre = newfstate(nfa, '>'); /* number 1 */
nfa->init = newstate(nfa); /* may become invalid later */
nfa->final = newstate(nfa);
if (ISERR()) {
freenfa(nfa);
return NULL;
}
rainbow(nfa, nfa->cm, PLAIN, COLORLESS, nfa->pre, nfa->init);
newarc(nfa, '^', 1, nfa->pre, nfa->init);
newarc(nfa, '^', 0, nfa->pre, nfa->init);
rainbow(nfa, nfa->cm, PLAIN, COLORLESS, nfa->final, nfa->post);
newarc(nfa, '$', 1, nfa->final, nfa->post);
newarc(nfa, '$', 0, nfa->final, nfa->post);
if (ISERR()) {
freenfa(nfa);
return NULL;
}
return nfa;
}
/*
- too_many_states - checks if the max states exceeds the compile-time value
^ static int too_many_states(struct nfa *);
*/
static int
too_many_states(nfa)
struct nfa *nfa;
{
struct nfa *parent = nfa->parent;
size_t sz = nfa->size;
while (parent != NULL) {
sz = parent->size;
parent = parent->parent;
}
if (sz > REG_MAX_STATES)
return 1;
return 0;
}
/*
- increment_size - increases the tracked size of the NFA and its parents.
^ static void increment_size(struct nfa *);
*/
static void
increment_size(nfa)
struct nfa *nfa;
{
struct nfa *parent = nfa->parent;
nfa->size++;
while (parent != NULL) {
parent->size++;
parent = parent->parent;
}
}
/*
- decrement_size - increases the tracked size of the NFA and its parents.
^ static void decrement_size(struct nfa *);
*/
static void
decrement_size(nfa)
struct nfa *nfa;
{
struct nfa *parent = nfa->parent;
nfa->size--;
while (parent != NULL) {
parent->size--;
parent = parent->parent;
}
}
/*
- freenfa - free an entire NFA
^ static VOID freenfa(struct nfa *);
*/
static VOID
freenfa(nfa)
struct nfa *nfa;
{
struct state *s;
while ((s = nfa->states) != NULL) {
s->nins = s->nouts = 0; /* don't worry about arcs */
freestate(nfa, s);
}
while ((s = nfa->free) != NULL) {
nfa->free = s->next;
destroystate(nfa, s);
}
nfa->slast = NULL;
nfa->nstates = -1;
nfa->pre = NULL;
nfa->post = NULL;
FREE(nfa);
}
/*
- newstate - allocate an NFA state, with zero flag value
^ static struct state *newstate(struct nfa *);
*/
static struct state * /* NULL on error */
newstate(nfa)
struct nfa *nfa;
{
struct state *s;
if (too_many_states(nfa)) {
/* XXX: add specific error for this */
NERR(REG_ETOOBIG);
return NULL;
}
if (nfa->free != NULL) {
s = nfa->free;
nfa->free = s->next;
} else {
s = (struct state *)MALLOC(sizeof(struct state));
if (s == NULL) {
NERR(REG_ESPACE);
return NULL;
}
s->oas.next = NULL;
s->free = NULL;
s->noas = 0;
}
assert(nfa->nstates >= 0);
s->no = nfa->nstates++;
s->flag = 0;
if (nfa->states == NULL)
nfa->states = s;
s->nins = 0;
s->ins = NULL;
s->nouts = 0;
s->outs = NULL;
s->tmp = NULL;
s->next = NULL;
if (nfa->slast != NULL) {
assert(nfa->slast->next == NULL);
nfa->slast->next = s;
}
s->prev = nfa->slast;
nfa->slast = s;
/* Track the current size and the parent size */
increment_size(nfa);
return s;
}
/*
- newfstate - allocate an NFA state with a specified flag value
^ static struct state *newfstate(struct nfa *, int flag);
*/
static struct state * /* NULL on error */
newfstate(nfa, flag)
struct nfa *nfa;
int flag;
{
struct state *s;
s = newstate(nfa);
if (s != NULL)
s->flag = (char)flag;
return s;
}
/*
- dropstate - delete a state's inarcs and outarcs and free it
^ static VOID dropstate(struct nfa *, struct state *);
*/
static VOID
dropstate(nfa, s)
struct nfa *nfa;
struct state *s;
{
struct arc *a;
while ((a = s->ins) != NULL)
freearc(nfa, a);
while ((a = s->outs) != NULL)
freearc(nfa, a);
freestate(nfa, s);
}
/*
- freestate - free a state, which has no in-arcs or out-arcs
^ static VOID freestate(struct nfa *, struct state *);
*/
static VOID
freestate(nfa, s)
struct nfa *nfa;
struct state *s;
{
assert(s != NULL);
assert(s->nins == 0 && s->nouts == 0);
s->no = FREESTATE;
s->flag = 0;
if (s->next != NULL)
s->next->prev = s->prev;
else {
assert(s == nfa->slast);
nfa->slast = s->prev;
}
if (s->prev != NULL)
s->prev->next = s->next;
else {
assert(s == nfa->states);
nfa->states = s->next;
}
s->prev = NULL;
s->next = nfa->free; /* don't delete it, put it on the free list */
nfa->free = s;
decrement_size(nfa);
}
/*
- destroystate - really get rid of an already-freed state
^ static VOID destroystate(struct nfa *, struct state *);
*/
static VOID
destroystate(nfa, s)
struct nfa *nfa;
struct state *s;
{
struct arcbatch *ab;
struct arcbatch *abnext;
assert(s->no == FREESTATE);
for (ab = s->oas.next; ab != NULL; ab = abnext) {
abnext = ab->next;
FREE(ab);
}
s->ins = NULL;
s->outs = NULL;
s->next = NULL;
FREE(s);
}
/*
- newarc - set up a new arc within an NFA
^ static VOID newarc(struct nfa *, int, pcolor, struct state *,
^ struct state *);
*/
static VOID
newarc(nfa, t, co, from, to)
struct nfa *nfa;
int t;
pcolor co;
struct state *from;
struct state *to;
{
struct arc *a;
assert(from != NULL && to != NULL);
/* check for duplicates */
for (a = from->outs; a != NULL; a = a->outchain)
if (a->to == to && a->co == co && a->type == t)
return;
a = allocarc(nfa, from);
if (NISERR())
return;
assert(a != NULL);
a->type = t;
a->co = (color)co;
a->to = to;
a->from = from;
/*
* Put the new arc on the beginning, not the end, of the chains.
* Not only is this easier, it has the very useful side effect that
* deleting the most-recently-added arc is the cheapest case rather
* than the most expensive one.
*/
a->inchain = to->ins;
to->ins = a;
a->outchain = from->outs;
from->outs = a;
from->nouts++;
to->nins++;
if (COLORED(a) && nfa->parent == NULL)
colorchain(nfa->cm, a);
return;
}
/*
- allocarc - allocate a new out-arc within a state
^ static struct arc *allocarc(struct nfa *, struct state *);
*/
static struct arc * /* NULL for failure */
allocarc(nfa, s)
struct nfa *nfa;
struct state *s;
{
struct arc *a;
struct arcbatch *new;
int i;
/* shortcut */
if (s->free == NULL && s->noas < ABSIZE) {
a = &s->oas.a[s->noas];
s->noas++;
return a;
}
/* if none at hand, get more */
if (s->free == NULL) {
new = (struct arcbatch *)MALLOC(sizeof(struct arcbatch));
if (new == NULL) {
NERR(REG_ESPACE);
return NULL;
}
new->next = s->oas.next;
s->oas.next = new;
for (i = 0; i < ABSIZE; i++) {
new->a[i].type = 0;
new->a[i].freechain = &new->a[i+1];
}
new->a[ABSIZE-1].freechain = NULL;
s->free = &new->a[0];
}
assert(s->free != NULL);
a = s->free;
s->free = a->freechain;
return a;
}
/*
- freearc - free an arc
^ static VOID freearc(struct nfa *, struct arc *);
*/
static VOID
freearc(nfa, victim)
struct nfa *nfa;
struct arc *victim;
{
struct state *from = victim->from;
struct state *to = victim->to;
struct arc *a;
assert(victim->type != 0);
/* take it off color chain if necessary */
if (COLORED(victim) && nfa->parent == NULL)
uncolorchain(nfa->cm, victim);
/* take it off source's out-chain */
assert(from != NULL);
assert(from->outs != NULL);
a = from->outs;
if (a == victim) /* simple case: first in chain */
from->outs = victim->outchain;
else {
for (; a != NULL && a->outchain != victim; a = a->outchain)
continue;
assert(a != NULL);
a->outchain = victim->outchain;
}
from->nouts--;
/* take it off target's in-chain */
assert(to != NULL);
assert(to->ins != NULL);
a = to->ins;
if (a == victim) /* simple case: first in chain */
to->ins = victim->inchain;
else {
for (; a != NULL && a->inchain != victim; a = a->inchain)
continue;
assert(a != NULL);
a->inchain = victim->inchain;
}
to->nins--;
/* clean up and place on free list */
victim->type = 0;
victim->from = NULL; /* precautions... */
victim->to = NULL;
victim->inchain = NULL;
victim->outchain = NULL;
victim->freechain = from->free;
from->free = victim;
}
/*
- hasnonemptyout - Does state have a non-EMPTY out arc?
^ static int hasnonemptyout(struct state *);
*/
static int
hasnonemptyout(s)
struct state *s;
{
struct arc *a;
for (a = s->outs; a != NULL; a = a->outchain)
if (a->type != EMPTY)
return 1;
return 0;
}
/*
- nonemptyouts - count non-EMPTY out arcs of a state
^ static int nonemptyouts(struct state *);
*/
static int
nonemptyouts(s)
struct state *s;
{
int n = 0;
struct arc *a;
for (a = s->outs; a != NULL; a = a->outchain)
if (a->type != EMPTY)
n++;
return n;
}
/*
- nonemptyins - count non-EMPTY in arcs of a state
^ static int nonemptyins(struct state *);
*/
static int
nonemptyins(s)
struct state *s;
{
int n = 0;
struct arc *a;
for (a = s->ins; a != NULL; a = a->inchain)
if (a->type != EMPTY)
n++;
return n;
}
/*
- findarc - find arc, if any, from given source with given type and color
* If there is more than one such arc, the result is random.
^ static struct arc *findarc(struct state *, int, pcolor);
*/
static struct arc *
findarc(s, type, co)
struct state *s;
int type;
pcolor co;
{
struct arc *a;
for (a = s->outs; a != NULL; a = a->outchain)
if (a->type == type && a->co == co)
return a;
return NULL;
}
/*
- cparc - allocate a new arc within an NFA, copying details from old one
^ static VOID cparc(struct nfa *, struct arc *, struct state *,
^ struct state *);
*/
static VOID
cparc(nfa, oa, from, to)
struct nfa *nfa;
struct arc *oa;
struct state *from;
struct state *to;
{
newarc(nfa, oa->type, oa->co, from, to);
}
/*
- moveins - move all in arcs of a state to another state
* You might think this could be done better by just updating the
* existing arcs, and you would be right if it weren't for the desire
* for duplicate suppression, which makes it easier to just make new
* ones to exploit the suppression built into newarc.
^ static VOID moveins(struct nfa *, struct state *, struct state *);
*/
static VOID
moveins(nfa, old, new)
struct nfa *nfa;
struct state *old;
struct state *new;
{
struct arc *a;
assert(old != new);
while ((a = old->ins) != NULL) {
cparc(nfa, a, a->from, new);
freearc(nfa, a);
}
assert(old->nins == 0);
assert(old->ins == NULL);
}
/*
- copyins - copy in arcs of a state to another state
* Either all arcs, or only non-empty ones as determined by all value.
^ static VOID copyins(struct nfa *, struct state *, struct state *, int);
*/
static VOID
copyins(nfa, old, new, all)
struct nfa *nfa;
struct state *old;
struct state *new;
int all;
{
struct arc *a;
assert(old != new);
for (a = old->ins; a != NULL; a = a->inchain)
if (all || a->type != EMPTY)
cparc(nfa, a, a->from, new);
}
/*
- moveouts - move all out arcs of a state to another state
^ static VOID moveouts(struct nfa *, struct state *, struct state *);
*/
static VOID
moveouts(nfa, old, new)
struct nfa *nfa;
struct state *old;
struct state *new;
{
struct arc *a;
assert(old != new);
while ((a = old->outs) != NULL) {
cparc(nfa, a, new, a->to);
freearc(nfa, a);
}
}
/*
- copyouts - copy out arcs of a state to another state
* Either all arcs, or only non-empty ones as determined by all value.
^ static VOID copyouts(struct nfa *, struct state *, struct state *, int);
*/
static VOID
copyouts(nfa, old, new, all)
struct nfa *nfa;
struct state *old;
struct state *new;
int all;
{
struct arc *a;
assert(old != new);
for (a = old->outs; a != NULL; a = a->outchain)
if (all || a->type != EMPTY)
cparc(nfa, a, new, a->to);
}
/*
- cloneouts - copy out arcs of a state to another state pair, modifying type
^ static VOID cloneouts(struct nfa *, struct state *, struct state *,
^ struct state *, int);
*/
static VOID
cloneouts(nfa, old, from, to, type)
struct nfa *nfa;
struct state *old;
struct state *from;
struct state *to;
int type;
{
struct arc *a;
assert(old != from);
for (a = old->outs; a != NULL; a = a->outchain)
newarc(nfa, type, a->co, from, to);
}
/*
- delsub - delete a sub-NFA, updating subre pointers if necessary
* This uses a recursive traversal of the sub-NFA, marking already-seen
* states using their tmp pointer.
^ static VOID delsub(struct nfa *, struct state *, struct state *);
*/
static VOID
delsub(nfa, lp, rp)
struct nfa *nfa;
struct state *lp; /* the sub-NFA goes from here... */
struct state *rp; /* ...to here, *not* inclusive */
{
assert(lp != rp);
rp->tmp = rp; /* mark end */
deltraverse(nfa, lp, lp);
assert(lp->nouts == 0 && rp->nins == 0); /* did the job */
assert(lp->no != FREESTATE && rp->no != FREESTATE); /* no more */
rp->tmp = NULL; /* unmark end */
lp->tmp = NULL; /* and begin, marked by deltraverse */
}
/*
- deltraverse - the recursive heart of delsub
* This routine's basic job is to destroy all out-arcs of the state.
^ static VOID deltraverse(struct nfa *, struct state *, struct state *);
*/
static VOID
deltraverse(nfa, leftend, s)
struct nfa *nfa;
struct state *leftend;
struct state *s;
{
struct arc *a;
struct state *to;
if (s->nouts == 0)
return; /* nothing to do */
if (s->tmp != NULL)
return; /* already in progress */
s->tmp = s; /* mark as in progress */
while ((a = s->outs) != NULL) {
to = a->to;
deltraverse(nfa, leftend, to);
assert(to->nouts == 0 || to->tmp != NULL);
freearc(nfa, a);
if (to->nins == 0 && to->tmp == NULL) {
assert(to->nouts == 0);
freestate(nfa, to);
}
}
assert(s->no != FREESTATE); /* we're still here */
assert(s == leftend || s->nins != 0); /* and still reachable */
assert(s->nouts == 0); /* but have no outarcs */
s->tmp = NULL; /* we're done here */
}
/*
- dupnfa - duplicate sub-NFA
* Another recursive traversal, this time using tmp to point to duplicates
* as well as mark already-seen states. (You knew there was a reason why
* it's a state pointer, didn't you? :-))
^ static VOID dupnfa(struct nfa *, struct state *, struct state *,
^ struct state *, struct state *);
*/
static VOID
dupnfa(nfa, start, stop, from, to)
struct nfa *nfa;
struct state *start; /* duplicate of subNFA starting here */
struct state *stop; /* and stopping here */
struct state *from; /* stringing duplicate from here */
struct state *to; /* to here */
{
if (start == stop) {
newarc(nfa, EMPTY, 0, from, to);
return;
}
stop->tmp = to;
duptraverse(nfa, start, from);
/* done, except for clearing out the tmp pointers */
stop->tmp = NULL;
cleartraverse(nfa, start);
}
/*
- duptraverse - recursive heart of dupnfa
^ static VOID duptraverse(struct nfa *, struct state *, struct state *);
*/
static VOID
duptraverse(nfa, s, stmp)
struct nfa *nfa;
struct state *s;
struct state *stmp; /* s's duplicate, or NULL */
{
struct arc *a;
if (s->tmp != NULL)
return; /* already done */
s->tmp = (stmp == NULL) ? newstate(nfa) : stmp;
if (s->tmp == NULL) {
assert(NISERR());
return;
}
for (a = s->outs; a != NULL && !NISERR(); a = a->outchain) {
duptraverse(nfa, a->to, (struct state *)NULL);
if (NISERR())
break;
assert(a->to->tmp != NULL);
cparc(nfa, a, s->tmp, a->to->tmp);
}
}
/*
- cleartraverse - recursive cleanup for algorithms that leave tmp ptrs set
^ static VOID cleartraverse(struct nfa *, struct state *);
*/
static VOID
cleartraverse(nfa, s)
struct nfa *nfa;
struct state *s;
{
struct arc *a;
if (s->tmp == NULL)
return;
s->tmp = NULL;
for (a = s->outs; a != NULL; a = a->outchain)
cleartraverse(nfa, a->to);
}
/*
- specialcolors - fill in special colors for an NFA
^ static VOID specialcolors(struct nfa *);
*/
static VOID
specialcolors(nfa)
struct nfa *nfa;
{
/* false colors for BOS, BOL, EOS, EOL */
if (nfa->parent == NULL) {
nfa->bos[0] = pseudocolor(nfa->cm);
nfa->bos[1] = pseudocolor(nfa->cm);
nfa->eos[0] = pseudocolor(nfa->cm);
nfa->eos[1] = pseudocolor(nfa->cm);
} else {
assert(nfa->parent->bos[0] != COLORLESS);
nfa->bos[0] = nfa->parent->bos[0];
assert(nfa->parent->bos[1] != COLORLESS);
nfa->bos[1] = nfa->parent->bos[1];
assert(nfa->parent->eos[0] != COLORLESS);
nfa->eos[0] = nfa->parent->eos[0];
assert(nfa->parent->eos[1] != COLORLESS);
nfa->eos[1] = nfa->parent->eos[1];
}
}
/*
- optimize - optimize an NFA
^ static long optimize(struct nfa *, FILE *);
*/
static long /* re_info bits */
optimize(nfa, f)
struct nfa *nfa;
FILE *f; /* for debug output; NULL none */
{
int verbose = (f != NULL) ? 1 : 0;
if (verbose)
fprintf(f, "\ninitial cleanup:\n");
cleanup(nfa); /* may simplify situation */
if (verbose)
dumpnfa(nfa, f);
if (verbose)
fprintf(f, "\nempties:\n");
fixempties(nfa, f); /* get rid of EMPTY arcs */
if (verbose)
fprintf(f, "\nconstraints:\n");
pullback(nfa, f); /* pull back constraints backward */
pushfwd(nfa, f); /* push fwd constraints forward */
if (verbose)
fprintf(f, "\nfinal cleanup:\n");
cleanup(nfa); /* final tidying */
return analyze(nfa); /* and analysis */
}
/*
- pullback - pull back constraints backward to (with luck) eliminate them
^ static VOID pullback(struct nfa *, FILE *);
*/
static VOID
pullback(nfa, f)
struct nfa *nfa;
FILE *f; /* for debug output; NULL none */
{
struct state *s;
struct state *nexts;
struct arc *a;
struct arc *nexta;
int progress;
/* find and pull until there are no more */
do {
progress = 0;
for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
nexts = s->next;
for (a = s->outs; a != NULL && !NISERR(); a = nexta) {
nexta = a->outchain;
if (a->type == '^' || a->type == BEHIND)
if (pull(nfa, a))
progress = 1;
assert(nexta == NULL || s->no != FREESTATE);
}
}
if (progress && f != NULL)
dumpnfa(nfa, f);
} while (progress && !NISERR());
if (NISERR())
return;
for (a = nfa->pre->outs; a != NULL; a = nexta) {
nexta = a->outchain;
if (a->type == '^') {
assert(a->co == 0 || a->co == 1);
newarc(nfa, PLAIN, nfa->bos[a->co], a->from, a->to);
freearc(nfa, a);
}
}
}
/*
- pull - pull a back constraint backward past its source state
* A significant property of this function is that it deletes at most
* one state -- the constraint's from state -- and only if the constraint
* was that state's last outarc.
^ static int pull(struct nfa *, struct arc *);
*/
static int /* 0 couldn't, 1 could */
pull(nfa, con)
struct nfa *nfa;
struct arc *con;
{
struct state *from = con->from;
struct state *to = con->to;
struct arc *a;
struct arc *nexta;
struct state *s;
if (from == to) { /* circular constraint is pointless */
freearc(nfa, con);
return 1;
}
if (from->flag) /* can't pull back beyond start */
return 0;
if (from->nins == 0) { /* unreachable */
freearc(nfa, con);
return 1;
}
/*
* DGP 2007-11-15: Cloning a state with a circular constraint on its
* list of outs can lead to trouble [Bug 1810038], so get rid of them
* first.
*/
for (a = from->outs; a != NULL; a = nexta) {
nexta = a->outchain;
switch (a->type) {
case '^':
case '$':
case BEHIND:
case AHEAD:
if (from == a->to) {
freearc(nfa, a);
}
break;
}
}
/* first, clone from state if necessary to avoid other outarcs */
if (from->nouts > 1) {
s = newstate(nfa);
if (NISERR())
return 0;
assert(to != from); /* con is not an inarc */
copyins(nfa, from, s, 1); /* duplicate inarcs */
cparc(nfa, con, s, to); /* move constraint arc */
freearc(nfa, con);
from = s;
con = from->outs;
}
assert(from->nouts == 1);
/* propagate the constraint into the from state's inarcs */
for (a = from->ins; a != NULL; a = nexta) {
nexta = a->inchain;
switch (combine(con, a)) {
case INCOMPATIBLE: /* destroy the arc */
freearc(nfa, a);
break;
case SATISFIED: /* no action needed */
break;
case COMPATIBLE: /* swap the two arcs, more or less */
s = newstate(nfa);
if (NISERR())
return 0;
cparc(nfa, a, s, to); /* anticipate move */
cparc(nfa, con, a->from, s);
if (NISERR())
return 0;
freearc(nfa, a);
break;
default:
assert(NOTREACHED);
break;
}
}
/* remaining inarcs, if any, incorporate the constraint */
moveins(nfa, from, to);
dropstate(nfa, from); /* will free the constraint */
return 1;
}
/*
- pushfwd - push forward constraints forward to (with luck) eliminate them
^ static VOID pushfwd(struct nfa *, FILE *);
*/
static VOID
pushfwd(nfa, f)
struct nfa *nfa;
FILE *f; /* for debug output; NULL none */
{
struct state *s;
struct state *nexts;
struct arc *a;
struct arc *nexta;
int progress;
/* find and push until there are no more */
do {
progress = 0;
for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
nexts = s->next;
for (a = s->ins; a != NULL && !NISERR(); a = nexta) {
nexta = a->inchain;
if (a->type == '$' || a->type == AHEAD)
if (push(nfa, a))
progress = 1;
assert(nexta == NULL || s->no != FREESTATE);
}
}
if (progress && f != NULL)
dumpnfa(nfa, f);
} while (progress && !NISERR());
if (NISERR())
return;
for (a = nfa->post->ins; a != NULL; a = nexta) {
nexta = a->inchain;
if (a->type == '$') {
assert(a->co == 0 || a->co == 1);
newarc(nfa, PLAIN, nfa->eos[a->co], a->from, a->to);
freearc(nfa, a);
}
}
}
/*
- push - push a forward constraint forward past its destination state
* A significant property of this function is that it deletes at most
* one state -- the constraint's to state -- and only if the constraint
* was that state's last inarc.
^ static int push(struct nfa *, struct arc *);
*/
static int /* 0 couldn't, 1 could */
push(nfa, con)
struct nfa *nfa;
struct arc *con;
{
struct state *from = con->from;
struct state *to = con->to;
struct arc *a;
struct arc *nexta;
struct state *s;
if (to == from) { /* circular constraint is pointless */
freearc(nfa, con);
return 1;
}
if (to->flag) /* can't push forward beyond end */
return 0;
if (to->nouts == 0) { /* dead end */
freearc(nfa, con);
return 1;
}
/*
* DGP 2007-11-15: Here we duplicate the same protections as appear
* in pull() above to avoid troubles with cloning a state with a
* circular constraint on its list of ins. It is not clear whether
* this is necessary, or is protecting against a "can't happen".
* Any test case that actually leads to a freearc() call here would
* be a welcome addition to the test suite.
*/
for (a = to->ins; a != NULL; a = nexta) {
nexta = a->inchain;
switch (a->type) {
case '^':
case '$':
case BEHIND:
case AHEAD:
if (a->from == to) {
freearc(nfa, a);
}
break;
}
}
/* first, clone to state if necessary to avoid other inarcs */
if (to->nins > 1) {
s = newstate(nfa);
if (NISERR())
return 0;
copyouts(nfa, to, s, 1); /* duplicate outarcs */
cparc(nfa, con, from, s); /* move constraint */
freearc(nfa, con);
to = s;
con = to->ins;
}
assert(to->nins == 1);
/* propagate the constraint into the to state's outarcs */
for (a = to->outs; a != NULL; a = nexta) {
nexta = a->outchain;
switch (combine(con, a)) {
case INCOMPATIBLE: /* destroy the arc */
freearc(nfa, a);
break;
case SATISFIED: /* no action needed */
break;
case COMPATIBLE: /* swap the two arcs, more or less */
s = newstate(nfa);
if (NISERR())
return 0;
cparc(nfa, con, s, a->to); /* anticipate move */
cparc(nfa, a, from, s);
if (NISERR())
return 0;
freearc(nfa, a);
break;
default:
assert(NOTREACHED);
break;
}
}
/* remaining outarcs, if any, incorporate the constraint */
moveouts(nfa, to, from);
dropstate(nfa, to); /* will free the constraint */
return 1;
}
/*
- combine - constraint lands on an arc, what happens?
^ #def INCOMPATIBLE 1 // destroys arc
^ #def SATISFIED 2 // constraint satisfied
^ #def COMPATIBLE 3 // compatible but not satisfied yet
^ static int combine(struct arc *, struct arc *);
*/
static int
combine(con, a)
struct arc *con;
struct arc *a;
{
# define CA(ct,at) (((ct)<type, a->type)) {
case CA('^', PLAIN): /* newlines are handled separately */
case CA('$', PLAIN):
return INCOMPATIBLE;
break;
case CA(AHEAD, PLAIN): /* color constraints meet colors */
case CA(BEHIND, PLAIN):
if (con->co == a->co)
return SATISFIED;
return INCOMPATIBLE;
break;
case CA('^', '^'): /* collision, similar constraints */
case CA('$', '$'):
case CA(AHEAD, AHEAD):
case CA(BEHIND, BEHIND):
if (con->co == a->co) /* true duplication */
return SATISFIED;
return INCOMPATIBLE;
break;
case CA('^', BEHIND): /* collision, dissimilar constraints */
case CA(BEHIND, '^'):
case CA('$', AHEAD):
case CA(AHEAD, '$'):
return INCOMPATIBLE;
break;
case CA('^', '$'): /* constraints passing each other */
case CA('^', AHEAD):
case CA(BEHIND, '$'):
case CA(BEHIND, AHEAD):
case CA('$', '^'):
case CA('$', BEHIND):
case CA(AHEAD, '^'):
case CA(AHEAD, BEHIND):
case CA('^', LACON):
case CA(BEHIND, LACON):
case CA('$', LACON):
case CA(AHEAD, LACON):
return COMPATIBLE;
break;
}
assert(NOTREACHED);
return INCOMPATIBLE; /* for benefit of blind compilers */
}
/*
- fixempties - get rid of EMPTY arcs
^ static VOID fixempties(struct nfa *, FILE *);
*/
static VOID
fixempties(nfa, f)
struct nfa *nfa;
FILE *f; /* for debug output; NULL none */
{
struct state *s;
struct state *s2;
struct state *nexts;
struct arc *a;
struct arc *nexta;
/*
* First, get rid of any states whose sole out-arc is an EMPTY,
* since they're basically just aliases for their successor.
* The parsing algorithm creates enough of these that it's worth
* special-casing this.
*/
for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
nexts = s->next;
if (s->flag || s->nouts != 1)
continue;
a = s->outs;
assert(a != NULL && a->outchain == NULL);
if (a->type != EMPTY)
continue;
if (s != a->to)
moveins(nfa, s, a->to);
dropstate(nfa, s);
}
/*
* Similarly, get rid of any state with a single EMPTY in-arc,
* by folding it into its predecessor.
*/
for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
nexts = s->next;
/* Ensure tmp fields are clear for next step */
assert(s->tmp = NULL);
if (s->flag || s->nins != 1)
continue;
a = s->ins;
assert(a != NULL && a->inchain == NULL);
if (a->type != EMPTY)
continue;
if (s != a->from)
moveouts(nfa, s, a->from);
dropstate(nfa, s);
}
/*
* For each remaining NFA state, find all other states that are
* reachable from it by a chain of one or more EMPTY arcs. Then
* generate new arcs that eliminate the need for each such chain.
*
* If we just do this straightforwardly, the algorithm gets slow
* in complex graphs, because the same arcs get copied to all
* intermediate states of an EMPTY chain, and then uselessly
* pushed repeatedly to the chain's final state; we waste a lot
* of time in newarc's duplicate checking. To improve matters,
* we decree that any state with only EMPTY out-arcs is "doomed"
* and will not be part of the final NFA. That can be ensured by
* not adding any new out-arcs to such a state. Having ensured
* that, we need not update the state's in-arcs list either; all
* arcs that might have gotten pushed forward to it will just get
* pushed directly to successor states. This eliminates most of
* the useless duplicate arcs.
*/
for (s = nfa->states; s != NULL && !NISERR(); s = s->next) {
for (s2 = emptyreachable(s, s); s2 != s && !NISERR();
s2 = nexts) {
/*
* If s2 is doomed, we decide that (1) we will
* always push arcs forward to it, not pull them
* back to s; and (2) we can optimize away the
* push-forward, per comment above.
* So do nothing.
*/
if (s2->flag || hasnonemptyout(s2))
replaceempty(nfa, s, s2);
/* Reset the tmp fields as we walk back */
nexts = s2->tmp;
s2->tmp = NULL;
}
s->tmp = NULL;
}
if (NISERR())
return;
/*
* Remove all the EMPTY arcs, since we don't need them anymore.
*/
for (s = nfa->states; s != NULL; s = s->next)
for (a = s->outs; a != NULL; a = nexta) {
nexta = a->outchain;
if (a->type == EMPTY)
freearc(nfa, a);
}
/*
* And remove any states that have become useless. (This
* cleanup is not very thorough, and would be even less so if we
* tried to combine it with the previous step; but cleanup()
* will take care of anything we miss.)
*/
for (s = nfa->states; s != NULL; s = nexts) {
nexts = s->next;
if ((s->nins == 0 || s->nouts == 0) && !s->flag)
dropstate(nfa, s);
}
if (f != NULL)
dumpnfa(nfa, f);
}
/*
- emptyreachable - recursively find all states reachable from s by EMPTY arcs
* The return value is the last such state found. Its tmp field links back
* to the next-to-last such state, and so on back to s, so that all these
* states can be located without searching the whole NFA.
* The maximum recursion depth here is equal to the length of the longest
* loop-free chain of EMPTY arcs, which is surely no more than the size of
* the NFA, and in practice will be a lot less than that.
^ static struct state *emptyreachable(struct state *, struct state *);
*/
static struct state *
emptyreachable(s, lastfound)
struct state *s;
struct state *lastfound;
{
struct arc *a;
s->tmp = lastfound;
lastfound = s;
for (a = s->outs; a != NULL; a = a->outchain)
if (a->type == EMPTY && a->to->tmp == NULL)
lastfound = emptyreachable(a->to, lastfound);
return lastfound;
}
/*
- replaceempty - replace an EMPTY arc chain with some non-empty arcs
* The EMPTY arc(s) should be deleted later, but we can't do it here because
* they may still be needed to identify other arc chains during fixempties().
^ static void replaceempty(struct nfa *, struct state *, struct state *);
*/
static VOID
replaceempty(nfa, from, to)
struct nfa *nfa;
struct state *from;
struct state *to;
{
int fromouts;
int toins;
assert(from != to);
/*
* Create replacement arcs that bypass the need for the EMPTY
* chain. We can do this either by pushing arcs forward
* (linking directly from predecessors of "from" to "to") or by
* pulling them back (linking directly from "from" to the
* successors of "to"). In general, we choose whichever way
* creates greater fan-out or fan-in, so as to improve the odds
* of reducing the other state to zero in-arcs or out-arcs and
* thereby being able to delete it. However, if "from" is
* doomed (has no non-EMPTY out-arcs), we must keep it so, so
* always push forward in that case.
*
* The fan-out/fan-in comparison should count only non-EMPTY
* arcs. If "from" is doomed, we can skip counting "to"'s arcs,
* since we want to force taking the copyins path in that case.
*/
fromouts = nonemptyouts(from);
toins = (fromouts == 0) ? 1 : nonemptyins(to);
if (fromouts > toins) {
copyouts(nfa, to, from, 0);
return;
}
if (fromouts < toins) {
copyins(nfa, from, to, 0);
return;
}
/*
* fromouts == toins. Secondary decision: copy fewest arcs.
*
* Doesn't seem to be worth the trouble to exclude empties from
* these comparisons; that takes extra time and doesn't seem to
* improve the resulting graph much.
*/
if (from->nins > to->nouts) {
copyouts(nfa, to, from, 0);
return;
}
copyins(nfa, from, to, 0);
}
/*
- cleanup - clean up NFA after optimizations
^ static VOID cleanup(struct nfa *);
*/
static VOID
cleanup(nfa)
struct nfa *nfa;
{
struct state *s;
struct state *nexts;
int n;
/* clear out unreachable or dead-end states */
/* use pre to mark reachable, then post to mark can-reach-post */
markreachable(nfa, nfa->pre, (struct state *)NULL, nfa->pre);
markcanreach(nfa, nfa->post, nfa->pre, nfa->post);
for (s = nfa->states; s != NULL; s = nexts) {
nexts = s->next;
if (s->tmp != nfa->post && !s->flag)
dropstate(nfa, s);
}
assert(nfa->post->nins == 0 || nfa->post->tmp == nfa->post);
cleartraverse(nfa, nfa->pre);
assert(nfa->post->nins == 0 || nfa->post->tmp == NULL);
/* the nins==0 (final unreachable) case will be caught later */
/* renumber surviving states */
n = 0;
for (s = nfa->states; s != NULL; s = s->next)
s->no = n++;
nfa->nstates = n;
}
/*
- markreachable - recursive marking of reachable states
^ static VOID markreachable(struct nfa *, struct state *, struct state *,
^ struct state *);
*/
static VOID
markreachable(nfa, s, okay, mark)
struct nfa *nfa;
struct state *s;
struct state *okay; /* consider only states with this mark */
struct state *mark; /* the value to mark with */
{
struct arc *a;
if (s->tmp != okay)
return;
s->tmp = mark;
for (a = s->outs; a != NULL; a = a->outchain)
markreachable(nfa, a->to, okay, mark);
}
/*
- markcanreach - recursive marking of states which can reach here
^ static VOID markcanreach(struct nfa *, struct state *, struct state *,
^ struct state *);
*/
static VOID
markcanreach(nfa, s, okay, mark)
struct nfa *nfa;
struct state *s;
struct state *okay; /* consider only states with this mark */
struct state *mark; /* the value to mark with */
{
struct arc *a;
if (s->tmp != okay)
return;
s->tmp = mark;
for (a = s->ins; a != NULL; a = a->inchain)
markcanreach(nfa, a->from, okay, mark);
}
/*
- analyze - ascertain potentially-useful facts about an optimized NFA
^ static long analyze(struct nfa *);
*/
static long /* re_info bits to be ORed in */
analyze(nfa)
struct nfa *nfa;
{
struct arc *a;
struct arc *aa;
if (nfa->pre->outs == NULL)
return REG_UIMPOSSIBLE;
for (a = nfa->pre->outs; a != NULL; a = a->outchain)
for (aa = a->to->outs; aa != NULL; aa = aa->outchain)
if (aa->to == nfa->post)
return REG_UEMPTYMATCH;
return 0;
}
/*
- compact - compact an NFA
^ static VOID compact(struct nfa *, struct cnfa *);
*/
static VOID
compact(nfa, cnfa)
struct nfa *nfa;
struct cnfa *cnfa;
{
struct state *s;
struct arc *a;
size_t nstates;
size_t narcs;
struct carc *ca;
struct carc *first;
assert (!NISERR());
nstates = 0;
narcs = 0;
for (s = nfa->states; s != NULL; s = s->next) {
nstates++;
narcs += 1 + s->nouts + 1;
/* 1 as a fake for flags, nouts for arcs, 1 as endmarker */
}
cnfa->states = (struct carc **)MALLOC(nstates * sizeof(struct carc *));
cnfa->arcs = (struct carc *)MALLOC(narcs * sizeof(struct carc));
if (cnfa->states == NULL || cnfa->arcs == NULL) {
if (cnfa->states != NULL)
FREE(cnfa->states);
if (cnfa->arcs != NULL)
FREE(cnfa->arcs);
NERR(REG_ESPACE);
return;
}
cnfa->nstates = nstates;
cnfa->pre = nfa->pre->no;
cnfa->post = nfa->post->no;
cnfa->bos[0] = nfa->bos[0];
cnfa->bos[1] = nfa->bos[1];
cnfa->eos[0] = nfa->eos[0];
cnfa->eos[1] = nfa->eos[1];
cnfa->ncolors = maxcolor(nfa->cm) + 1;
cnfa->flags = 0;
ca = cnfa->arcs;
for (s = nfa->states; s != NULL; s = s->next) {
assert((size_t)s->no < nstates);
cnfa->states[s->no] = ca;
ca->co = 0; /* clear and skip flags "arc" */
ca++;
first = ca;
for (a = s->outs; a != NULL; a = a->outchain)
switch (a->type) {
case PLAIN:
ca->co = a->co;
ca->to = a->to->no;
ca++;
break;
case LACON:
assert(s->no != cnfa->pre);
ca->co = (color)(cnfa->ncolors + a->co);
ca->to = a->to->no;
ca++;
cnfa->flags |= HASLACONS;
break;
default:
assert(NOTREACHED);
break;
}
carcsort(first, ca-1);
ca->co = COLORLESS;
ca->to = 0;
ca++;
}
assert(ca == &cnfa->arcs[narcs]);
assert(cnfa->nstates != 0);
/* mark no-progress states */
for (a = nfa->pre->outs; a != NULL; a = a->outchain)
cnfa->states[a->to->no]->co = 1;
cnfa->states[nfa->pre->no]->co = 1;
}
/*
- carcsort - sort compacted-NFA arcs by color
* Really dumb algorithm, but if the list is long enough for that to matter,
* you're in real trouble anyway.
^ static VOID carcsort(struct carc *, struct carc *);
*/
static VOID
carcsort(first, last)
struct carc *first;
struct carc *last;
{
struct carc *p;
struct carc *q;
struct carc tmp;
if (last - first <= 1)
return;
for (p = first; p <= last; p++)
for (q = p; q <= last; q++)
if (p->co > q->co ||
(p->co == q->co && p->to > q->to)) {
assert(p != q);
tmp = *p;
*p = *q;
*q = tmp;
}
}
/*
- freecnfa - free a compacted NFA
^ static VOID freecnfa(struct cnfa *);
*/
static VOID
freecnfa(cnfa)
struct cnfa *cnfa;
{
assert(cnfa->nstates != 0); /* not empty already */
cnfa->nstates = 0;
FREE(cnfa->states);
FREE(cnfa->arcs);
}
/*
- dumpnfa - dump an NFA in human-readable form
^ static VOID dumpnfa(struct nfa *, FILE *);
*/
static VOID
dumpnfa(nfa, f)
struct nfa *nfa;
FILE *f;
{
#ifdef REG_DEBUG
struct state *s;
fprintf(f, "pre %d, post %d", nfa->pre->no, nfa->post->no);
if (nfa->bos[0] != COLORLESS)
fprintf(f, ", bos [%ld]", (long)nfa->bos[0]);
if (nfa->bos[1] != COLORLESS)
fprintf(f, ", bol [%ld]", (long)nfa->bos[1]);
if (nfa->eos[0] != COLORLESS)
fprintf(f, ", eos [%ld]", (long)nfa->eos[0]);
if (nfa->eos[1] != COLORLESS)
fprintf(f, ", eol [%ld]", (long)nfa->eos[1]);
fprintf(f, "\n");
for (s = nfa->states; s != NULL; s = s->next)
dumpstate(s, f);
if (nfa->parent == NULL)
dumpcolors(nfa->cm, f);
fflush(f);
#endif
}
#ifdef REG_DEBUG /* subordinates of dumpnfa */
/*
^ #ifdef REG_DEBUG
*/
/*
- dumpstate - dump an NFA state in human-readable form
^ static VOID dumpstate(struct state *, FILE *);
*/
static VOID
dumpstate(s, f)
struct state *s;
FILE *f;
{
struct arc *a;
fprintf(f, "%d%s%c", s->no, (s->tmp != NULL) ? "T" : "",
(s->flag) ? s->flag : '.');
if (s->prev != NULL && s->prev->next != s)
fprintf(f, "\tstate chain bad\n");
if (s->nouts == 0)
fprintf(f, "\tno out arcs\n");
else
dumparcs(s, f);
fflush(f);
for (a = s->ins; a != NULL; a = a->inchain) {
if (a->to != s)
fprintf(f, "\tlink from %d to %d on %d's in-chain\n",
a->from->no, a->to->no, s->no);
}
}
/*
- dumparcs - dump out-arcs in human-readable form
^ static VOID dumparcs(struct state *, FILE *);
*/
static VOID
dumparcs(s, f)
struct state *s;
FILE *f;
{
int pos;
assert(s->nouts > 0);
/* printing arcs in reverse order is usually clearer */
pos = dumprarcs(s->outs, s, f, 1);
if (pos != 1)
fprintf(f, "\n");
}
/*
- dumprarcs - dump remaining outarcs, recursively, in reverse order
^ static int dumprarcs(struct arc *, struct state *, FILE *, int);
*/
static int /* resulting print position */
dumprarcs(a, s, f, pos)
struct arc *a;
struct state *s;
FILE *f;
int pos; /* initial print position */
{
if (a->outchain != NULL)
pos = dumprarcs(a->outchain, s, f, pos);
dumparc(a, s, f);
if (pos == 5) {
fprintf(f, "\n");
pos = 1;
} else
pos++;
return pos;
}
/*
- dumparc - dump one outarc in readable form, including prefixing tab
^ static VOID dumparc(struct arc *, struct state *, FILE *);
*/
static VOID
dumparc(a, s, f)
struct arc *a;
struct state *s;
FILE *f;
{
struct arc *aa;
struct arcbatch *ab;
fprintf(f, "\t");
switch (a->type) {
case PLAIN:
fprintf(f, "[%ld]", (long)a->co);
break;
case AHEAD:
fprintf(f, ">%ld>", (long)a->co);
break;
case BEHIND:
fprintf(f, "<%ld<", (long)a->co);
break;
case LACON:
fprintf(f, ":%ld:", (long)a->co);
break;
case '^':
case '$':
fprintf(f, "%c%d", a->type, (int)a->co);
break;
case EMPTY:
break;
default:
fprintf(f, "0x%x/0%lo", a->type, (long)a->co);
break;
}
if (a->from != s)
fprintf(f, "?%d?", a->from->no);
for (ab = &a->from->oas; ab != NULL; ab = ab->next) {
for (aa = &ab->a[0]; aa < &ab->a[ABSIZE]; aa++)
if (aa == a)
break; /* NOTE BREAK OUT */
if (aa < &ab->a[ABSIZE]) /* propagate break */
break; /* NOTE BREAK OUT */
}
if (ab == NULL)
fprintf(f, "?!?"); /* not in allocated space */
fprintf(f, "->");
if (a->to == NULL) {
fprintf(f, "NULL");
return;
}
fprintf(f, "%d", a->to->no);
for (aa = a->to->ins; aa != NULL; aa = aa->inchain)
if (aa == a)
break; /* NOTE BREAK OUT */
if (aa == NULL)
fprintf(f, "?!?"); /* missing from in-chain */
}
/*
^ #endif
*/
#endif /* ifdef REG_DEBUG */
/*
- dumpcnfa - dump a compacted NFA in human-readable form
^ static VOID dumpcnfa(struct cnfa *, FILE *);
*/
static VOID
dumpcnfa(cnfa, f)
struct cnfa *cnfa;
FILE *f;
{
#ifdef REG_DEBUG
int st;
fprintf(f, "pre %d, post %d", cnfa->pre, cnfa->post);
if (cnfa->bos[0] != COLORLESS)
fprintf(f, ", bos [%ld]", (long)cnfa->bos[0]);
if (cnfa->bos[1] != COLORLESS)
fprintf(f, ", bol [%ld]", (long)cnfa->bos[1]);
if (cnfa->eos[0] != COLORLESS)
fprintf(f, ", eos [%ld]", (long)cnfa->eos[0]);
if (cnfa->eos[1] != COLORLESS)
fprintf(f, ", eol [%ld]", (long)cnfa->eos[1]);
if (cnfa->flags&HASLACONS)
fprintf(f, ", haslacons");
fprintf(f, "\n");
for (st = 0; st < cnfa->nstates; st++)
dumpcstate(st, cnfa->states[st], cnfa, f);
fflush(f);
#endif
}
#ifdef REG_DEBUG /* subordinates of dumpcnfa */
/*
^ #ifdef REG_DEBUG
*/
/*
- dumpcstate - dump a compacted-NFA state in human-readable form
^ static VOID dumpcstate(int, struct carc *, struct cnfa *, FILE *);
*/
static VOID
dumpcstate(st, ca, cnfa, f)
int st;
struct carc *ca;
struct cnfa *cnfa;
FILE *f;
{
int i;
int pos;
fprintf(f, "%d%s", st, (ca[0].co) ? ":" : ".");
pos = 1;
for (i = 1; ca[i].co != COLORLESS; i++) {
if (ca[i].co < cnfa->ncolors)
fprintf(f, "\t[%ld]->%d", (long)ca[i].co, ca[i].to);
else
fprintf(f, "\t:%ld:->%d", (long)ca[i].co-cnfa->ncolors,
ca[i].to);
if (pos == 5) {
fprintf(f, "\n");
pos = 1;
} else
pos++;
}
if (i == 1 || pos != 1)
fprintf(f, "\n");
fflush(f);
}
/*
^ #endif
*/
#endif /* ifdef REG_DEBUG */
tcl8.4.20/generic/regc_color.c 0000644 0036047 0045461 00000043043 12133546537 014620 0 ustar dgp 771div /*
* colorings of characters
* This file is #included by regcomp.c.
*
* Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
* Corporation, none of whom are responsible for the results. The author
* thanks all of them.
*
* Redistribution and use in source and binary forms -- with or without
* modification -- are permitted for any purpose, provided that
* redistributions in source form retain this entire copyright notice and
* indicate the origin and nature of any modifications.
*
* I'd appreciate being given credit for this package in the documentation
* of software which uses it, but that is not a requirement.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
* HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*
*
* Note that there are some incestuous relationships between this code and
* NFA arc maintenance, which perhaps ought to be cleaned up sometime.
*/
#define CISERR() VISERR(cm->v)
#define CERR(e) VERR(cm->v, (e))
/*
- initcm - set up new colormap
^ static VOID initcm(struct vars *, struct colormap *);
*/
static VOID
initcm(v, cm)
struct vars *v;
struct colormap *cm;
{
int i;
int j;
union tree *t;
union tree *nextt;
struct colordesc *cd;
cm->magic = CMMAGIC;
cm->v = v;
cm->ncds = NINLINECDS;
cm->cd = cm->cdspace;
cm->max = 0;
cm->free = 0;
cd = cm->cd; /* cm->cd[WHITE] */
cd->sub = NOSUB;
cd->arcs = NULL;
cd->flags = 0;
cd->nchrs = CHR_MAX - CHR_MIN + 1;
/* upper levels of tree */
for (t = &cm->tree[0], j = NBYTS-1; j > 0; t = nextt, j--) {
nextt = t + 1;
for (i = BYTTAB-1; i >= 0; i--)
t->tptr[i] = nextt;
}
/* bottom level is solid white */
t = &cm->tree[NBYTS-1];
for (i = BYTTAB-1; i >= 0; i--)
t->tcolor[i] = WHITE;
cd->block = t;
}
/*
- freecm - free dynamically-allocated things in a colormap
^ static VOID freecm(struct colormap *);
*/
static VOID
freecm(cm)
struct colormap *cm;
{
size_t i;
union tree *cb;
cm->magic = 0;
if (NBYTS > 1)
cmtreefree(cm, cm->tree, 0);
for (i = 1; i <= cm->max; i++) /* skip WHITE */
if (!UNUSEDCOLOR(&cm->cd[i])) {
cb = cm->cd[i].block;
if (cb != NULL)
FREE(cb);
}
if (cm->cd != cm->cdspace)
FREE(cm->cd);
}
/*
- cmtreefree - free a non-terminal part of a colormap tree
^ static VOID cmtreefree(struct colormap *, union tree *, int);
*/
static VOID
cmtreefree(cm, tree, level)
struct colormap *cm;
union tree *tree;
int level; /* level number (top == 0) of this block */
{
int i;
union tree *t;
union tree *fillt = &cm->tree[level+1];
union tree *cb;
assert(level < NBYTS-1); /* this level has pointers */
for (i = BYTTAB-1; i >= 0; i--) {
t = tree->tptr[i];
assert(t != NULL);
if (t != fillt) {
if (level < NBYTS-2) { /* more pointer blocks below */
cmtreefree(cm, t, level+1);
FREE(t);
} else { /* color block below */
cb = cm->cd[t->tcolor[0]].block;
if (t != cb) /* not a solid block */
FREE(t);
}
}
}
}
/*
- setcolor - set the color of a character in a colormap
^ static color setcolor(struct colormap *, pchr, pcolor);
*/
static color /* previous color */
setcolor(cm, c, co)
struct colormap *cm;
pchr c;
pcolor co;
{
uchr uc = c;
int shift;
int level;
int b;
int bottom;
union tree *t;
union tree *newt;
union tree *fillt;
union tree *lastt;
union tree *cb;
color prev;
assert(cm->magic == CMMAGIC);
if (CISERR() || co == COLORLESS)
return COLORLESS;
t = cm->tree;
for (level = 0, shift = BYTBITS * (NBYTS - 1); shift > 0;
level++, shift -= BYTBITS) {
b = (uc >> shift) & BYTMASK;
lastt = t;
t = lastt->tptr[b];
assert(t != NULL);
fillt = &cm->tree[level+1];
bottom = (shift <= BYTBITS) ? 1 : 0;
cb = (bottom) ? cm->cd[t->tcolor[0]].block : fillt;
if (t == fillt || t == cb) { /* must allocate a new block */
newt = (union tree *)MALLOC((bottom) ?
sizeof(struct colors) : sizeof(struct ptrs));
if (newt == NULL) {
CERR(REG_ESPACE);
return COLORLESS;
}
if (bottom)
memcpy(VS(newt->tcolor), VS(t->tcolor),
BYTTAB*sizeof(color));
else
memcpy(VS(newt->tptr), VS(t->tptr),
BYTTAB*sizeof(union tree *));
t = newt;
lastt->tptr[b] = t;
}
}
b = uc & BYTMASK;
prev = t->tcolor[b];
t->tcolor[b] = (color)co;
return prev;
}
/*
- maxcolor - report largest color number in use
^ static color maxcolor(struct colormap *);
*/
static color
maxcolor(cm)
struct colormap *cm;
{
if (CISERR())
return COLORLESS;
return (color)cm->max;
}
/*
- newcolor - find a new color (must be subject of setcolor at once)
* Beware: may relocate the colordescs.
^ static color newcolor(struct colormap *);
*/
static color /* COLORLESS for error */
newcolor(cm)
struct colormap *cm;
{
struct colordesc *cd;
size_t n;
if (CISERR())
return COLORLESS;
if (cm->free != 0) {
assert(cm->free > 0);
assert((size_t)cm->free < cm->ncds);
cd = &cm->cd[cm->free];
assert(UNUSEDCOLOR(cd));
assert(cd->arcs == NULL);
cm->free = cd->sub;
} else if (cm->max < cm->ncds - 1) {
cm->max++;
cd = &cm->cd[cm->max];
} else {
/* oops, must allocate more */
struct colordesc *newCd;
if (cm->max == MAX_COLOR) {
CERR(REG_ECOLORS);
return COLORLESS; /* too many colors */
}
n = cm->ncds * 2;
if (n < MAX_COLOR + 1)
n = MAX_COLOR + 1;
if (cm->cd == cm->cdspace) {
newCd = (struct colordesc *)MALLOC(n *
sizeof(struct colordesc));
if (newCd != NULL)
memcpy(VS(newCd), VS(cm->cdspace), cm->ncds *
sizeof(struct colordesc));
} else
newCd = (struct colordesc *)REALLOC(cm->cd,
n * sizeof(struct colordesc));
if (newCd == NULL) {
CERR(REG_ESPACE);
return COLORLESS;
}
cm->cd = newCd;
cm->ncds = n;
assert(cm->max < cm->ncds - 1);
cm->max++;
cd = &cm->cd[cm->max];
}
cd->nchrs = 0;
cd->sub = NOSUB;
cd->arcs = NULL;
cd->flags = 0;
cd->block = NULL;
return (color)(cd - cm->cd);
}
/*
- freecolor - free a color (must have no arcs or subcolor)
^ static VOID freecolor(struct colormap *, pcolor);
*/
static VOID
freecolor(cm, co)
struct colormap *cm;
pcolor co;
{
struct colordesc *cd = &cm->cd[co];
color pco, nco; /* for freelist scan */
assert(co >= 0);
if (co == WHITE)
return;
assert(cd->arcs == NULL);
assert(cd->sub == NOSUB);
assert(cd->nchrs == 0);
cd->flags = FREECOL;
if (cd->block != NULL) {
FREE(cd->block);
cd->block = NULL; /* just paranoia */
}
if ((size_t)co == cm->max) {
while (cm->max > WHITE && UNUSEDCOLOR(&cm->cd[cm->max]))
cm->max--;
assert(cm->free >= 0);
while ((size_t)cm->free > cm->max)
cm->free = cm->cd[cm->free].sub;
if (cm->free > 0) {
assert(cm->free < cm->max);
pco = cm->free;
nco = cm->cd[pco].sub;
while (nco > 0)
if ((size_t)nco > cm->max) {
/* take this one out of freelist */
nco = cm->cd[nco].sub;
cm->cd[pco].sub = nco;
} else {
assert(nco < cm->max);
pco = nco;
nco = cm->cd[pco].sub;
}
}
} else {
cd->sub = cm->free;
cm->free = (color)(cd - cm->cd);
}
}
/*
- pseudocolor - allocate a false color, to be managed by other means
^ static color pseudocolor(struct colormap *);
*/
static color
pseudocolor(cm)
struct colormap *cm;
{
color co;
co = newcolor(cm);
if (CISERR())
return COLORLESS;
cm->cd[co].nchrs = 1;
cm->cd[co].flags = PSEUDO;
return co;
}
/*
- subcolor - allocate a new subcolor (if necessary) to this chr
^ static color subcolor(struct colormap *, pchr c);
*/
static color
subcolor(cm, c)
struct colormap *cm;
pchr c;
{
color co; /* current color of c */
color sco; /* new subcolor */
co = GETCOLOR(cm, c);
sco = newsub(cm, co);
if (CISERR())
return COLORLESS;
assert(sco != COLORLESS);
if (co == sco) /* already in an open subcolor */
return co; /* rest is redundant */
cm->cd[co].nchrs--;
cm->cd[sco].nchrs++;
setcolor(cm, c, sco);
return sco;
}
/*
- newsub - allocate a new subcolor (if necessary) for a color
^ static color newsub(struct colormap *, pcolor);
*/
static color
newsub(cm, co)
struct colormap *cm;
pcolor co;
{
color sco; /* new subcolor */
sco = cm->cd[co].sub;
if (sco == NOSUB) { /* color has no open subcolor */
if (cm->cd[co].nchrs == 1) /* optimization */
return co;
sco = newcolor(cm); /* must create subcolor */
if (sco == COLORLESS) {
assert(CISERR());
return COLORLESS;
}
cm->cd[co].sub = sco;
cm->cd[sco].sub = sco; /* open subcolor points to self */
}
assert(sco != NOSUB);
return sco;
}
/*
- subrange - allocate new subcolors to this range of chrs, fill in arcs
^ static VOID subrange(struct vars *, pchr, pchr, struct state *,
^ struct state *);
*/
static VOID
subrange(v, from, to, lp, rp)
struct vars *v;
pchr from;
pchr to;
struct state *lp;
struct state *rp;
{
uchr uf;
int i;
assert(from <= to);
/* first, align "from" on a tree-block boundary */
uf = (uchr)from;
i = (int)( ((uf + BYTTAB-1) & (uchr)~BYTMASK) - uf );
for (; from <= to && i > 0; i--, from++)
newarc(v->nfa, PLAIN, subcolor(v->cm, from), lp, rp);
if (from > to) /* didn't reach a boundary */
return;
/* deal with whole blocks */
for (; to - from >= BYTTAB; from += BYTTAB)
subblock(v, from, lp, rp);
/* clean up any remaining partial table */
for (; from <= to; from++)
newarc(v->nfa, PLAIN, subcolor(v->cm, from), lp, rp);
}
/*
- subblock - allocate new subcolors for one tree block of chrs, fill in arcs
^ static VOID subblock(struct vars *, pchr, struct state *, struct state *);
*/
static VOID
subblock(v, start, lp, rp)
struct vars *v;
pchr start; /* first of BYTTAB chrs */
struct state *lp;
struct state *rp;
{
uchr uc = start;
struct colormap *cm = v->cm;
int shift;
int level;
int i;
int b;
union tree *t;
union tree *cb;
union tree *fillt;
union tree *lastt;
int previ;
int ndone;
color co;
color sco;
assert((uc % BYTTAB) == 0);
/* find its color block, making new pointer blocks as needed */
t = cm->tree;
fillt = NULL;
for (level = 0, shift = BYTBITS * (NBYTS - 1); shift > 0;
level++, shift -= BYTBITS) {
b = (uc >> shift) & BYTMASK;
lastt = t;
t = lastt->tptr[b];
assert(t != NULL);
fillt = &cm->tree[level+1];
if (t == fillt && shift > BYTBITS) { /* need new ptr block */
t = (union tree *)MALLOC(sizeof(struct ptrs));
if (t == NULL) {
CERR(REG_ESPACE);
return;
}
memcpy(VS(t->tptr), VS(fillt->tptr),
BYTTAB*sizeof(union tree *));
lastt->tptr[b] = t;
}
}
/* special cases: fill block or solid block */
co = t->tcolor[0];
cb = cm->cd[co].block;
if (t == fillt || t == cb) {
/* either way, we want a subcolor solid block */
sco = newsub(cm, co);
t = cm->cd[sco].block;
if (t == NULL) { /* must set it up */
t = (union tree *)MALLOC(sizeof(struct colors));
if (t == NULL) {
CERR(REG_ESPACE);
return;
}
for (i = 0; i < BYTTAB; i++)
t->tcolor[i] = sco;
cm->cd[sco].block = t;
}
/* find loop must have run at least once */
lastt->tptr[b] = t;
newarc(v->nfa, PLAIN, sco, lp, rp);
cm->cd[co].nchrs -= BYTTAB;
cm->cd[sco].nchrs += BYTTAB;
return;
}
/* general case, a mixed block to be altered */
i = 0;
while (i < BYTTAB) {
co = t->tcolor[i];
sco = newsub(cm, co);
newarc(v->nfa, PLAIN, sco, lp, rp);
previ = i;
do {
t->tcolor[i++] = sco;
} while (i < BYTTAB && t->tcolor[i] == co);
ndone = i - previ;
cm->cd[co].nchrs -= ndone;
cm->cd[sco].nchrs += ndone;
}
}
/*
- okcolors - promote subcolors to full colors
^ static VOID okcolors(struct nfa *, struct colormap *);
*/
static VOID
okcolors(nfa, cm)
struct nfa *nfa;
struct colormap *cm;
{
struct colordesc *cd;
struct colordesc *end = CDEND(cm);
struct colordesc *scd;
struct arc *a;
color co;
color sco;
for (cd = cm->cd, co = 0; cd < end; cd++, co++) {
sco = cd->sub;
if (UNUSEDCOLOR(cd) || sco == NOSUB) {
/* has no subcolor, no further action */
} else if (sco == co) {
/* is subcolor, let parent deal with it */
} else if (cd->nchrs == 0) {
/* parent empty, its arcs change color to subcolor */
cd->sub = NOSUB;
scd = &cm->cd[sco];
assert(scd->nchrs > 0);
assert(scd->sub == sco);
scd->sub = NOSUB;
while ((a = cd->arcs) != NULL) {
assert(a->co == co);
uncolorchain(cm, a);
a->co = sco;
colorchain(cm, a);
}
freecolor(cm, co);
} else {
/* parent's arcs must gain parallel subcolor arcs */
cd->sub = NOSUB;
scd = &cm->cd[sco];
assert(scd->nchrs > 0);
assert(scd->sub == sco);
scd->sub = NOSUB;
for (a = cd->arcs; a != NULL; a = a->colorchain) {
assert(a->co == co);
newarc(nfa, a->type, sco, a->from, a->to);
}
}
}
}
/*
- colorchain - add this arc to the color chain of its color
^ static VOID colorchain(struct colormap *, struct arc *);
*/
static VOID
colorchain(cm, a)
struct colormap *cm;
struct arc *a;
{
struct colordesc *cd = &cm->cd[a->co];
if (cd->arcs)
cd->arcs->colorchain_rev = a;
a->colorchain = cd->arcs;
a->colorchain_rev = NULL;
cd->arcs = a;
}
/*
- uncolorchain - delete this arc from the color chain of its color
^ static VOID uncolorchain(struct colormap *, struct arc *);
*/
static VOID
uncolorchain(cm, a)
struct colormap *cm;
struct arc *a;
{
struct colordesc *cd = &cm->cd[a->co];
struct arc *aa = a->colorchain_rev;
if (aa == NULL) {
assert(cd->arcs == a);
cd->arcs = a->colorchain;
} else {
assert(aa->colorchain == a);
aa->colorchain = a->colorchain;
}
if (a->colorchain)
a->colorchain->colorchain_rev = aa;
a->colorchain = NULL; /* paranoia */
a->colorchain_rev = NULL;
}
/*
- singleton - is this character in its own color?
^ static int singleton(struct colormap *, pchr c);
*/
static int /* predicate */
singleton(cm, c)
struct colormap *cm;
pchr c;
{
color co; /* color of c */
co = GETCOLOR(cm, c);
if (cm->cd[co].nchrs == 1 && cm->cd[co].sub == NOSUB)
return 1;
return 0;
}
/*
- rainbow - add arcs of all full colors (but one) between specified states
^ static VOID rainbow(struct nfa *, struct colormap *, int, pcolor,
^ struct state *, struct state *);
*/
static VOID
rainbow(nfa, cm, type, but, from, to)
struct nfa *nfa;
struct colormap *cm;
int type;
pcolor but; /* COLORLESS if no exceptions */
struct state *from;
struct state *to;
{
struct colordesc *cd;
struct colordesc *end = CDEND(cm);
color co;
for (cd = cm->cd, co = 0; cd < end && !CISERR(); cd++, co++)
if (!UNUSEDCOLOR(cd) && cd->sub != co && co != but &&
!(cd->flags&PSEUDO))
newarc(nfa, type, co, from, to);
}
/*
- colorcomplement - add arcs of complementary colors
* The calling sequence ought to be reconciled with cloneouts().
^ static VOID colorcomplement(struct nfa *, struct colormap *, int,
^ struct state *, struct state *, struct state *);
*/
static VOID
colorcomplement(nfa, cm, type, of, from, to)
struct nfa *nfa;
struct colormap *cm;
int type;
struct state *of; /* complements of this guy's PLAIN outarcs */
struct state *from;
struct state *to;
{
struct colordesc *cd;
struct colordesc *end = CDEND(cm);
color co;
assert(of != from);
for (cd = cm->cd, co = 0; cd < end && !CISERR(); cd++, co++)
if (!UNUSEDCOLOR(cd) && !(cd->flags&PSEUDO))
if (findarc(of, PLAIN, co) == NULL)
newarc(nfa, type, co, from, to);
}
#ifdef REG_DEBUG
/*
^ #ifdef REG_DEBUG
*/
/*
- dumpcolors - debugging output
^ static VOID dumpcolors(struct colormap *, FILE *);
*/
static VOID
dumpcolors(cm, f)
struct colormap *cm;
FILE *f;
{
struct colordesc *cd;
struct colordesc *end;
color co;
chr c;
char *has;
fprintf(f, "max %ld\n", (long)cm->max);
if (NBYTS > 1)
fillcheck(cm, cm->tree, 0, f);
end = CDEND(cm);
for (cd = cm->cd + 1, co = 1; cd < end; cd++, co++) /* skip 0 */
if (!UNUSEDCOLOR(cd)) {
assert(cd->nchrs > 0);
has = (cd->block != NULL) ? "#" : "";
if (cd->flags&PSEUDO)
fprintf(f, "#%2ld%s(ps): ", (long)co, has);
else
fprintf(f, "#%2ld%s(%2d): ", (long)co,
has, cd->nchrs);
/* it's hard to do this more efficiently */
for (c = CHR_MIN; c < CHR_MAX; c++)
if (GETCOLOR(cm, c) == co)
dumpchr(c, f);
assert(c == CHR_MAX);
if (GETCOLOR(cm, c) == co)
dumpchr(c, f);
fprintf(f, "\n");
}
}
/*
- fillcheck - check proper filling of a tree
^ static VOID fillcheck(struct colormap *, union tree *, int, FILE *);
*/
static VOID
fillcheck(cm, tree, level, f)
struct colormap *cm;
union tree *tree;
int level; /* level number (top == 0) of this block */
FILE *f;
{
int i;
union tree *t;
union tree *fillt = &cm->tree[level+1];
assert(level < NBYTS-1); /* this level has pointers */
for (i = BYTTAB-1; i >= 0; i--) {
t = tree->tptr[i];
if (t == NULL)
fprintf(f, "NULL found in filled tree!\n");
else if (t == fillt)
{}
else if (level < NBYTS-2) /* more pointer blocks below */
fillcheck(cm, t, level+1, f);
}
}
/*
- dumpchr - print a chr
* Kind of char-centric but works well enough for debug use.
^ static VOID dumpchr(pchr, FILE *);
*/
static VOID
dumpchr(c, f)
pchr c;
FILE *f;
{
if (c == '\\')
fprintf(f, "\\\\");
else if (c > ' ' && c <= '~')
putc((char)c, f);
else
fprintf(f, "\\u%04lx", (long)c);
}
/*
^ #endif
*/
#endif /* ifdef REG_DEBUG */
tcl8.4.20/generic/tclIndexObj.c 0000644 0036047 0045461 00000034714 12144442333 014703 0 ustar dgp 771div /*
* tclIndexObj.c --
*
* This file implements objects of type "index". This object type
* is used to lookup a keyword in a table of valid values and cache
* the index of the matching entry.
*
* 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.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* Prototypes for procedures defined later in this file:
*/
static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr));
static void DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr));
static void FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr));
/*
* The structure below defines the index Tcl object type by means of
* procedures that can be invoked by generic object code.
*/
Tcl_ObjType tclIndexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
UpdateStringOfIndex, /* updateStringProc */
SetIndexFromAny /* setFromAnyProc */
};
/*
* The definition of the internal representation of the "index"
* object; The internalRep.otherValuePtr field of an object of "index"
* type will be a pointer to one of these structures.
*
* Keep this structure declaration in sync with tclTestObj.c
*/
typedef struct {
VOID *tablePtr; /* Pointer to the table of strings */
int offset; /* Offset between table entries */
int index; /* Selected index into table. */
} IndexRep;
/*
* The following macros greatly simplify moving through a table...
*/
#define STRING_AT(table, offset, index) \
(*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index)))))
#define NEXT_ENTRY(table, offset) \
(&(STRING_AT(table, offset, 1)))
#define EXPAND_OF(indexRep) \
STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index)
/*
*----------------------------------------------------------------------
*
* Tcl_GetIndexFromObj --
*
* This procedure looks up an object's value in a table of strings
* and returns the index of the matching string, if any.
*
* Results:
*
* If the value of objPtr is identical to or a unique abbreviation
* for one of the entries in objPtr, then the return value is
* TCL_OK and the index of the matching entry is stored at
* *indexPtr. If there isn't a proper match, then TCL_ERROR is
* returned and an error message is left in interp's result (unless
* interp is NULL). The msg argument is used in the error
* message; for example, if msg has the value "option" then the
* error message will say something flag 'bad option "foo": must be
* ...'
*
* Side effects:
* The result of the lookup is cached as the internal rep of
* objPtr, so that repeated lookups can be done quickly.
*
*----------------------------------------------------------------------
*/
#undef Tcl_GetIndexFromObj
int
Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* Object containing the string to lookup. */
CONST char **tablePtr; /* Array of strings to compare against the
* value of objPtr; last entry must be NULL
* and there must not be duplicate entries. */
CONST char *msg; /* Identifying word to use in error messages. */
int flags; /* 0 or TCL_EXACT */
int *indexPtr; /* Place to store resulting integer index. */
{
/*
* See if there is a valid cached result from a previous lookup
* (doing the check here saves the overhead of calling
* Tcl_GetIndexFromObjStruct in the common case where the result
* is cached).
*/
if (objPtr->typePtr == &tclIndexType) {
IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
/*
* Here's hoping we don't get hit by unfortunate packing
* constraints on odd platforms like a Cray PVP...
*/
if (indexRep->tablePtr == (VOID *)tablePtr &&
indexRep->offset == sizeof(char *)) {
*indexPtr = indexRep->index;
return TCL_OK;
}
}
return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
msg, flags, indexPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetIndexFromObjStruct --
*
* This procedure looks up an object's value given a starting
* string and an offset for the amount of space between strings.
* This is useful when the strings are embedded in some other
* kind of array.
*
* Results:
*
* If the value of objPtr is identical to or a unique abbreviation
* for one of the entries in objPtr, then the return value is
* TCL_OK and the index of the matching entry is stored at
* *indexPtr. If there isn't a proper match, then TCL_ERROR is
* returned and an error message is left in interp's result (unless
* interp is NULL). The msg argument is used in the error
* message; for example, if msg has the value "option" then the
* error message will say something like 'bad option "foo": must be
* ...'
*
* Side effects:
* The result of the lookup is cached as the internal rep of
* objPtr, so that repeated lookups can be done quickly.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
indexPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* Object containing the string to lookup. */
CONST VOID *tablePtr; /* The first string in the table. The second
* string will be at this address plus the
* offset, the third plus the offset again,
* etc. The last entry must be NULL
* and there must not be duplicate entries. */
int offset; /* The number of bytes between entries */
CONST char *msg; /* Identifying word to use in error messages. */
int flags; /* 0 or TCL_EXACT */
int *indexPtr; /* Place to store resulting integer index. */
{
int index, i, numAbbrev;
char *key, *p1;
CONST char *p2;
CONST char * CONST *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
/* Protect against invalid values, like -1 or 0. */
if (offset < (int)sizeof(char *)) {
offset = (int)sizeof(char *);
}
/*
* See if there is a valid cached result from a previous lookup.
*/
if (objPtr->typePtr == &tclIndexType) {
indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
return TCL_OK;
}
}
/*
* Lookup the value of the object in the table. Accept unique
* abbreviations unless TCL_EXACT is set in flags.
*/
key = TclGetString(objPtr);
index = -1;
numAbbrev = 0;
/*
* Scan the table looking for one of:
* - An exact match (always preferred)
* - A single abbreviation (allowed depending on flags)
* - Several abbreviations (never allowed, but overridden by exact match)
*/
for (entryPtr = tablePtr, i = 0; *entryPtr != NULL;
entryPtr = NEXT_ENTRY(entryPtr, offset), i++) {
for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
if (*p1 == '\0') {
index = i;
goto done;
}
}
if (*p1 == '\0') {
/*
* The value is an abbreviation for this entry. Continue
* checking other entries to make sure it's unique. If we
* get more than one unique abbreviation, keep searching to
* see if there is an exact match, but remember the number
* of unique abbreviations and don't allow either.
*/
numAbbrev++;
index = i;
}
}
/*
* Check if we were instructed to disallow abbreviations.
*/
if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)) {
goto error;
}
done:
/*
* Cache the found representation. Note that we want to avoid
* allocating a new internal-rep if at all possible since that is
* potentially a slow operation.
*/
if (objPtr->typePtr == &tclIndexType) {
indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
} else {
if ((objPtr->typePtr != NULL)
&& (objPtr->typePtr->freeIntRepProc != NULL)) {
objPtr->typePtr->freeIntRepProc(objPtr);
}
indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
objPtr->internalRep.otherValuePtr = (VOID *) indexRep;
objPtr->typePtr = &tclIndexType;
}
indexRep->tablePtr = (VOID*) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
*indexPtr = index;
return TCL_OK;
error:
if (interp != NULL) {
/*
* Produce a fancy error message.
*/
int count = 0;
TclNewObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
entryPtr = tablePtr;
while ((*entryPtr != NULL) && !**entryPtr) {
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) &&
!(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"",
key, "\": must be ", *entryPtr, (char*)NULL);
entryPtr = NEXT_ENTRY(entryPtr, offset);
while (*entryPtr != NULL) {
if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
Tcl_AppendStringsToObj(resultPtr,
(count > 0) ? ", or " : " or ", *entryPtr,
(char *) NULL);
} else if (**entryPtr) {
Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,
(char *) NULL);
count++;
}
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* SetIndexFromAny --
*
* This procedure is called to convert a Tcl object to index
* internal form. However, this doesn't make sense (need to have a
* table of keywords in order to do the conversion) so the
* procedure always generates an error.
*
* Results:
* The return value is always TCL_ERROR, and an error message is
* left in interp's result if interp isn't NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
SetIndexFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
if (interp) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"can't convert value to index except via Tcl_GetIndexFromObj API",
-1);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfIndex --
*
* This procedure is called to convert a Tcl object from index
* internal form to its string form. No abbreviation is ever
* generated.
*
* Results:
* None.
*
* Side effects:
* The string representation of the object is updated.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfIndex(objPtr)
Tcl_Obj *objPtr;
{
IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
register char *buf;
register unsigned len;
register CONST char *indexStr = EXPAND_OF(indexRep);
len = strlen(indexStr);
buf = (char *) ckalloc(len + 1);
memcpy(buf, indexStr, len+1);
objPtr->bytes = buf;
objPtr->length = len;
}
/*
*----------------------------------------------------------------------
*
* DupIndex --
*
* This procedure is called to copy the internal rep of an index
* Tcl object from to another object.
*
* Results:
* None.
*
* Side effects:
* The internal representation of the target object is updated
* and the type is set.
*
*----------------------------------------------------------------------
*/
static void
DupIndex(srcPtr, dupPtr)
Tcl_Obj *srcPtr, *dupPtr;
{
IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr;
IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep;
dupPtr->typePtr = &tclIndexType;
}
/*
*----------------------------------------------------------------------
*
* FreeIndex --
*
* This procedure is called to delete the internal rep of an index
* Tcl object.
*
* Results:
* None.
*
* Side effects:
* The internal representation of the target object is deleted.
*
*----------------------------------------------------------------------
*/
static void
FreeIndex(objPtr)
Tcl_Obj *objPtr;
{
ckfree((char *) objPtr->internalRep.otherValuePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_WrongNumArgs --
*
* This procedure generates a "wrong # args" error message in an
* interpreter. It is used as a utility function by many command
* procedures.
*
* Results:
* None.
*
* Side effects:
* An error message is generated in interp's result object to
* indicate that a command was invoked with the wrong number of
* arguments. The message has the form
* wrong # args: should be "foo bar additional stuff"
* where "foo" and "bar" are the initial objects in objv (objc
* determines how many of these are printed) and "additional stuff"
* is the contents of the message argument.
*
*----------------------------------------------------------------------
*/
void
Tcl_WrongNumArgs(interp, objc, objv, message)
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments to print
* from objv. */
Tcl_Obj *CONST objv[]; /* Initial argument objects, which
* should be included in the error
* message. */
CONST char *message; /* Error message to print after the
* leading objects in objv. The
* message may be NULL. */
{
Tcl_Obj *objPtr;
int i;
register IndexRep *indexRep;
TclNewObj(objPtr);
Tcl_SetObjResult(interp, objPtr);
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
for (i = 0; i < objc; i++) {
/*
* If the object is an index type use the index table which allows
* for the correct error message even if the subcommand was
* abbreviated. Otherwise, just use the string rep.
*/
if (objv[i]->typePtr == &tclIndexType) {
indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL);
} else {
Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]),
(char *) NULL);
}
/*
* Append a space character (" ") if there is more text to follow
* (either another element from objv, or the message string).
*/
if ((i < (objc - 1)) || message) {
Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
}
}
if (message) {
Tcl_AppendStringsToObj(objPtr, message, (char *) NULL);
}
Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
}
tcl8.4.20/generic/README 0000644 0036047 0045461 00000000273 12052456743 013213 0 ustar dgp 771div This directory contains Tcl source files that work on all the platforms
where Tcl runs (e.g. UNIX, PCs). Platform-specific
sources are in the directories ../unix, ../win, and ../macosx.
tcl8.4.20/generic/tclCmdAH.c 0000644 0036047 0045461 00000176712 12052456743 014132 0 ustar dgp 771div /*
* tclCmdAH.c --
*
* This file contains the top-level command routines for most of
* the Tcl built-in commands whose names begin with the letters
* A to H.
*
* Copyright (c) 1987-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.
*/
#ifndef _WIN64
/* See [Bug 3354324]: file mtime sets wrong time */
# define _USE_32BIT_TIME_T
#endif
#include
#include "tclInt.h"
#include "tclPort.h"
#include
/*
* Prototypes for local procedures defined in this file:
*/
static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, int mode));
static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_FSStatProc *statProc,
Tcl_StatBuf *statPtr));
static char * GetTypeFromMode _ANSI_ARGS_((int mode));
static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
char *varName, Tcl_StatBuf *statPtr));
/*
*----------------------------------------------------------------------
*
* Tcl_BreakObjCmd --
*
* This procedure is invoked to process the "break" Tcl command.
* See the user documentation for details on what it does.
*
* With the bytecode compiler, this procedure is only called when
* a command name is computed at runtime, and is "break" or the name
* to which "break" was renamed: e.g., "set z break; $z"
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_BreakObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return TCL_BREAK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CaseObjCmd --
*
* This procedure is invoked to process the "case" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_CaseObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register int i;
int body, result, caseObjc;
char *string, *arg;
Tcl_Obj *CONST *caseObjv;
Tcl_Obj *armPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"string ?in? patList body ... ?default body?");
return TCL_ERROR;
}
string = Tcl_GetString(objv[1]);
body = -1;
arg = Tcl_GetString(objv[2]);
if (strcmp(arg, "in") == 0) {
i = 3;
} else {
i = 2;
}
caseObjc = objc - i;
caseObjv = objv + i;
/*
* If all of the pattern/command pairs are lumped into a single
* argument, split them out again.
*/
if (caseObjc == 1) {
Tcl_Obj **newObjv;
Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
caseObjv = newObjv;
}
for (i = 0; i < caseObjc; i += 2) {
int patObjc, j;
CONST char **patObjv;
char *pat;
unsigned char *p;
if (i == (caseObjc - 1)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"extra case pattern with no body", -1);
return TCL_ERROR;
}
/*
* Check for special case of single pattern (no list) with
* no backslash sequences.
*/
pat = Tcl_GetString(caseObjv[i]);
for (p = (unsigned char *) pat; *p != '\0'; p++) {
if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */
break;
}
}
if (*p == '\0') {
if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
body = i + 1;
}
if (Tcl_StringMatch(string, pat)) {
body = i + 1;
goto match;
}
continue;
}
/*
* Break up pattern lists, then check each of the patterns
* in the list.
*/
result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
if (result != TCL_OK) {
return result;
}
for (j = 0; j < patObjc; j++) {
if (Tcl_StringMatch(string, patObjv[j])) {
body = i + 1;
break;
}
}
ckfree((char *) patObjv);
if (j < patObjc) {
break;
}
}
match:
if (body != -1) {
armPtr = caseObjv[body - 1];
result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
if (result == TCL_ERROR) {
char msg[100 + TCL_INTEGER_SPACE];
arg = Tcl_GetString(armPtr);
sprintf(msg,
"\n (\"%.50s\" arm line %d)", arg,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
return result;
}
/*
* Nothing matched: return nothing.
*/
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CatchObjCmd --
*
* This object-based procedure is invoked to process the "catch" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_CatchObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *varNamePtr = NULL;
int result;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
return TCL_ERROR;
}
if (objc == 3) {
varNamePtr = objv[2];
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[1], 0);
#else
/* TIP #280. Make invoking context available to caught script */
result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1);
#endif
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
Tcl_GetObjResult(interp), 0) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"couldn't save command result in variable", -1);
return TCL_ERROR;
}
}
/*
* Set the interpreter's object result to an integer object holding the
* integer Tcl_EvalObj result. Note that we don't bother generating a
* string representation. We reset the interpreter's object result
* to an unshared empty object and then set it to be an integer object.
*/
Tcl_ResetResult(interp);
Tcl_SetIntObj(Tcl_GetObjResult(interp), result);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CdObjCmd --
*
* This procedure is invoked to process the "cd" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_CdObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *dir;
int result;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?dirName?");
return TCL_ERROR;
}
if (objc == 2) {
dir = objv[1];
} else {
dir = Tcl_NewStringObj("~",1);
Tcl_IncrRefCount(dir);
}
if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) {
result = TCL_ERROR;
} else {
result = Tcl_FSChdir(dir);
if (result != TCL_OK) {
Tcl_AppendResult(interp, "couldn't change working directory to \"",
Tcl_GetString(dir), "\": ", Tcl_PosixError(interp), (char *) NULL);
result = TCL_ERROR;
}
}
if (objc != 2) {
Tcl_DecrRefCount(dir);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConcatObjCmd --
*
* This object-based procedure is invoked to process the "concat" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ConcatObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc >= 2) {
Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ContinueObjCmd -
*
* This procedure is invoked to process the "continue" Tcl command.
* See the user documentation for details on what it does.
*
* With the bytecode compiler, this procedure is only called when
* a command name is computed at runtime, and is "continue" or the name
* to which "continue" was renamed: e.g., "set z continue; $z"
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ContinueObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return TCL_CONTINUE;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EncodingObjCmd --
*
* This command manipulates encodings.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_EncodingObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int index, length;
Tcl_Encoding encoding;
char *string;
Tcl_DString ds;
Tcl_Obj *resultPtr;
static CONST char *optionStrings[] = {
"convertfrom", "convertto", "names", "system",
NULL
};
enum options {
ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case ENC_CONVERTTO:
case ENC_CONVERTFROM: {
Tcl_Obj *data;
if (objc == 3) {
encoding = Tcl_GetEncoding(interp, NULL);
data = objv[2];
} else if (objc == 4) {
if (TclGetEncodingFromObj(interp, objv[2], &encoding)
!= TCL_OK) {
return TCL_ERROR;
}
data = objv[3];
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
return TCL_ERROR;
}
if ((enum options) index == ENC_CONVERTFROM) {
/*
* Treat the string as binary data.
*/
string = (char *) Tcl_GetByteArrayFromObj(data, &length);
Tcl_ExternalToUtfDString(encoding, string, length, &ds);
/*
* Note that we cannot use Tcl_DStringResult here because
* it will truncate the string at the first null byte.
*/
Tcl_SetStringObj(Tcl_GetObjResult(interp),
Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
} else {
/*
* Store the result as binary data.
*/
string = Tcl_GetStringFromObj(data, &length);
Tcl_UtfToExternalDString(encoding, string, length, &ds);
resultPtr = Tcl_GetObjResult(interp);
Tcl_SetByteArrayObj(resultPtr,
(unsigned char *) Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
}
Tcl_FreeEncoding(encoding);
break;
}
case ENC_NAMES: {
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_GetEncodingNames(interp);
break;
}
case ENC_SYSTEM: {
if (objc > 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
return TCL_ERROR;
}
if (objc == 2) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
Tcl_GetEncodingName(NULL), -1);
} else {
return Tcl_SetSystemEncoding(interp,
Tcl_GetStringFromObj(objv[2], NULL));
}
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ErrorObjCmd --
*
* This procedure is invoked to process the "error" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ErrorObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
char *info;
int infoLen;
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
return TCL_ERROR;
}
if (objc >= 3) { /* process the optional info argument */
info = Tcl_GetStringFromObj(objv[2], &infoLen);
if (infoLen > 0) {
Tcl_AddObjErrorInfo(interp, info, infoLen);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
if (objc == 4) {
Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY);
iPtr->flags |= ERROR_CODE_SET;
}
Tcl_SetObjResult(interp, objv[1]);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalObjCmd --
*
* This object-based procedure is invoked to process the "eval" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_EvalObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result;
register Tcl_Obj *objPtr;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
return TCL_ERROR;
}
if (objc == 2) {
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);
#else
/* TIP #280. Make argument location available to eval'd script */
CmdFrame* invoker = iPtr->cmdFramePtr;
int word = 1;
TclArgumentGet (interp, objv[1], &invoker, &word);
result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
invoker, word);
#endif
} else {
/*
* More than one argument: concatenate them together with spaces
* between, then evaluate the result. Tcl_EvalObjEx will delete
* the object when it decrements its refcount after eval'ing it.
*/
objPtr = Tcl_ConcatObj(objc-1, objv+1);
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
#else
/* TIP #280. Make invoking context available to eval'd script */
result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
#endif
}
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ExitObjCmd --
*
* This procedure is invoked to process the "exit" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ExitObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int value;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
return TCL_ERROR;
}
if (objc == 1) {
value = 0;
} else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
return TCL_ERROR;
}
Tcl_Exit(value);
/*NOTREACHED*/
return TCL_OK; /* Better not ever reach this! */
}
/*
*----------------------------------------------------------------------
*
* Tcl_ExprObjCmd --
*
* This object-based procedure is invoked to process the "expr" Tcl
* command. See the user documentation for details on what it does.
*
* With the bytecode compiler, this procedure is called in two
* circumstances: 1) to execute expr commands that are too complicated
* or too unsafe to try compiling directly into an inline sequence of
* instructions, and 2) to execute commands where the command name is
* computed at runtime and is "expr" or the name to which "expr" was
* renamed (e.g., "set z expr; $z 2+3")
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ExprObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Tcl_Obj *objPtr;
Tcl_Obj *resultPtr;
register char *bytes;
int length, i, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
return TCL_ERROR;
}
if (objc == 2) {
result = Tcl_ExprObj(interp, objv[1], &resultPtr);
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr); /* done with the result object */
}
return result;
}
/*
* Create a new object holding the concatenated argument strings.
*/
/*** QUESTION: Do we need to copy the slow way? ***/
bytes = Tcl_GetStringFromObj(objv[1], &length);
objPtr = Tcl_NewStringObj(bytes, length);
Tcl_IncrRefCount(objPtr);
for (i = 2; i < objc; i++) {
Tcl_AppendToObj(objPtr, " ", 1);
bytes = Tcl_GetStringFromObj(objv[i], &length);
Tcl_AppendToObj(objPtr, bytes, length);
}
/*
* Evaluate the concatenated string object.
*/
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr); /* done with the result object */
}
/*
* Free allocated resources.
*/
Tcl_DecrRefCount(objPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FileObjCmd --
*
* This procedure is invoked to process the "file" Tcl command.
* See the user documentation for details on what it does.
* PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
* EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.
* With the object-based Tcl_FS APIs, the above NOTE may no
* longer be true. In any case this assertion should be tested.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_FileObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int index;
/*
* This list of constants should match the fileOption string array below.
*/
static CONST char *fileOptions[] = {
"atime", "attributes", "channels", "copy",
"delete",
"dirname", "executable", "exists", "extension",
"isdirectory", "isfile", "join", "link",
"lstat", "mtime", "mkdir", "nativename",
"normalize", "owned",
"pathtype", "readable", "readlink", "rename",
"rootname", "separator", "size", "split",
"stat", "system",
"tail", "type", "volumes", "writable",
(char *) NULL
};
enum options {
FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY,
FCMD_DELETE,
FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION,
FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK,
FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME,
FCMD_NORMALIZE, FCMD_OWNED,
FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME,
FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT,
FCMD_STAT, FCMD_SYSTEM,
FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case FCMD_ATIME: {
Tcl_StatBuf buf;
struct utimbuf tval;
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 4) {
long newTime;
if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
return TCL_ERROR;
}
tval.actime = newTime;
tval.modtime = buf.st_mtime;
if (Tcl_FSUtime(objv[2], &tval) != 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not set access time for file \"",
Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
/*
* Do another stat to ensure that the we return the
* new recognized atime - hopefully the same as the
* one we sent in. However, fs's like FAT don't
* even know what atime is.
*/
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_atime);
return TCL_OK;
}
case FCMD_ATTRIBUTES: {
return TclFileAttrsCmd(interp, objc, objv);
}
case FCMD_CHANNELS: {
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
return Tcl_GetChannelNamesEx(interp,
((objc == 2) ? NULL : Tcl_GetString(objv[2])));
}
case FCMD_COPY: {
return TclFileCopyCmd(interp, objc, objv);
}
case FCMD_DELETE: {
return TclFileDeleteCmd(interp, objc, objv);
}
case FCMD_DIRNAME: {
Tcl_Obj *dirPtr;
if (objc != 3) {
goto only3Args;
}
dirPtr = TclFileDirname(interp, objv[2]);
if (dirPtr == NULL) {
return TCL_ERROR;
} else {
Tcl_SetObjResult(interp, dirPtr);
Tcl_DecrRefCount(dirPtr);
return TCL_OK;
}
}
case FCMD_EXECUTABLE: {
if (objc != 3) {
goto only3Args;
}
return CheckAccess(interp, objv[2], X_OK);
}
case FCMD_EXISTS: {
if (objc != 3) {
goto only3Args;
}
return CheckAccess(interp, objv[2], F_OK);
}
case FCMD_EXTENSION: {
char *fileName, *extension;
if (objc != 3) {
goto only3Args;
}
fileName = Tcl_GetString(objv[2]);
extension = TclGetExtension(fileName);
if (extension != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), extension, -1);
}
return TCL_OK;
}
case FCMD_ISDIRECTORY: {
int value;
Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
value = 0;
if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
value = S_ISDIR(buf.st_mode);
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
return TCL_OK;
}
case FCMD_ISFILE: {
int value;
Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
value = 0;
if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
value = S_ISREG(buf.st_mode);
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
return TCL_OK;
}
case FCMD_JOIN: {
Tcl_Obj *resObj;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
return TCL_ERROR;
}
resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
Tcl_SetObjResult(interp, resObj);
return TCL_OK;
}
case FCMD_LINK: {
Tcl_Obj *contents;
int index;
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-linktype? linkname ?target?");
return TCL_ERROR;
}
/* Index of the 'source' argument */
if (objc == 5) {
index = 3;
} else {
index = 2;
}
if (objc > 3) {
int linkAction;
if (objc == 5) {
/* We have a '-linktype' argument */
static CONST char *linkTypes[] = {
"-symbolic", "-hard", NULL
};
if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes,
"switch", 0, &linkAction) != TCL_OK) {
return TCL_ERROR;
}
if (linkAction == 0) {
linkAction = TCL_CREATE_SYMBOLIC_LINK;
} else {
linkAction = TCL_CREATE_HARD_LINK;
}
} else {
linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
}
if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
/* Create link from source to target */
contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
if (contents == NULL) {
/*
* We handle two common error cases specially, and
* for all other errors, we use the standard posix
* error message.
*/
if (errno == EEXIST) {
Tcl_AppendResult(interp, "could not create new link \"",
Tcl_GetString(objv[index]),
"\": that path already exists", (char *) NULL);
} else if (errno == ENOENT) {
Tcl_AppendResult(interp, "could not create new link \"",
Tcl_GetString(objv[index]),
"\" since target \"",
Tcl_GetString(objv[index+1]),
"\" doesn't exist",
(char *) NULL);
} else {
Tcl_AppendResult(interp, "could not create new link \"",
Tcl_GetString(objv[index]), "\" pointing to \"",
Tcl_GetString(objv[index+1]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return TCL_ERROR;
}
} else {
if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
/* Read link */
contents = Tcl_FSLink(objv[index], NULL, 0);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not read link \"",
Tcl_GetString(objv[index]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, contents);
if (objc == 3) {
/*
* If we are reading a link, we need to free this
* result refCount. If we are creating a link, this
* will just be objv[index+1], and so we don't own it.
*/
Tcl_DecrRefCount(contents);
}
return TCL_OK;
}
case FCMD_LSTAT: {
char *varName;
Tcl_StatBuf buf;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "name varName");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
varName = Tcl_GetString(objv[3]);
return StoreStatData(interp, varName, &buf);
}
case FCMD_MTIME: {
Tcl_StatBuf buf;
struct utimbuf tval;
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 4) {
long newTime;
if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
return TCL_ERROR;
}
tval.actime = buf.st_atime;
tval.modtime = newTime;
if (Tcl_FSUtime(objv[2], &tval) != 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not set modification time for file \"",
Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
/*
* Do another stat to ensure that the we return the
* new recognized atime - hopefully the same as the
* one we sent in. However, fs's like FAT don't
* even know what atime is.
*/
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_mtime);
return TCL_OK;
}
case FCMD_MKDIR: {
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
return TCL_ERROR;
}
return TclFileMakeDirsCmd(interp, objc, objv);
}
case FCMD_NATIVENAME: {
CONST char *fileName;
Tcl_DString ds;
if (objc != 3) {
goto only3Args;
}
fileName = Tcl_GetString(objv[2]);
fileName = Tcl_TranslateFileName(interp, fileName, &ds);
if (fileName == NULL) {
return TCL_ERROR;
}
Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
return TCL_OK;
}
case FCMD_NORMALIZE: {
Tcl_Obj *fileName;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "filename");
return TCL_ERROR;
}
fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
if (fileName == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, fileName);
return TCL_OK;
}
case FCMD_OWNED: {
int value;
Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
value = 0;
if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
/*
* For Windows there are no user ids
* associated with a file, so we always return 1.
*/
#if defined(__WIN32__) || defined(__CYGWIN__)
value = 1;
#else
value = (geteuid() == buf.st_uid);
#endif
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
return TCL_OK;
}
case FCMD_PATHTYPE: {
if (objc != 3) {
goto only3Args;
}
switch (Tcl_FSGetPathType(objv[2])) {
case TCL_PATH_ABSOLUTE:
Tcl_SetStringObj(Tcl_GetObjResult(interp), "absolute", -1);
break;
case TCL_PATH_RELATIVE:
Tcl_SetStringObj(Tcl_GetObjResult(interp), "relative", -1);
break;
case TCL_PATH_VOLUME_RELATIVE:
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"volumerelative", -1);
break;
}
return TCL_OK;
}
case FCMD_READABLE: {
if (objc != 3) {
goto only3Args;
}
return CheckAccess(interp, objv[2], R_OK);
}
case FCMD_READLINK: {
Tcl_Obj *contents;
if (objc != 3) {
goto only3Args;
}
if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
return TCL_ERROR;
}
contents = Tcl_FSLink(objv[2], NULL, 0);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not readlink \"",
Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, contents);
Tcl_DecrRefCount(contents);
return TCL_OK;
}
case FCMD_RENAME: {
return TclFileRenameCmd(interp, objc, objv);
}
case FCMD_ROOTNAME: {
int length;
char *fileName, *extension;
if (objc != 3) {
goto only3Args;
}
fileName = Tcl_GetStringFromObj(objv[2], &length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
Tcl_SetObjResult(interp, objv[2]);
} else {
Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
(int) (length - strlen(extension)));
}
return TCL_OK;
}
case FCMD_SEPARATOR: {
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 2, objv, "?name?");
return TCL_ERROR;
}
if (objc == 2) {
char *separator = NULL; /* lint */
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separator = "/";
break;
case TCL_PLATFORM_WINDOWS:
separator = "\\";
break;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1));
} else {
Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
if (separatorObj != NULL) {
Tcl_SetObjResult(interp, separatorObj);
} else {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("Unrecognised path",-1));
return TCL_ERROR;
}
}
return TCL_OK;
}
case FCMD_SIZE: {
Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetWideIntObj(Tcl_GetObjResult(interp),
(Tcl_WideInt) buf.st_size);
return TCL_OK;
}
case FCMD_SPLIT: {
if (objc != 3) {
goto only3Args;
}
Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL));
return TCL_OK;
}
case FCMD_STAT: {
char *varName;
Tcl_StatBuf buf;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
varName = Tcl_GetString(objv[3]);
return StoreStatData(interp, varName, &buf);
}
case FCMD_SYSTEM: {
Tcl_Obj* fsInfo;
if (objc != 3) {
goto only3Args;
}
fsInfo = Tcl_FSFileSystemInfo(objv[2]);
if (fsInfo != NULL) {
Tcl_SetObjResult(interp, fsInfo);
return TCL_OK;
} else {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("Unrecognised path",-1));
return TCL_ERROR;
}
}
case FCMD_TAIL: {
int splitElements;
Tcl_Obj *splitPtr;
if (objc != 3) {
goto only3Args;
}
/*
* The behaviour we want here is slightly different to
* the standard Tcl_FSSplitPath in the handling of home
* directories; Tcl_FSSplitPath preserves the "~" while
* this code computes the actual full path name, if we
* had just a single component.
*/
splitPtr = Tcl_FSSplitPath(objv[2], &splitElements);
if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) {
Tcl_DecrRefCount(splitPtr);
splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]);
if (splitPtr == NULL) {
return TCL_ERROR;
}
splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
}
/*
* Return the last component, unless it is the only component,
* and it is the root of an absolute path.
*/
if (splitElements > 0) {
if ((splitElements > 1)
|| (Tcl_FSGetPathType(objv[2]) == TCL_PATH_RELATIVE)) {
Tcl_Obj *tail = NULL;
Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail);
Tcl_SetObjResult(interp, tail);
}
}
Tcl_DecrRefCount(splitPtr);
return TCL_OK;
}
case FCMD_TYPE: {
Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetStringObj(Tcl_GetObjResult(interp),
GetTypeFromMode((unsigned short) buf.st_mode), -1);
return TCL_OK;
}
case FCMD_VOLUMES: {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_FSListVolumes());
return TCL_OK;
}
case FCMD_WRITABLE: {
if (objc != 3) {
goto only3Args;
}
return CheckAccess(interp, objv[2], W_OK);
}
}
only3Args:
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
*
* CheckAccess --
*
* Utility procedure used by Tcl_FileObjCmd() to query file
* attributes available through the access() system call.
*
* Results:
* Always returns TCL_OK. Sets interp's result to boolean true or
* false depending on whether the file has the specified attribute.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static int
CheckAccess(interp, objPtr, mode)
Tcl_Interp *interp; /* Interp for status return. Must not be
* NULL. */
Tcl_Obj *objPtr; /* Name of file to check. */
int mode; /* Attribute to check; passed as argument to
* access(). */
{
int value;
if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
value = 0;
} else {
value = (Tcl_FSAccess(objPtr, mode) == 0);
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* GetStatBuf --
*
* Utility procedure used by Tcl_FileObjCmd() to query file
* attributes available through the stat() or lstat() system call.
*
* Results:
* The return value is TCL_OK if the specified file exists and can
* be stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an
* error message is left in interp's result. If TCL_OK is returned,
* *statPtr is filled with information about the specified file.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static int
GetStatBuf(interp, objPtr, statProc, statPtr)
Tcl_Interp *interp; /* Interp for error return. May be NULL. */
Tcl_Obj *objPtr; /* Path name to examine. */
Tcl_FSStatProc *statProc; /* Either stat() or lstat() depending on
* desired behavior. */
Tcl_StatBuf *statPtr; /* Filled with info about file obtained by
* calling (*statProc)(). */
{
int status;
if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
return TCL_ERROR;
}
status = (*statProc)(objPtr, statPtr);
if (status < 0) {
if (interp != NULL) {
Tcl_AppendResult(interp, "could not read \"",
Tcl_GetString(objPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StoreStatData --
*
* This is a utility procedure that breaks out the fields of a
* "stat" structure and stores them in textual form into the
* elements of an associative array.
*
* Results:
* Returns a standard Tcl return value. If an error occurs then
* a message is left in interp's result.
*
* Side effects:
* Elements of the associative array given by "varName" are modified.
*
*----------------------------------------------------------------------
*/
static int
StoreStatData(interp, varName, statPtr)
Tcl_Interp *interp; /* Interpreter for error reports. */
char *varName; /* Name of associative array variable
* in which to store stat results. */
Tcl_StatBuf *statPtr; /* Pointer to buffer containing
* stat data to store in varName. */
{
Tcl_Obj *var = Tcl_NewStringObj(varName, -1);
Tcl_Obj *field = Tcl_NewObj();
Tcl_Obj *value;
register unsigned short mode;
/*
* Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
*/
#define STORE_ARY(fieldName, object) \
Tcl_SetStringObj(field, (fieldName), -1); \
value = (object); \
if (Tcl_ObjSetVar2(interp,var,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \
Tcl_DecrRefCount(var); \
Tcl_DecrRefCount(field); \
Tcl_DecrRefCount(value); \
return TCL_ERROR; \
}
Tcl_IncrRefCount(var);
Tcl_IncrRefCount(field);
STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev));
/*
* Watch out porters; the inode is meant to be an *unsigned* value,
* so the cast might fail when there isn't a real arithmentic 'long
* long' type...
*/
STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink));
STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid));
STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid));
STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_ST_BLOCKS
STORE_ARY("blocks",Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
#endif
STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime));
STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime));
STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime));
mode = (unsigned short) statPtr->st_mode;
STORE_ARY("mode", Tcl_NewIntObj(mode));
STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ARY
Tcl_DecrRefCount(var);
Tcl_DecrRefCount(field);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetTypeFromMode --
*
* Given a mode word, returns a string identifying the type of a
* file.
*
* Results:
* A static text string giving the file type from mode.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static char *
GetTypeFromMode(mode)
int mode;
{
if (S_ISREG(mode)) {
return "file";
} else if (S_ISDIR(mode)) {
return "directory";
} else if (S_ISCHR(mode)) {
return "characterSpecial";
} else if (S_ISBLK(mode)) {
return "blockSpecial";
} else if (S_ISFIFO(mode)) {
return "fifo";
#ifdef S_ISLNK
} else if (S_ISLNK(mode)) {
return "link";
#endif
#ifdef S_ISSOCK
} else if (S_ISSOCK(mode)) {
return "socket";
#endif
}
return "unknown";
}
/*
*----------------------------------------------------------------------
*
* Tcl_ForObjCmd --
*
* This procedure is invoked to process the "for" Tcl command.
* See the user documentation for details on what it does.
*
* With the bytecode compiler, this procedure is only called when
* a command name is computed at runtime, and is "for" or the name
* to which "for" was renamed: e.g.,
* "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ForObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result, value;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
return TCL_ERROR;
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[1], 0);
#else
/* TIP #280. Make invoking context available to initial script */
result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1);
#endif
if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
}
return result;
}
while (1) {
/*
* We need to reset the result before passing it off to
* Tcl_ExprBooleanObj. Otherwise, any error message will be appended
* to the result of the last evaluation.
*/
Tcl_ResetResult(interp);
result = Tcl_ExprBooleanObj(interp, objv[2], &value);
if (result != TCL_OK) {
return result;
}
if (!value) {
break;
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[4], 0);
#else
/* TIP #280. Make invoking context available to loop body */
result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr,4);
#endif
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
break;
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[3], 0);
#else
/* TIP #280. Make invoking context available to next script */
result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3);
#endif
if (result == TCL_BREAK) {
break;
} else if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
}
return result;
}
}
if (result == TCL_BREAK) {
result = TCL_OK;
}
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ForeachObjCmd --
*
* This object-based procedure is invoked to process the "foreach" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ForeachObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result = TCL_OK;
int i; /* i selects a value list */
int j, maxj; /* Number of loop iterations */
int v; /* v selects a loop variable */
int numLists; /* Count of value lists */
Tcl_Obj *bodyPtr;
/*
* We copy the argument object pointers into a local array to avoid
* the problem that "objv" might become invalid. It is a pointer into
* the evaluation stack and that stack might be grown and reallocated
* if the loop body requires a large amount of stack space.
*/
#define NUM_ARGS 9
Tcl_Obj *(argObjStorage[NUM_ARGS]);
Tcl_Obj **argObjv = argObjStorage;
#define STATIC_LIST_SIZE 4
int indexArray[STATIC_LIST_SIZE];
int varcListArray[STATIC_LIST_SIZE];
Tcl_Obj **varvListArray[STATIC_LIST_SIZE];
int argcListArray[STATIC_LIST_SIZE];
Tcl_Obj **argvListArray[STATIC_LIST_SIZE];
int *index = indexArray; /* Array of value list indices */
int *varcList = varcListArray; /* # loop variables per list */
Tcl_Obj ***varvList = varvListArray; /* Array of var name lists */
int *argcList = argcListArray; /* Array of value list sizes */
Tcl_Obj ***argvList = argvListArray; /* Array of value lists */
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
if (objc < 4 || (objc%2 != 0)) {
Tcl_WrongNumArgs(interp, 1, objv,
"varList list ?varList list ...? command");
return TCL_ERROR;
}
/*
* Create the object argument array "argObjv". Make sure argObjv is
* large enough to hold the objc arguments.
*/
if (objc > NUM_ARGS) {
argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));
}
for (i = 0; i < objc; i++) {
argObjv[i] = objv[i];
}
/*
* Manage numList parallel value lists.
* argvList[i] is a value list counted by argcList[i]
* varvList[i] is the list of variables associated with the value list
* varcList[i] is the number of variables associated with the value list
* index[i] is the current pointer into the value list argvList[i]
*/
numLists = (objc-2)/2;
if (numLists > STATIC_LIST_SIZE) {
index = (int *) ckalloc(numLists * sizeof(int));
varcList = (int *) ckalloc(numLists * sizeof(int));
varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
argcList = (int *) ckalloc(numLists * sizeof(int));
argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
}
for (i = 0; i < numLists; i++) {
index[i] = 0;
varcList[i] = 0;
varvList[i] = (Tcl_Obj **) NULL;
argcList[i] = 0;
argvList[i] = (Tcl_Obj **) NULL;
}
/*
* Break up the value lists and variable lists into elements
*/
maxj = 0;
for (i = 0; i < numLists; i++) {
result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
&varcList[i], &varvList[i]);
if (result != TCL_OK) {
goto done;
}
if (varcList[i] < 1) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"foreach varlist is empty", -1);
result = TCL_ERROR;
goto done;
}
result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
&argcList[i], &argvList[i]);
if (result != TCL_OK) {
goto done;
}
j = argcList[i] / varcList[i];
if ((argcList[i] % varcList[i]) != 0) {
j++;
}
if (j > maxj) {
maxj = j;
}
}
/*
* Iterate maxj times through the lists in parallel
* If some value lists run out of values, set loop vars to ""
*/
bodyPtr = argObjv[objc-1];
for (j = 0; j < maxj; j++) {
for (i = 0; i < numLists; i++) {
/*
* Refetch the list members; we assume that the sizes are
* the same, but the array of elements might be different
* if the internal rep of the objects has been lost and
* recreated (it is too difficult to accurately tell when
* this happens, which can lead to some wierd crashes,
* like Bug #494348...)
*/
result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
&varcList[i], &varvList[i]);
if (result != TCL_OK) {
panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
}
result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
&argcList[i], &argvList[i]);
if (result != TCL_OK) {
panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
}
for (v = 0; v < varcList[i]; v++) {
int k = index[i]++;
Tcl_Obj *valuePtr, *varValuePtr;
if (k < argcList[i]) {
valuePtr = argvList[i][k];
} else {
valuePtr = Tcl_NewObj(); /* empty string */
}
Tcl_IncrRefCount(valuePtr);
varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v],
NULL, valuePtr, 0);
Tcl_DecrRefCount(valuePtr);
if (varValuePtr == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't set loop variable: \"",
Tcl_GetString(varvList[i][v]), "\"", (char *) NULL);
result = TCL_ERROR;
goto done;
}
}
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, bodyPtr, 0);
#else
/* TIP #280. Make invoking context available to loop body */
result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr,objc-1);
#endif
if (result != TCL_OK) {
if (result == TCL_CONTINUE) {
result = TCL_OK;
} else if (result == TCL_BREAK) {
result = TCL_OK;
break;
} else if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"foreach\" body line %d)",
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
break;
} else {
break;
}
}
}
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
done:
if (numLists > STATIC_LIST_SIZE) {
ckfree((char *) index);
ckfree((char *) varcList);
ckfree((char *) argcList);
ckfree((char *) varvList);
ckfree((char *) argvList);
}
if (argObjv != argObjStorage) {
ckfree((char *) argObjv);
}
return result;
#undef STATIC_LIST_SIZE
#undef NUM_ARGS
}
/*
*----------------------------------------------------------------------
*
* Tcl_FormatObjCmd --
*
* This procedure is invoked to process the "format" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_FormatObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *format; /* Used to read characters from the format
* string. */
int formatLen; /* The length of the format string */
char *endPtr; /* Points to the last char in format array */
char newFormat[43]; /* A new format specifier is generated here. */
int width; /* Field width from field specifier, or 0 if
* no width given. */
int precision; /* Field precision from field specifier, or 0
* if no precision given. */
int size; /* Number of bytes needed for result of
* conversion, based on type of conversion
* ("e", "s", etc.), width, and precision. */
long intValue; /* Used to hold value to pass to sprintf, if
* it's a one-word integer or char value */
char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if
* it's a one-word value. */
double doubleValue; /* Used to hold value to pass to sprintf if
* it's a double value. */
Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if
* it's a 'long long' value. */
int whichValue; /* Indicates which of intValue, ptrValue,
* or doubleValue has the value to pass to
* sprintf, according to the following
* definitions: */
# define INT_VALUE 0
# define CHAR_VALUE 1
# define PTR_VALUE 2
# define DOUBLE_VALUE 3
# define STRING_VALUE 4
# define WIDE_VALUE 5
# define MAX_FLOAT_SIZE 320
Tcl_Obj *resultPtr; /* Where result is stored finally. */
char staticBuf[MAX_FLOAT_SIZE + 1];
/* A static buffer to copy the format results
* into */
char *dst = staticBuf; /* The buffer that sprintf writes into each
* time the format processes a specifier */
int dstSize = MAX_FLOAT_SIZE;
/* The size of the dst buffer */
int noPercent; /* Special case for speed: indicates there's
* no field specifier, just a string to copy.*/
int objIndex; /* Index of argument to substitute next. */
int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style
* specifier has been seen. */
int gotSequential = 0; /* Non-zero means that a regular sequential
* (non-XPG3) conversion specifier has been
* seen. */
int useShort; /* Value to be printed is short (half word). */
char *end; /* Used to locate end of numerical fields. */
int stringLen = 0; /* Length of string in characters rather
* than bytes. Used for %s substitution. */
int gotMinus; /* Non-zero indicates that a minus flag has
* been seen in the current field. */
int gotPrecision; /* Non-zero indicates that a precision has
* been set for the current field. */
int gotZero; /* Non-zero indicates that a zero flag has
* been seen in the current field. */
int useWide; /* Value to be printed is Tcl_WideInt. */
/*
* This procedure is a bit nasty. The goal is to use sprintf to
* do most of the dirty work. There are several problems:
* 1. this procedure can't trust its arguments.
* 2. we must be able to provide a large enough result area to hold
* whatever's generated. This is hard to estimate.
* 3. there's no way to move the arguments from objv to the call
* to sprintf in a reasonable way. This is particularly nasty
* because some of the arguments may be two-word values (doubles
* and wide-ints).
* So, what happens here is to scan the format string one % group
* at a time, making many individual calls to sprintf.
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
return TCL_ERROR;
}
format = Tcl_GetStringFromObj(objv[1], &formatLen);
endPtr = format + formatLen;
resultPtr = Tcl_NewObj();
objIndex = 2;
while (format < endPtr) {
register char *newPtr = newFormat;
width = precision = noPercent = useShort = 0;
gotZero = gotMinus = gotPrecision = 0;
useWide = 0;
whichValue = PTR_VALUE;
/*
* Get rid of any characters before the next field specifier.
*/
if (*format != '%') {
ptrValue = format;
while ((*format != '%') && (format < endPtr)) {
format++;
}
size = format - ptrValue;
noPercent = 1;
goto doField;
}
if (format[1] == '%') {
ptrValue = format;
size = 1;
noPercent = 1;
format += 2;
goto doField;
}
/*
* Parse off a field specifier, compute how many characters
* will be needed to store the result, and substitute for
* "*" size specifiers.
*/
*newPtr = '%';
newPtr++;
format++;
if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
int tmp;
/*
* Check for an XPG3-style %n$ specification. Note: there
* must not be a mixture of XPG3 specs and non-XPG3 specs
* in the same format string.
*/
tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */
if (*end != '$') {
goto notXpg;
}
format = end+1;
gotXpg = 1;
if (gotSequential) {
goto mixedXPG;
}
objIndex = tmp+1;
if ((objIndex < 2) || (objIndex >= objc)) {
goto badIndex;
}
goto xpgCheckDone;
}
notXpg:
gotSequential = 1;
if (gotXpg) {
goto mixedXPG;
}
xpgCheckDone:
while ((*format == '-') || (*format == '#') || (*format == '0')
|| (*format == ' ') || (*format == '+')) {
if (*format == '-') {
gotMinus = 1;
}
if (*format == '0') {
/*
* This will be handled by sprintf for numbers, but we
* need to do the char/string ones ourselves
*/
gotZero = 1;
}
*newPtr = *format;
newPtr++;
format++;
}
if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
width = strtoul(format, &end, 10); /* INTL: Tcl source. */
format = end;
} else if (*format == '*') {
if (objIndex >= objc) {
goto badIndex;
}
if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &width) != TCL_OK) {
goto fmtError;
}
if (width < 0) {
width = -width;
*newPtr = '-';
gotMinus = 1;
newPtr++;
}
objIndex++;
format++;
}
if (width > 100000) {
/*
* Don't allow arbitrarily large widths: could cause core
* dump when we try to allocate a zillion bytes of memory
* below.
*/
width = 100000;
} else if (width < 0) {
width = 0;
}
if (width != 0) {
TclFormatInt(newPtr, width); /* INTL: printf format. */
while (*newPtr != 0) {
newPtr++;
}
}
if (*format == '.') {
*newPtr = '.';
newPtr++;
format++;
gotPrecision = 1;
}
if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
precision = strtoul(format, &end, 10); /* INTL: "C" locale. */
format = end;
} else if (*format == '*') {
if (objIndex >= objc) {
goto badIndex;
}
if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &precision) != TCL_OK) {
goto fmtError;
}
objIndex++;
format++;
}
if (gotPrecision) {
TclFormatInt(newPtr, precision); /* INTL: printf format. */
while (*newPtr != 0) {
newPtr++;
}
}
if (*format == 'l') {
useWide = 1;
/*
* Only add a 'll' modifier for integer values as it makes
* some libc's go into spasm otherwise. [Bug #702622]
*/
switch (format[1]) {
case 'i':
case 'd':
case 'o':
case 'u':
case 'x':
case 'X':
strcpy(newPtr, TCL_LL_MODIFIER);
newPtr += TCL_LL_MODIFIER_SIZE;
}
format++;
} else if (*format == 'h') {
useShort = 1;
*newPtr = 'h';
newPtr++;
format++;
}
*newPtr = *format;
newPtr++;
*newPtr = 0;
if (objIndex >= objc) {
goto badIndex;
}
switch (*format) {
case 'i':
newPtr[-1] = 'd';
case 'd':
case 'o':
case 'u':
case 'x':
case 'X':
if (useWide) {
if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &wideValue) != TCL_OK) {
goto fmtError;
}
whichValue = WIDE_VALUE;
size = 40 + precision;
break;
}
if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &intValue) != TCL_OK) {
if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &wideValue) != TCL_OK) {
goto fmtError;
}
intValue = Tcl_WideAsLong(wideValue);
}
#if (LONG_MAX > INT_MAX)
if (!useShort) {
/*
* Add the 'l' for long format type because we are on an
* LP64 archtecture and we are really going to pass a long
* argument to sprintf.
*
* Do not add this if we're going to pass in a short (i.e.
* if we've got an 'h' modifier already in the string); some
* libc implementations of sprintf() do not like it at all.
* [Bug 1154163]
*/
newPtr++;
*newPtr = 0;
newPtr[-1] = newPtr[-2];
newPtr[-2] = 'l';
}
#endif /* LONG_MAX > INT_MAX */
whichValue = INT_VALUE;
size = 40 + precision;
break;
case 's':
/*
* Compute the length of the string in characters and add
* any additional space required by the field width. All
* of the extra characters will be spaces, so one byte per
* character is adequate.
*/
whichValue = STRING_VALUE;
ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
stringLen = Tcl_NumUtfChars(ptrValue, size);
if (gotPrecision && (precision < stringLen)) {
stringLen = precision;
}
size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
if (width > stringLen) {
size += (width - stringLen);
}
break;
case 'c':
if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &intValue) != TCL_OK) {
goto fmtError;
}
whichValue = CHAR_VALUE;
size = width + TCL_UTF_MAX;
break;
case 'e':
case 'E':
case 'f':
case 'g':
case 'G':
if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &doubleValue) != TCL_OK) {
goto fmtError;
}
whichValue = DOUBLE_VALUE;
size = MAX_FLOAT_SIZE;
if (precision > 10) {
size += precision;
}
break;
case 0:
Tcl_SetResult(interp,
"format string ended in middle of field specifier",
TCL_STATIC);
goto fmtError;
default:
{
char buf[40];
sprintf(buf, "bad field specifier \"%c\"", *format);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
goto fmtError;
}
}
objIndex++;
format++;
/*
* Make sure that there's enough space to hold the formatted
* result, then format it.
*/
doField:
if (width > size) {
size = width;
}
if (noPercent) {
Tcl_AppendToObj(resultPtr, ptrValue, size);
} else {
if (size > dstSize) {
if (dst != staticBuf) {
ckfree(dst);
}
dst = (char *) ckalloc((unsigned) (size + 1));
dstSize = size;
}
switch (whichValue) {
case DOUBLE_VALUE:
sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */
break;
case WIDE_VALUE:
sprintf(dst, newFormat, wideValue);
break;
case INT_VALUE:
if (useShort) {
sprintf(dst, newFormat, (short) intValue);
} else {
sprintf(dst, newFormat, intValue);
}
break;
case CHAR_VALUE: {
char *ptr;
char padChar = (gotZero ? '0' : ' ');
ptr = dst;
if (!gotMinus) {
for ( ; --width > 0; ptr++) {
*ptr = padChar;
}
}
ptr += Tcl_UniCharToUtf(intValue, ptr);
for ( ; --width > 0; ptr++) {
*ptr = padChar;
}
*ptr = '\0';
break;
}
case STRING_VALUE: {
char *ptr;
char padChar = (gotZero ? '0' : ' ');
int pad;
ptr = dst;
if (width > stringLen) {
pad = width - stringLen;
} else {
pad = 0;
}
if (!gotMinus) {
while (pad > 0) {
*ptr++ = padChar;
pad--;
}
}
size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
if (size) {
memcpy(ptr, ptrValue, (size_t) size);
ptr += size;
}
while (pad > 0) {
*ptr++ = padChar;
pad--;
}
*ptr = '\0';
break;
}
default:
sprintf(dst, newFormat, ptrValue);
break;
}
Tcl_AppendToObj(resultPtr, dst, -1);
}
}
Tcl_SetObjResult(interp, resultPtr);
if (dst != staticBuf) {
ckfree(dst);
}
return TCL_OK;
mixedXPG:
Tcl_SetResult(interp,
"cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
goto fmtError;
badIndex:
if (gotXpg) {
Tcl_SetResult(interp,
"\"%n$\" argument index out of range", TCL_STATIC);
} else {
Tcl_SetResult(interp,
"not enough arguments for all format specifiers", TCL_STATIC);
}
fmtError:
if (dst != staticBuf) {
ckfree(dst);
}
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclThreadJoin.c 0000644 0036047 0045461 00000023070 12052456744 015232 0 ustar dgp 771div /*
* tclThreadJoin.c --
*
* This file implements a platform independent emulation layer for
* the handling of joinable threads. The Mac and Windows platforms
* use this code to provide the functionality of joining threads.
* This code is currently not necessary on Unix.
*
* Copyright (c) 2000 by Scriptics Corporation
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#if defined(WIN32)
/* The information about each joinable thread is remembered in a
* structure as defined below.
*/
typedef struct JoinableThread {
Tcl_ThreadId id; /* The id of the joinable thread */
int result; /* A place for the result after the
* demise of the thread */
int done; /* Boolean flag. Initialized to 0
* and set to 1 after the exit of
* the thread. This allows a thread
* requesting a join to detect when
* waiting is not necessary. */
int waitedUpon; /* Boolean flag. Initialized to 0
* and set to 1 by the thread waiting
* for this one via Tcl_JoinThread.
* Used to lock any other thread
* trying to wait on this one.
*/
Tcl_Mutex threadMutex; /* The mutex used to serialize access
* to this structure. */
Tcl_Condition cond; /* This is the condition a thread has
* to wait upon to get notified of the
* end of the described thread. It is
* signaled indirectly by
* Tcl_ExitThread. */
struct JoinableThread* nextThreadPtr; /* Reference to the next thread in the
* list of joinable threads */
} JoinableThread;
/* The following variable is used to maintain the global list of all
* joinable threads. Usage by a thread is allowed only if the
* thread acquired the 'joinMutex'.
*/
TCL_DECLARE_MUTEX(joinMutex)
static JoinableThread* firstThreadPtr;
/*
*----------------------------------------------------------------------
*
* TclJoinThread --
*
* This procedure waits for the exit of the thread with the specified
* id and returns its result.
*
* Results:
* A standard tcl result signaling the overall success/failure of the
* operation and an integer result delivered by the thread which was
* waited upon.
*
* Side effects:
* Deallocates the memory allocated by TclRememberJoinableThread.
* Removes the data associated to the thread waited upon from the
* list of joinable threads.
*
*----------------------------------------------------------------------
*/
int
TclJoinThread(id, result)
Tcl_ThreadId id; /* The id of the thread to wait upon. */
int* result; /* Reference to a location for the result
* of the thread we are waiting upon. */
{
/* Steps done here:
* i. Acquire the joinMutex and search for the thread.
* ii. Error out if it could not be found.
* iii. If found, switch from exclusive access to the list to exclusive
* access to the thread structure.
* iv. Error out if some other is already waiting.
* v. Skip the waiting part of the thread is already done.
* vi. Wait for the thread to exit, mark it as waited upon too.
* vii. Get the result form the structure,
* viii. switch to exclusive access of the list,
* ix. remove the structure from the list,
* x. then switch back to exclusive access to the structure
* xi. and delete it.
*/
JoinableThread* threadPtr;
Tcl_MutexLock (&joinMutex);
for (threadPtr = firstThreadPtr;
(threadPtr != (JoinableThread*) NULL) && (threadPtr->id != id);
threadPtr = threadPtr->nextThreadPtr)
/* empty body */
;
if (threadPtr == (JoinableThread*) NULL) {
/* Thread not found. Either not joinable, or already waited
* upon and exited. Whatever, an error is in order.
*/
Tcl_MutexUnlock (&joinMutex);
return TCL_ERROR;
}
/* [1] If we don't lock the structure before giving up exclusive access
* to the list some other thread just completing its wait on the same
* thread can delete the structure from under us, leaving us with a
* dangling pointer.
*/
Tcl_MutexLock (&threadPtr->threadMutex);
Tcl_MutexUnlock (&joinMutex);
/* [2] Now that we have the structure mutex any other thread that just
* tries to delete structure will wait at location [3] until we are
* done with the structure. And in that case we are done with it
* rather quickly as 'waitedUpon' will be set and we will have to
* error out.
*/
if (threadPtr->waitedUpon) {
Tcl_MutexUnlock (&threadPtr->threadMutex);
return TCL_ERROR;
}
/* We are waiting now, let other threads recognize this
*/
threadPtr->waitedUpon = 1;
while (!threadPtr->done) {
Tcl_ConditionWait (&threadPtr->cond, &threadPtr->threadMutex, NULL);
}
/* We have to release the structure before trying to access the list
* again or we can run into deadlock with a thread at [1] (see above)
* because of us holding the structure and the other holding the list.
* There is no problem with dangling pointers here as 'waitedUpon == 1'
* is still valid and any other thread will error out and not come to
* this place. IOW, the fact that we are here also means that no other
* thread came here before us and is able to delete the structure.
*/
Tcl_MutexUnlock (&threadPtr->threadMutex);
Tcl_MutexLock (&joinMutex);
/* We have to search the list again as its structure may (may, almost
* certainly) have changed while we were waiting. Especially now is the
* time to compute the predecessor in the list. Any earlier result can
* be dangling by now.
*/
if (firstThreadPtr == threadPtr) {
firstThreadPtr = threadPtr->nextThreadPtr;
} else {
JoinableThread* prevThreadPtr;
for (prevThreadPtr = firstThreadPtr;
prevThreadPtr->nextThreadPtr != threadPtr;
prevThreadPtr = prevThreadPtr->nextThreadPtr)
/* empty body */
;
prevThreadPtr->nextThreadPtr = threadPtr->nextThreadPtr;
}
Tcl_MutexUnlock (&joinMutex);
/* [3] Now that the structure is not part of the list anymore no other
* thread can acquire its mutex from now on. But it is possible that
* another thread is still holding the mutex though, see location [2].
* So we have to acquire the mutex one more time to wait for that thread
* to finish. We can (and have to) release the mutex immediately.
*/
Tcl_MutexLock (&threadPtr->threadMutex);
Tcl_MutexUnlock (&threadPtr->threadMutex);
/* Copy the result to us, finalize the synchronisation objects, then
* free the structure and return.
*/
*result = threadPtr->result;
Tcl_ConditionFinalize (&threadPtr->cond);
Tcl_MutexFinalize (&threadPtr->threadMutex);
ckfree ((VOID*) threadPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclRememberJoinableThread --
*
* This procedure remebers a thread as joinable. Only a call to
* TclJoinThread will remove the structre created (and initialized)
* here. IOW, not waiting upon a joinable thread will cause memory
* leaks.
*
* Results:
* None.
*
* Side effects:
* Allocates memory, adds it to the global list of all joinable
* threads.
*
*----------------------------------------------------------------------
*/
VOID
TclRememberJoinableThread(id)
Tcl_ThreadId id; /* The thread to remember as joinable */
{
JoinableThread* threadPtr;
threadPtr = (JoinableThread*) ckalloc (sizeof (JoinableThread));
threadPtr->id = id;
threadPtr->done = 0;
threadPtr->waitedUpon = 0;
threadPtr->threadMutex = (Tcl_Mutex) NULL;
threadPtr->cond = (Tcl_Condition) NULL;
Tcl_MutexLock (&joinMutex);
threadPtr->nextThreadPtr = firstThreadPtr;
firstThreadPtr = threadPtr;
Tcl_MutexUnlock (&joinMutex);
}
/*
*----------------------------------------------------------------------
*
* TclSignalExitThread --
*
* This procedure signals that the specified thread is done with
* its work. If the thread is joinable this signal is propagated
* to the thread waiting upon it.
*
* Results:
* None.
*
* Side effects:
* Modifies the associated structure to hold the result.
*
*----------------------------------------------------------------------
*/
VOID
TclSignalExitThread(id,result)
Tcl_ThreadId id; /* Id of the thread signaling its exit */
int result; /* The result from the thread */
{
JoinableThread* threadPtr;
Tcl_MutexLock (&joinMutex);
for (threadPtr = firstThreadPtr;
(threadPtr != (JoinableThread*) NULL) && (threadPtr->id != id);
threadPtr = threadPtr->nextThreadPtr)
/* empty body */
;
if (threadPtr == (JoinableThread*) NULL) {
/* Thread not found. Not joinable. No problem, nothing to do.
*/
Tcl_MutexUnlock (&joinMutex);
return;
}
/* Switch over the exclusive access from the list to the structure,
* then store the result, set the flag and notify the waiting thread,
* provided that it exists. The order of lock/unlock ensures that a
* thread entering 'TclJoinThread' will not interfere with us.
*/
Tcl_MutexLock (&threadPtr->threadMutex);
Tcl_MutexUnlock (&joinMutex);
threadPtr->done = 1;
threadPtr->result = result;
if (threadPtr->waitedUpon) {
Tcl_ConditionNotify (&threadPtr->cond);
}
Tcl_MutexUnlock (&threadPtr->threadMutex);
}
#endif /* WIN32 */
tcl8.4.20/generic/tclEncoding.c 0000644 0036047 0045461 00000267732 12052456743 014747 0 ustar dgp 771div /*
* tclEncoding.c --
*
* Contains the implementation of the encoding conversion package.
*
* Copyright (c) 1996-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.
*/
#include "tclInt.h"
#include "tclPort.h"
typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src));
/*
* The following data structure represents an encoding, which describes how
* to convert between various character sets and UTF-8.
*/
typedef struct Encoding {
char *name; /* Name of encoding. Malloced because (1)
* hash table entry that owns this encoding
* may be freed prior to this encoding being
* freed, (2) string passed in the
* Tcl_EncodingType structure may not be
* persistent. */
Tcl_EncodingConvertProc *toUtfProc;
/* Procedure to convert from external
* encoding into UTF-8. */
Tcl_EncodingConvertProc *fromUtfProc;
/* Procedure to convert from UTF-8 into
* external encoding. */
Tcl_EncodingFreeProc *freeProc;
/* If non-NULL, procedure to call when this
* encoding is deleted. */
int nullSize; /* Number of 0x00 bytes that signify
* end-of-string in this encoding. This
* number is used to determine the source
* string length when the srcLen argument is
* negative. This number can be 1 or 2. */
ClientData clientData; /* Arbitrary value associated with encoding
* type. Passed to conversion procedures. */
LengthProc *lengthProc; /* Function to compute length of
* null-terminated strings in this encoding.
* If nullSize is 1, this is strlen; if
* nullSize is 2, this is a function that
* returns the number of bytes in a 0x0000
* terminated string. */
int refCount; /* Number of uses of this structure. */
Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */
} Encoding;
/*
* The following structure is the clientData for a dynamically-loaded,
* table-driven encoding created by LoadTableEncoding(). It maps between
* Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only)
* encoding.
*/
typedef struct TableEncodingData {
int fallback; /* Character (in this encoding) to
* substitute when this encoding cannot
* represent a UTF-8 character. */
char prefixBytes[256]; /* If a byte in the input stream is a lead
* byte for a 2-byte sequence, the
* corresponding entry in this array is 1,
* otherwise it is 0. */
unsigned short **toUnicode; /* Two dimensional sparse matrix to map
* characters from the encoding to Unicode.
* Each element of the toUnicode array points
* to an array of 256 shorts. If there is no
* corresponding character in Unicode, the
* value in the matrix is 0x0000. malloc'd. */
unsigned short **fromUnicode;
/* Two dimensional sparse matrix to map
* characters from Unicode to the encoding.
* Each element of the fromUnicode array
* points to an array of 256 shorts. If there
* is no corresponding character the encoding,
* the value in the matrix is 0x0000.
* malloc'd. */
} TableEncodingData;
/*
* The following structures is the clientData for a dynamically-loaded,
* escape-driven encoding that is itself comprised of other simpler
* encodings. An example is "iso-2022-jp", which uses escape sequences to
* switch between ascii, jis0208, jis0212, gb2312, and ksc5601. Note that
* "escape-driven" does not necessarily mean that the ESCAPE character is
* the character used for switching character sets.
*/
typedef struct EscapeSubTable {
unsigned int sequenceLen; /* Length of following string. */
char sequence[16]; /* Escape code that marks this encoding. */
char name[32]; /* Name for encoding. */
Encoding *encodingPtr; /* Encoding loaded using above name, or NULL
* if this sub-encoding has not been needed
* yet. */
} EscapeSubTable;
typedef struct EscapeEncodingData {
int fallback; /* Character (in this encoding) to
* substitute when this encoding cannot
* represent a UTF-8 character. */
unsigned int initLen; /* Length of following string. */
char init[16]; /* String to emit or expect before first char
* in conversion. */
unsigned int finalLen; /* Length of following string. */
char final[16]; /* String to emit or expect after last char
* in conversion. */
char prefixBytes[256]; /* If a byte in the input stream is the
* first character of one of the escape
* sequences in the following array, the
* corresponding entry in this array is 1,
* otherwise it is 0. */
int numSubTables; /* Length of following array. */
EscapeSubTable subTables[1];/* Information about each EscapeSubTable
* used by this encoding type. The actual
* size will be as large as necessary to
* hold all EscapeSubTables. */
} EscapeEncodingData;
/*
* Constants used when loading an encoding file to identify the type of the
* file.
*/
#define ENCODING_SINGLEBYTE 0
#define ENCODING_DOUBLEBYTE 1
#define ENCODING_MULTIBYTE 2
#define ENCODING_ESCAPE 3
/*
* Initialize the default encoding directory. If this variable contains
* a non NULL value, it will be the first path used to locate the
* system encoding files.
*/
char *tclDefaultEncodingDir = NULL;
static int encodingsInitialized = 0;
/*
* Hash table that keeps track of all loaded Encodings. Keys are
* the string names that represent the encoding, values are (Encoding *).
*/
static Tcl_HashTable encodingTable;
TCL_DECLARE_MUTEX(encodingMutex)
/*
* The following are used to hold the default and current system encodings.
* If NULL is passed to one of the conversion routines, the current setting
* of the system encoding will be used to perform the conversion.
*/
static Tcl_Encoding defaultEncoding;
static Tcl_Encoding systemEncoding;
/*
* The following variable is used in the sparse matrix code for a
* TableEncoding to represent a page in the table that has no entries.
*/
static unsigned short emptyPage[256];
/*
* Procedures used only in this module.
*/
static int BinaryProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static void DupEncodingIntRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr));
static void EscapeFreeProc _ANSI_ARGS_((ClientData clientData));
static int EscapeFromUtfProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static int EscapeToUtfProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static void FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding));
static void FreeEncodingIntRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static Encoding * GetTableEncoding _ANSI_ARGS_((
EscapeEncodingData *dataPtr, int state));
static Tcl_Encoding LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name));
static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name, int type, Tcl_Channel chan));
static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name,
Tcl_Channel chan));
static Tcl_Channel OpenEncodingFile _ANSI_ARGS_((CONST char *dir,
CONST char *name));
static void TableFreeProc _ANSI_ARGS_((ClientData clientData));
static int TableFromUtfProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static int TableToUtfProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static size_t unilen _ANSI_ARGS_((CONST char *src));
static int UnicodeToUtfProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static int UtfToUnicodeProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static int UtfToUtfProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr, int pureNullMode));
static int UtfIntToUtfExtProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static int UtfExtToUtfIntProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static int TclFindEncodings _ANSI_ARGS_((CONST char *argv0));
/*
* A Tcl_ObjType for holding a cached Tcl_Encoding as the intrep.
* This should help the lifetime of encodings be more useful.
* See concerns raised in [Bug 1077262].
*/
static Tcl_ObjType EncodingType = {
"encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL
};
/*
*----------------------------------------------------------------------
*
* TclGetEncodingFromObj --
*
* Writes to (*encodingPtr) the Tcl_Encoding value of (*objPtr),
* if possible, and returns TCL_OK. If no such encoding exists,
* TCL_ERROR is returned, and if interp is non-NULL, an error message
* is written there.
*
* Results:
* Standard Tcl return code.
*
* Side effects:
* Caches the Tcl_Encoding value as the internal rep of (*objPtr).
*
*----------------------------------------------------------------------
*/
int
TclGetEncodingFromObj(interp, objPtr, encodingPtr)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
Tcl_Encoding *encodingPtr;
{
CONST char *name = Tcl_GetString(objPtr);
if (objPtr->typePtr != &EncodingType) {
Tcl_Encoding encoding = Tcl_GetEncoding(interp, name);
if (encoding == NULL) {
return TCL_ERROR;
}
if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc) {
objPtr->typePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.otherValuePtr = (VOID *) encoding;
objPtr->typePtr = &EncodingType;
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeEncodingIntRep --
*
* The Tcl_FreeInternalRepProc for the "encoding" Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
static void
FreeEncodingIntRep(objPtr)
Tcl_Obj *objPtr;
{
Tcl_FreeEncoding((Tcl_Encoding) objPtr->internalRep.otherValuePtr);
}
/*
*----------------------------------------------------------------------
*
* DupEncodingIntRep --
*
* The Tcl_DupInternalRepProc for the "encoding" Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
static void
DupEncodingIntRep(srcPtr, dupPtr)
Tcl_Obj *srcPtr;
Tcl_Obj *dupPtr;
{
dupPtr->internalRep.otherValuePtr = (VOID *)
Tcl_GetEncoding(NULL, srcPtr->bytes);
}
/*
*---------------------------------------------------------------------------
*
* TclInitEncodingSubsystem --
*
* Initialize all resources used by this subsystem on a per-process
* basis.
*
* Results:
* None.
*
* Side effects:
* Depends on the memory, object, and IO subsystems.
*
*---------------------------------------------------------------------------
*/
void
TclInitEncodingSubsystem()
{
Tcl_EncodingType type;
Tcl_MutexLock(&encodingMutex);
Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&encodingMutex);
/*
* Create a few initial encodings. Note that the UTF-8 to UTF-8
* translation is not a no-op, because it will turn a stream of
* improperly formed UTF-8 into a properly formed stream.
*/
type.encodingName = "identity";
type.toUtfProc = BinaryProc;
type.fromUtfProc = BinaryProc;
type.freeProc = NULL;
type.nullSize = 1;
type.clientData = NULL;
defaultEncoding = Tcl_CreateEncoding(&type);
systemEncoding = Tcl_GetEncoding(NULL, type.encodingName);
type.encodingName = "utf-8";
type.toUtfProc = UtfExtToUtfIntProc;
type.fromUtfProc = UtfIntToUtfExtProc;
type.freeProc = NULL;
type.nullSize = 1;
type.clientData = NULL;
Tcl_CreateEncoding(&type);
type.encodingName = "unicode";
type.toUtfProc = UnicodeToUtfProc;
type.fromUtfProc = UtfToUnicodeProc;
type.freeProc = NULL;
type.nullSize = 2;
type.clientData = NULL;
Tcl_CreateEncoding(&type);
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeEncodingSubsystem --
*
* Release the state associated with the encoding subsystem.
*
* Results:
* None.
*
* Side effects:
* Frees all of the encodings.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeEncodingSubsystem()
{
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
Tcl_MutexLock(&encodingMutex);
encodingsInitialized = 0;
FreeEncoding(systemEncoding);
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
while (hPtr != NULL) {
/*
* Call FreeEncoding instead of doing it directly to handle refcounts
* like escape encodings use. [Bug #524674]
* Make sure to call Tcl_FirstHashEntry repeatedly so that all
* encodings are eventually cleaned up.
*/
FreeEncoding((Tcl_Encoding) Tcl_GetHashValue(hPtr));
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
}
Tcl_DeleteHashTable(&encodingTable);
Tcl_MutexUnlock(&encodingMutex);
}
/*
*-------------------------------------------------------------------------
*
* Tcl_GetDefaultEncodingDir --
*
*
* Results:
*
* Side effects:
*
*-------------------------------------------------------------------------
*/
CONST char *
Tcl_GetDefaultEncodingDir()
{
return tclDefaultEncodingDir;
}
/*
*-------------------------------------------------------------------------
*
* Tcl_SetDefaultEncodingDir --
*
*
* Results:
*
* Side effects:
*
*-------------------------------------------------------------------------
*/
void
Tcl_SetDefaultEncodingDir(path)
CONST char *path;
{
tclDefaultEncodingDir = (char *)ckalloc((unsigned) strlen(path) + 1);
strcpy(tclDefaultEncodingDir, path);
}
/*
*-------------------------------------------------------------------------
*
* Tcl_GetEncoding --
*
* Given the name of a encoding, find the corresponding Tcl_Encoding
* token. If the encoding did not already exist, Tcl attempts to
* dynamically load an encoding by that name.
*
* Results:
* Returns a token that represents the encoding. If the name didn't
* refer to any known or loadable encoding, NULL is returned. If
* NULL was returned, an error message is left in interp's result
* object, unless interp was NULL.
*
* Side effects:
* The new encoding type is entered into a table visible to all
* interpreters, keyed off the encoding's name. For each call to
* this procedure, there should eventually be a call to
* Tcl_FreeEncoding, so that the database can be cleaned up when
* encodings aren't needed anymore.
*
*-------------------------------------------------------------------------
*/
Tcl_Encoding
Tcl_GetEncoding(interp, name)
Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */
CONST char *name; /* The name of the desired encoding. */
{
Tcl_HashEntry *hPtr;
Encoding *encodingPtr;
Tcl_MutexLock(&encodingMutex);
if (name == NULL) {
encodingPtr = (Encoding *) systemEncoding;
encodingPtr->refCount++;
Tcl_MutexUnlock(&encodingMutex);
return systemEncoding;
}
hPtr = Tcl_FindHashEntry(&encodingTable, name);
if (hPtr != NULL) {
encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
encodingPtr->refCount++;
Tcl_MutexUnlock(&encodingMutex);
return (Tcl_Encoding) encodingPtr;
}
Tcl_MutexUnlock(&encodingMutex);
return LoadEncodingFile(interp, name);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FreeEncoding --
*
* This procedure is called to release an encoding allocated by
* Tcl_CreateEncoding() or Tcl_GetEncoding().
*
* Results:
* None.
*
* Side effects:
* The reference count associated with the encoding is decremented
* and the encoding may be deleted if nothing is using it anymore.
*
*---------------------------------------------------------------------------
*/
void
Tcl_FreeEncoding(encoding)
Tcl_Encoding encoding;
{
Tcl_MutexLock(&encodingMutex);
FreeEncoding(encoding);
Tcl_MutexUnlock(&encodingMutex);
}
/*
*----------------------------------------------------------------------
*
* FreeEncoding --
*
* This procedure is called to release an encoding by procedures
* that already have the encodingMutex.
*
* Results:
* None.
*
* Side effects:
* The reference count associated with the encoding is decremented
* and the encoding may be deleted if nothing is using it anymore.
*
*----------------------------------------------------------------------
*/
static void
FreeEncoding(encoding)
Tcl_Encoding encoding;
{
Encoding *encodingPtr;
encodingPtr = (Encoding *) encoding;
if (encodingPtr == NULL) {
return;
}
if (encodingPtr->refCount<=0) {
Tcl_Panic("FreeEncoding: refcount problem !!!");
}
encodingPtr->refCount--;
if (encodingPtr->refCount == 0) {
if (encodingPtr->freeProc != NULL) {
(*encodingPtr->freeProc)(encodingPtr->clientData);
}
if (encodingPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(encodingPtr->hPtr);
}
ckfree((char *) encodingPtr->name);
ckfree((char *) encodingPtr);
}
}
/*
*-------------------------------------------------------------------------
*
* Tcl_GetEncodingName --
*
* Given an encoding, return the name that was used to constuct
* the encoding.
*
* Results:
* The name of the encoding.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
CONST char *
Tcl_GetEncodingName(encoding)
Tcl_Encoding encoding; /* The encoding whose name to fetch. */
{
Encoding *encodingPtr;
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
return encodingPtr->name;
}
/*
*-------------------------------------------------------------------------
*
* Tcl_GetEncodingNames --
*
* Get the list of all known encodings, including the ones stored
* as files on disk in the encoding path.
*
* Results:
* Modifies interp's result object to hold a list of all the available
* encodings.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
void
Tcl_GetEncodingNames(interp)
Tcl_Interp *interp; /* Interp to hold result. */
{
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
Tcl_Obj *pathPtr, *resultPtr;
int dummy;
Tcl_HashTable table;
Tcl_MutexLock(&encodingMutex);
Tcl_InitHashTable(&table, TCL_STRING_KEYS);
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
while (hPtr != NULL) {
Encoding *encodingPtr;
encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
Tcl_CreateHashEntry(&table, encodingPtr->name, &dummy);
hPtr = Tcl_NextHashEntry(&search);
}
Tcl_MutexUnlock(&encodingMutex);
pathPtr = TclGetLibraryPath();
if (pathPtr != NULL) {
int i, objc;
Tcl_Obj **objv;
char globArgString[10];
Tcl_Obj* encodingObj = Tcl_NewStringObj("encoding",-1);
Tcl_IncrRefCount(encodingObj);
objc = 0;
Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
for (i = 0; i < objc; i++) {
Tcl_Obj *searchIn;
/*
* Construct the path from the element of pathPtr,
* joined with 'encoding'.
*/
searchIn = Tcl_FSJoinToPath(objv[i],1,&encodingObj);
Tcl_IncrRefCount(searchIn);
Tcl_ResetResult(interp);
/*
* TclGlob() changes the contents of globArgString, which causes
* a segfault if we pass in a pointer to non-writeable memory.
* TclGlob() puts its results directly into interp.
*/
strcpy(globArgString, "*.enc");
/*
* The GLOBMODE_TAILS flag returns just the tail of each file
* which is the encoding name with a .enc extension
*/
if ((TclGlob(interp, globArgString, searchIn,
TCL_GLOBMODE_TAILS, NULL) == TCL_OK)) {
int objc2 = 0;
Tcl_Obj **objv2;
int j;
Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2,
&objv2);
for (j = 0; j < objc2; j++) {
int length;
char *string;
string = Tcl_GetStringFromObj(objv2[j], &length);
length -= 4;
if (length > 0) {
string[length] = '\0';
Tcl_CreateHashEntry(&table, string, &dummy);
string[length] = '.';
}
}
}
Tcl_DecrRefCount(searchIn);
}
Tcl_DecrRefCount(encodingObj);
}
/*
* Clear any values placed in the result by globbing.
*/
Tcl_ResetResult(interp);
resultPtr = Tcl_GetObjResult(interp);
hPtr = Tcl_FirstHashEntry(&table, &search);
while (hPtr != NULL) {
Tcl_Obj *strPtr;
strPtr = Tcl_NewStringObj(Tcl_GetHashKey(&table, hPtr), -1);
Tcl_ListObjAppendElement(NULL, resultPtr, strPtr);
hPtr = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(&table);
}
/*
*------------------------------------------------------------------------
*
* Tcl_SetSystemEncoding --
*
* Sets the default encoding that should be used whenever the user
* passes a NULL value in to one of the conversion routines.
* If the supplied name is NULL, the system encoding is reset to the
* default system encoding.
*
* Results:
* The return value is TCL_OK if the system encoding was successfully
* set to the encoding specified by name, TCL_ERROR otherwise. If
* TCL_ERROR is returned, an error message is left in interp's result
* object, unless interp was NULL.
*
* Side effects:
* The reference count of the new system encoding is incremented.
* The reference count of the old system encoding is decremented and
* it may be freed.
*
*------------------------------------------------------------------------
*/
int
Tcl_SetSystemEncoding(interp, name)
Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */
CONST char *name; /* The name of the desired encoding, or NULL/""
* to reset to default encoding. */
{
Tcl_Encoding encoding;
Encoding *encodingPtr;
if (!name || !*name) {
Tcl_MutexLock(&encodingMutex);
encoding = defaultEncoding;
encodingPtr = (Encoding *) encoding;
encodingPtr->refCount++;
Tcl_MutexUnlock(&encodingMutex);
} else {
encoding = Tcl_GetEncoding(interp, name);
if (encoding == NULL) {
return TCL_ERROR;
}
}
Tcl_MutexLock(&encodingMutex);
FreeEncoding(systemEncoding);
systemEncoding = encoding;
Tcl_MutexUnlock(&encodingMutex);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_CreateEncoding --
*
* This procedure is called to define a new encoding and the procedures
* that are used to convert between the specified encoding and Unicode.
*
* Results:
* Returns a token that represents the encoding. If an encoding with
* the same name already existed, the old encoding token remains
* valid and continues to behave as it used to, and will eventually
* be garbage collected when the last reference to it goes away. Any
* subsequent calls to Tcl_GetEncoding with the specified name will
* retrieve the most recent encoding token.
*
* Side effects:
* The new encoding type is entered into a table visible to all
* interpreters, keyed off the encoding's name. For each call to
* this procedure, there should eventually be a call to
* Tcl_FreeEncoding, so that the database can be cleaned up when
* encodings aren't needed anymore.
*
*---------------------------------------------------------------------------
*/
Tcl_Encoding
Tcl_CreateEncoding(typePtr)
Tcl_EncodingType *typePtr; /* The encoding type. */
{
Tcl_HashEntry *hPtr;
int new;
Encoding *encodingPtr;
char *name;
Tcl_MutexLock(&encodingMutex);
hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &new);
if (new == 0) {
/*
* Remove old encoding from hash table, but don't delete it until
* last reference goes away.
*/
encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
encodingPtr->hPtr = NULL;
}
name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1);
encodingPtr = (Encoding *) ckalloc(sizeof(Encoding));
encodingPtr->name = strcpy(name, typePtr->encodingName);
encodingPtr->toUtfProc = typePtr->toUtfProc;
encodingPtr->fromUtfProc = typePtr->fromUtfProc;
encodingPtr->freeProc = typePtr->freeProc;
encodingPtr->nullSize = typePtr->nullSize;
encodingPtr->clientData = typePtr->clientData;
if (typePtr->nullSize == 1) {
encodingPtr->lengthProc = (LengthProc *) strlen;
} else {
encodingPtr->lengthProc = (LengthProc *) unilen;
}
encodingPtr->refCount = 1;
encodingPtr->hPtr = hPtr;
Tcl_SetHashValue(hPtr, encodingPtr);
Tcl_MutexUnlock(&encodingMutex);
return (Tcl_Encoding) encodingPtr;
}
/*
*-------------------------------------------------------------------------
*
* Tcl_ExternalToUtfDString --
*
* Convert a source buffer from the specified encoding into UTF-8.
* If any of the bytes in the source buffer are invalid or cannot
* be represented in the target encoding, a default fallback
* character will be substituted.
*
* Results:
* The converted bytes are stored in the DString, which is then NULL
* terminated. The return value is a pointer to the value stored
* in the DString.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
char *
Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr)
Tcl_Encoding encoding; /* The encoding for the source string, or
* NULL for the default system encoding. */
CONST char *src; /* Source string in specified encoding. */
int srcLen; /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
Tcl_DString *dstPtr; /* Uninitialized or free DString in which
* the converted string is stored. */
{
char *dst;
Tcl_EncodingState state;
Encoding *encodingPtr;
int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
Tcl_DStringInit(dstPtr);
dst = Tcl_DStringValue(dstPtr);
dstLen = dstPtr->spaceAvl - 1;
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen < 0) {
srcLen = (*encodingPtr->lengthProc)(src);
}
flags = TCL_ENCODING_START | TCL_ENCODING_END;
while (1) {
result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src,
srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
&dstChars);
soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
if (result != TCL_CONVERT_NOSPACE) {
Tcl_DStringSetLength(dstPtr, soFar);
return Tcl_DStringValue(dstPtr);
}
flags &= ~TCL_ENCODING_START;
src += srcRead;
srcLen -= srcRead;
if (Tcl_DStringLength(dstPtr) == 0) {
Tcl_DStringSetLength(dstPtr, dstLen);
}
Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1);
dst = Tcl_DStringValue(dstPtr) + soFar;
dstLen = Tcl_DStringLength(dstPtr) - soFar - 1;
}
}
/*
*-------------------------------------------------------------------------
*
* Tcl_ExternalToUtf --
*
* Convert a source buffer from the specified encoding into UTF-8.
*
* Results:
* The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE,
* TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE,
* as documented in tcl.h.
*
* Side effects:
* The converted bytes are stored in the output buffer.
*
*-------------------------------------------------------------------------
*/
int
Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst,
dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
Tcl_Interp *interp; /* Interp for error return, if not NULL. */
Tcl_Encoding encoding; /* The encoding for the source string, or
* NULL for the default system encoding. */
CONST char *src; /* Source string in specified encoding. */
int srcLen; /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
Encoding *encodingPtr;
int result, srcRead, dstWrote, dstChars;
Tcl_EncodingState state;
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen < 0) {
srcLen = (*encodingPtr->lengthProc)(src);
}
if (statePtr == NULL) {
flags |= TCL_ENCODING_START | TCL_ENCODING_END;
statePtr = &state;
}
if (srcReadPtr == NULL) {
srcReadPtr = &srcRead;
}
if (dstWrotePtr == NULL) {
dstWrotePtr = &dstWrote;
}
if (dstCharsPtr == NULL) {
dstCharsPtr = &dstChars;
}
/*
* If there are any null characters in the middle of the buffer, they will
* converted to the UTF-8 null character (\xC080). To get the actual
* \0 at the end of the destination buffer, we need to append it manually.
*/
dstLen--;
result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen,
flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
dstCharsPtr);
dst[*dstWrotePtr] = '\0';
return result;
}
/*
*-------------------------------------------------------------------------
*
* Tcl_UtfToExternalDString --
*
* Convert a source buffer from UTF-8 into the specified encoding.
* If any of the bytes in the source buffer are invalid or cannot
* be represented in the target encoding, a default fallback
* character will be substituted.
*
* Results:
* The converted bytes are stored in the DString, which is then
* NULL terminated in an encoding-specific manner. The return value
* is a pointer to the value stored in the DString.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
char *
Tcl_UtfToExternalDString(encoding, src, srcLen, dstPtr)
Tcl_Encoding encoding; /* The encoding for the converted string,
* or NULL for the default system encoding. */
CONST char *src; /* Source string in UTF-8. */
int srcLen; /* Source string length in bytes, or < 0 for
* strlen(). */
Tcl_DString *dstPtr; /* Uninitialized or free DString in which
* the converted string is stored. */
{
char *dst;
Tcl_EncodingState state;
Encoding *encodingPtr;
int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
Tcl_DStringInit(dstPtr);
dst = Tcl_DStringValue(dstPtr);
dstLen = dstPtr->spaceAvl - 1;
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen < 0) {
srcLen = strlen(src);
}
flags = TCL_ENCODING_START | TCL_ENCODING_END;
while (1) {
result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src,
srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
&dstChars);
soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
if (result != TCL_CONVERT_NOSPACE) {
if (encodingPtr->nullSize == 2) {
Tcl_DStringSetLength(dstPtr, soFar + 1);
}
Tcl_DStringSetLength(dstPtr, soFar);
return Tcl_DStringValue(dstPtr);
}
flags &= ~TCL_ENCODING_START;
src += srcRead;
srcLen -= srcRead;
if (Tcl_DStringLength(dstPtr) == 0) {
Tcl_DStringSetLength(dstPtr, dstLen);
}
Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1);
dst = Tcl_DStringValue(dstPtr) + soFar;
dstLen = Tcl_DStringLength(dstPtr) - soFar - 1;
}
}
/*
*-------------------------------------------------------------------------
*
* Tcl_UtfToExternal --
*
* Convert a buffer from UTF-8 into the specified encoding.
*
* Results:
* The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE,
* TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE,
* as documented in tcl.h.
*
* Side effects:
* The converted bytes are stored in the output buffer.
*
*-------------------------------------------------------------------------
*/
int
Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst,
dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
Tcl_Interp *interp; /* Interp for error return, if not NULL. */
Tcl_Encoding encoding; /* The encoding for the converted string,
* or NULL for the default system encoding. */
CONST char *src; /* Source string in UTF-8. */
int srcLen; /* Source string length in bytes, or < 0 for
* strlen(). */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
Encoding *encodingPtr;
int result, srcRead, dstWrote, dstChars;
Tcl_EncodingState state;
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen < 0) {
srcLen = strlen(src);
}
if (statePtr == NULL) {
flags |= TCL_ENCODING_START | TCL_ENCODING_END;
statePtr = &state;
}
if (srcReadPtr == NULL) {
srcReadPtr = &srcRead;
}
if (dstWrotePtr == NULL) {
dstWrotePtr = &dstWrote;
}
if (dstCharsPtr == NULL) {
dstCharsPtr = &dstChars;
}
dstLen -= encodingPtr->nullSize;
result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen,
flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
dstCharsPtr);
if (encodingPtr->nullSize == 2) {
dst[*dstWrotePtr + 1] = '\0';
}
dst[*dstWrotePtr] = '\0';
return result;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FindExecutable --
*
* This procedure computes the absolute path name of the current
* application, given its argv[0] value.
*
* Results:
* None.
*
* Side effects:
* The variable tclExecutableName gets filled in with the file
* name for the application, if we figured it out. If we couldn't
* figure it out, tclExecutableName is set to NULL.
*
*---------------------------------------------------------------------------
*/
void
Tcl_FindExecutable(argv0)
CONST char *argv0; /* The value of the application's argv[0]
* (native). */
{
int mustCleanUtf;
CONST char *name;
Tcl_DString buffer, nameString;
TclInitSubsystems(argv0);
if (argv0 == NULL) {
goto done;
}
if (tclExecutableName != NULL) {
ckfree(tclExecutableName);
tclExecutableName = NULL;
}
if ((name = TclpFindExecutable(argv0)) == NULL) {
goto done;
}
/*
* The value returned from TclpNameOfExecutable is a UTF string that
* is possibly dirty depending on when it was initialized.
* TclFindEncodings will indicate whether we must "clean" the UTF (as
* reported by the underlying system). To assure that the UTF string
* is a properly encoded native string for this system, convert the
* UTF string to the default native encoding before the default
* encoding is initialized. Then, convert it back to UTF after the
* system encoding is loaded.
*/
Tcl_UtfToExternalDString(NULL, name, -1, &buffer);
mustCleanUtf = TclFindEncodings(argv0);
/*
* Now it is OK to convert the native string back to UTF and set
* the value of the tclExecutableName.
*/
if (mustCleanUtf) {
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buffer), -1,
&nameString);
tclExecutableName = (char *)
ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1));
strcpy(tclExecutableName, Tcl_DStringValue(&nameString));
Tcl_DStringFree(&nameString);
} else {
tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1));
strcpy(tclExecutableName, name);
}
Tcl_DStringFree(&buffer);
return;
done:
(void) TclFindEncodings(argv0);
}
/*
*---------------------------------------------------------------------------
*
* LoadEncodingFile --
*
* Read a file that describes an encoding and create a new Encoding
* from the data.
*
* Results:
* The return value is the newly loaded Encoding, or NULL if
* the file didn't exist of was in the incorrect format. If NULL was
* returned, an error message is left in interp's result object,
* unless interp was NULL.
*
* Side effects:
* File read from disk.
*
*---------------------------------------------------------------------------
*/
static Tcl_Encoding
LoadEncodingFile(interp, name)
Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */
CONST char *name; /* The name of the encoding file on disk
* and also the name for new encoding. */
{
int objc, i, ch;
Tcl_Obj **objv;
Tcl_Obj *pathPtr;
Tcl_Channel chan;
Tcl_Encoding encoding;
pathPtr = TclGetLibraryPath();
if (pathPtr == NULL) {
goto unknown;
}
objc = 0;
Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
chan = NULL;
for (i = 0; i < objc; i++) {
chan = OpenEncodingFile(Tcl_GetString(objv[i]), name);
if (chan != NULL) {
break;
}
}
if (chan == NULL) {
goto unknown;
}
Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
while (1) {
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_Gets(chan, &ds);
ch = Tcl_DStringValue(&ds)[0];
Tcl_DStringFree(&ds);
if (ch != '#') {
break;
}
}
encoding = NULL;
switch (ch) {
case 'S': {
encoding = LoadTableEncoding(interp, name, ENCODING_SINGLEBYTE,
chan);
break;
}
case 'D': {
encoding = LoadTableEncoding(interp, name, ENCODING_DOUBLEBYTE,
chan);
break;
}
case 'M': {
encoding = LoadTableEncoding(interp, name, ENCODING_MULTIBYTE,
chan);
break;
}
case 'E': {
encoding = LoadEscapeEncoding(name, chan);
break;
}
}
if ((encoding == NULL) && (interp != NULL)) {
Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL);
if (ch == 'E') {
Tcl_AppendResult(interp, " or missing sub-encoding", NULL);
}
}
Tcl_Close(NULL, chan);
return encoding;
unknown:
if (interp != NULL) {
Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* OpenEncodingFile --
*
* Look for the file encoding/.enc in the specified
* directory.
*
* Results:
* Returns an open file channel if the file exists.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Channel
OpenEncodingFile(dir, name)
CONST char *dir;
CONST char *name;
{
CONST char *argv[3];
Tcl_DString pathString;
CONST char *path;
Tcl_Channel chan;
Tcl_Obj *pathPtr;
argv[0] = dir;
argv[1] = "encoding";
argv[2] = name;
Tcl_DStringInit(&pathString);
Tcl_JoinPath(3, argv, &pathString);
path = Tcl_DStringAppend(&pathString, ".enc", -1);
pathPtr = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(pathPtr);
chan = Tcl_FSOpenFileChannel(NULL, pathPtr, "r", 0);
Tcl_DecrRefCount(pathPtr);
Tcl_DStringFree(&pathString);
return chan;
}
/*
*-------------------------------------------------------------------------
*
* LoadTableEncoding --
*
* Helper function for LoadEncodingTable(). Loads a table to that
* converts between Unicode and some other encoding and creates an
* encoding (using a TableEncoding structure) from that information.
*
* File contains binary data, but begins with a marker to indicate
* byte-ordering, so that same binary file can be read on either
* endian platforms.
*
* Results:
* The return value is the new encoding, or NULL if the encoding
* could not be created (because the file contained invalid data).
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static Tcl_Encoding
LoadTableEncoding(interp, name, type, chan)
Tcl_Interp *interp; /* Interp for temporary obj while reading. */
CONST char *name; /* Name for new encoding. */
int type; /* Type of encoding (ENCODING_?????). */
Tcl_Channel chan; /* File containing new encoding. */
{
Tcl_DString lineString;
Tcl_Obj *objPtr;
char *line;
int i, hi, lo, numPages, symbol, fallback;
unsigned char used[256];
unsigned int size;
TableEncodingData *dataPtr;
unsigned short *pageMemPtr;
Tcl_EncodingType encType;
/*
* Speed over memory. Use a full 256 character table to decode hex
* sequences in the encoding files.
*/
static CONST char staticHex[] = {
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0 ... 15 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 16 ... 31 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 32 ... 47 */
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /* 48 ... 63 */
0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 64 ... 79 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 80 ... 95 */
0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 96 ... 111 */
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /* 112 ... 127 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 128 ... 143 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 144 ... 159 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 160 ... 175 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 176 ... 191 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 192 ... 207 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 208 ... 223 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 224 ... 239 */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 240 ... 255 */
};
Tcl_DStringInit(&lineString);
Tcl_Gets(chan, &lineString);
line = Tcl_DStringValue(&lineString);
fallback = (int) strtol(line, &line, 16);
symbol = (int) strtol(line, &line, 10);
numPages = (int) strtol(line, &line, 10);
Tcl_DStringFree(&lineString);
if (numPages < 0) {
numPages = 0;
} else if (numPages > 256) {
numPages = 256;
}
memset(used, 0, sizeof(used));
#undef PAGESIZE
#define PAGESIZE (256 * sizeof(unsigned short))
dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData));
memset(dataPtr, 0, sizeof(TableEncodingData));
dataPtr->fallback = fallback;
/*
* Read the table that maps characters to Unicode. Performs a single
* malloc to get the memory for the array and all the pages needed by
* the array.
*/
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
dataPtr->toUnicode = (unsigned short **) ckalloc(size);
memset(dataPtr->toUnicode, 0, size);
pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256);
if (interp == NULL) {
objPtr = Tcl_NewObj();
} else {
objPtr = Tcl_GetObjResult(interp);
}
for (i = 0; i < numPages; i++) {
int ch;
char *p;
Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0);
p = Tcl_GetString(objPtr);
hi = (staticHex[(unsigned int)p[0]] << 4) + staticHex[(unsigned int)p[1]];
dataPtr->toUnicode[hi] = pageMemPtr;
p += 2;
for (lo = 0; lo < 256; lo++) {
if ((lo & 0x0f) == 0) {
p++;
}
ch = (staticHex[(unsigned int)p[0]] << 12) + (staticHex[(unsigned int)p[1]] << 8)
+ (staticHex[(unsigned int)p[2]] << 4) + staticHex[(unsigned int)p[3]];
if (ch != 0) {
used[ch >> 8] = 1;
}
*pageMemPtr = (unsigned short) ch;
pageMemPtr++;
p += 4;
}
}
if (interp == NULL) {
Tcl_DecrRefCount(objPtr);
} else {
Tcl_ResetResult(interp);
}
if (type == ENCODING_DOUBLEBYTE) {
memset(dataPtr->prefixBytes, 1, sizeof(dataPtr->prefixBytes));
} else {
for (hi = 1; hi < 256; hi++) {
if (dataPtr->toUnicode[hi] != NULL) {
dataPtr->prefixBytes[hi] = 1;
}
}
}
/*
* Invert toUnicode array to produce the fromUnicode array. Performs a
* single malloc to get the memory for the array and all the pages
* needed by the array. While reading in the toUnicode array, we
* remembered what pages that would be needed for the fromUnicode array.
*/
if (symbol) {
used[0] = 1;
}
numPages = 0;
for (hi = 0; hi < 256; hi++) {
if (used[hi]) {
numPages++;
}
}
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
dataPtr->fromUnicode = (unsigned short **) ckalloc(size);
memset(dataPtr->fromUnicode, 0, size);
pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256);
for (hi = 0; hi < 256; hi++) {
if (dataPtr->toUnicode[hi] == NULL) {
dataPtr->toUnicode[hi] = emptyPage;
} else {
for (lo = 0; lo < 256; lo++) {
int ch;
ch = dataPtr->toUnicode[hi][lo];
if (ch != 0) {
unsigned short *page;
page = dataPtr->fromUnicode[ch >> 8];
if (page == NULL) {
page = pageMemPtr;
pageMemPtr += 256;
dataPtr->fromUnicode[ch >> 8] = page;
}
page[ch & 0xff] = (unsigned short) ((hi << 8) + lo);
}
}
}
}
if (type == ENCODING_MULTIBYTE) {
/*
* If multibyte encodings don't have a backslash character, define
* one. Otherwise, on Windows, native file names won't work because
* the backslash in the file name will map to the unknown character
* (question mark) when converting from UTF-8 to external encoding.
*/
if (dataPtr->fromUnicode[0] != NULL) {
if (dataPtr->fromUnicode[0]['\\'] == '\0') {
dataPtr->fromUnicode[0]['\\'] = '\\';
}
}
}
if (symbol) {
unsigned short *page;
/*
* Make a special symbol encoding that not only maps the symbol
* characters from their Unicode code points down into page 0, but
* also ensure that the characters on page 0 map to themselves.
* This is so that a symbol font can be used to display a simple
* string like "abcd" and have alpha, beta, chi, delta show up,
* rather than have "unknown" chars show up because strictly
* speaking the symbol font doesn't have glyphs for those low ascii
* chars.
*/
page = dataPtr->fromUnicode[0];
if (page == NULL) {
page = pageMemPtr;
dataPtr->fromUnicode[0] = page;
}
for (lo = 0; lo < 256; lo++) {
if (dataPtr->toUnicode[0][lo] != 0) {
page[lo] = (unsigned short) lo;
}
}
}
for (hi = 0; hi < 256; hi++) {
if (dataPtr->fromUnicode[hi] == NULL) {
dataPtr->fromUnicode[hi] = emptyPage;
}
}
/*
* For trailing 'R'everse encoding, see [Patch #689341]
*/
Tcl_DStringInit(&lineString);
do {
int len;
/* skip leading empty lines */
while ((len = Tcl_Gets(chan, &lineString)) == 0)
;
if (len < 0) {
break;
}
line = Tcl_DStringValue(&lineString);
if (line[0] != 'R') {
break;
}
for (Tcl_DStringSetLength(&lineString, 0);
(len = Tcl_Gets(chan, &lineString)) >= 0;
Tcl_DStringSetLength(&lineString, 0)) {
unsigned char* p;
int to, from;
if (len < 5) {
continue;
}
p = (unsigned char*) Tcl_DStringValue(&lineString);
to = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
+ (staticHex[p[2]] << 4) + staticHex[p[3]];
if (to == 0) {
continue;
}
for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) {
from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
+ (staticHex[p[2]] << 4) + staticHex[p[3]];
if (from == 0) {
continue;
}
dataPtr->fromUnicode[from >> 8][from & 0xff] = to;
}
}
} while (0);
Tcl_DStringFree(&lineString);
encType.encodingName = name;
encType.toUtfProc = TableToUtfProc;
encType.fromUtfProc = TableFromUtfProc;
encType.freeProc = TableFreeProc;
encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1;
encType.clientData = (ClientData) dataPtr;
return Tcl_CreateEncoding(&encType);
}
/*
*-------------------------------------------------------------------------
*
* LoadEscapeEncoding --
*
* Helper function for LoadEncodingTable(). Loads a state machine
* that converts between Unicode and some other encoding.
*
* File contains text data that describes the escape sequences that
* are used to choose an encoding and the associated names for the
* sub-encodings.
*
* Results:
* The return value is the new encoding, or NULL if the encoding
* could not be created (because the file contained invalid data).
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static Tcl_Encoding
LoadEscapeEncoding(name, chan)
CONST char *name; /* Name for new encoding. */
Tcl_Channel chan; /* File containing new encoding. */
{
int i, missingSubEncoding = 0;
unsigned int size;
Tcl_DString escapeData;
char init[16], final[16];
EscapeEncodingData *dataPtr;
Tcl_EncodingType type;
init[0] = '\0';
final[0] = '\0';
Tcl_DStringInit(&escapeData);
while (1) {
int argc;
CONST char **argv;
char *line;
Tcl_DString lineString;
Tcl_DStringInit(&lineString);
if (Tcl_Gets(chan, &lineString) < 0) {
break;
}
line = Tcl_DStringValue(&lineString);
if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) {
continue;
}
if (argc >= 2) {
if (strcmp(argv[0], "name") == 0) {
;
} else if (strcmp(argv[0], "init") == 0) {
strncpy(init, argv[1], sizeof(init));
init[sizeof(init) - 1] = '\0';
} else if (strcmp(argv[0], "final") == 0) {
strncpy(final, argv[1], sizeof(final));
final[sizeof(final) - 1] = '\0';
} else {
EscapeSubTable est;
strncpy(est.sequence, argv[1], sizeof(est.sequence));
est.sequence[sizeof(est.sequence) - 1] = '\0';
est.sequenceLen = strlen(est.sequence);
strncpy(est.name, argv[0], sizeof(est.name));
est.name[sizeof(est.name) - 1] = '\0';
/*
* Load the subencodings first so we're never stuck
* trying to use a half-loaded system encoding to
* open/read a *.enc file.
*/
est.encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, est.name);
if ((est.encodingPtr == NULL)
|| (est.encodingPtr->toUtfProc != TableToUtfProc)) {
missingSubEncoding = 1;
}
Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
}
}
ckfree((char *) argv);
Tcl_DStringFree(&lineString);
}
if (missingSubEncoding) {
Tcl_DStringFree(&escapeData);
return NULL;
}
size = sizeof(EscapeEncodingData)
- sizeof(EscapeSubTable) + Tcl_DStringLength(&escapeData);
dataPtr = (EscapeEncodingData *) ckalloc(size);
dataPtr->initLen = strlen(init);
strcpy(dataPtr->init, init);
dataPtr->finalLen = strlen(final);
strcpy(dataPtr->final, final);
dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable);
memcpy((VOID *) dataPtr->subTables, (VOID *) Tcl_DStringValue(&escapeData),
(size_t) Tcl_DStringLength(&escapeData));
Tcl_DStringFree(&escapeData);
memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes));
for (i = 0; i < dataPtr->numSubTables; i++) {
dataPtr->prefixBytes[UCHAR(dataPtr->subTables[i].sequence[0])] = 1;
}
if (dataPtr->init[0] != '\0') {
dataPtr->prefixBytes[UCHAR(dataPtr->init[0])] = 1;
}
if (dataPtr->final[0] != '\0') {
dataPtr->prefixBytes[UCHAR(dataPtr->final[0])] = 1;
}
type.encodingName = name;
type.toUtfProc = EscapeToUtfProc;
type.fromUtfProc = EscapeFromUtfProc;
type.freeProc = EscapeFreeProc;
type.nullSize = 1;
type.clientData = (ClientData) dataPtr;
return Tcl_CreateEncoding(&type);
}
/*
*-------------------------------------------------------------------------
*
* BinaryProc --
*
* The default conversion when no other conversion is specified.
* No translation is done; source bytes are copied directly to
* destination bytes.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
BinaryProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* Not used. */
CONST char *src; /* Source string (unknown encoding). */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
int result;
result = TCL_OK;
dstLen -= TCL_UTF_MAX - 1;
if (dstLen < 0) {
dstLen = 0;
}
if (srcLen > dstLen) {
srcLen = dstLen;
result = TCL_CONVERT_NOSPACE;
}
*srcReadPtr = srcLen;
*dstWrotePtr = srcLen;
*dstCharsPtr = srcLen;
memcpy((void *) dst, (void *) src, (size_t) srcLen);
return result;
}
/*
*-------------------------------------------------------------------------
*
* UtfExtToUtfIntProc --
*
* Convert from UTF-8 to UTF-8. While converting null-bytes from
* the Tcl's internal representation (0xc0, 0x80) to the official
* representation (0x00). See UtfToUtfProc for details.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfIntToUtfExtProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* Not used. */
CONST char *src; /* Source string in UTF-8. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr, 1);
}
/*
*-------------------------------------------------------------------------
*
* UtfExtToUtfIntProc --
*
* Convert from UTF-8 to UTF-8 while converting null-bytes from
* the official representation (0x00) to Tcl's internal
* representation (0xc0, 0x80). See UtfToUtfProc for details.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfExtToUtfIntProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* Not used. */
CONST char *src; /* Source string in UTF-8. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr, 0);
}
/*
*-------------------------------------------------------------------------
*
* UtfToUtfProc --
*
* Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8
* translation is not a no-op, because it will turn a stream of
* improperly formed UTF-8 into a properly formed stream.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr, pureNullMode)
ClientData clientData; /* Not used. */
CONST char *src; /* Source string in UTF-8. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
int pureNullMode; /* Convert embedded nulls from
* internal representation to real
* null-bytes or vice versa */
{
CONST char *srcStart, *srcEnd, *srcClose;
char *dstStart, *dstEnd;
int result, numChars;
Tcl_UniChar ch;
result = TCL_OK;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
for (numChars = 0; src < srcEnd; numChars++) {
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
if (UCHAR(*src) < 0x80 &&
!(UCHAR(*src) == 0 && pureNullMode == 0)) {
/*
* Copy 7bit chatacters, but skip null-bytes when we are
* in input mode, so that they get converted to 0xc080.
*/
*dst++ = *src++;
} else if (pureNullMode == 1 &&
UCHAR(*src) == 0xc0 &&
UCHAR(*(src+1)) == 0x80) {
/*
* Convert 0xc080 to real nulls when we are in output mode.
*/
*dst++ = 0;
src += 2;
} else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
/* Always check before using Tcl_UtfToUniChar. Not doing
* can so cause it run beyond the endof the buffer! If we
* happen such an incomplete char its bytes are made to
* represent themselves.
*/
ch = (unsigned char) *src;
src += 1;
dst += Tcl_UniCharToUtf(ch, dst);
} else {
src += Tcl_UtfToUniChar(src, &ch);
dst += Tcl_UniCharToUtf(ch, dst);
}
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
* UnicodeToUtfProc --
*
* Convert from Unicode to UTF-8.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* Not used. */
CONST char *src; /* Source string in Unicode. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
CONST char *srcStart, *srcEnd;
char *dstEnd, *dstStart;
int result, numChars;
Tcl_UniChar ch;
result = TCL_OK;
if ((srcLen % sizeof(Tcl_UniChar)) != 0) {
result = TCL_CONVERT_MULTIBYTE;
srcLen /= sizeof(Tcl_UniChar);
srcLen *= sizeof(Tcl_UniChar);
}
srcStart = src;
srcEnd = src + srcLen;
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
for (numChars = 0; src < srcEnd; numChars++) {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
/*
* Special case for 1-byte utf chars for speed. Make sure we
* work with Tcl_UniChar-size data.
*/
ch = *(Tcl_UniChar *)src;
if (ch && ch < 0x80) {
*dst++ = (ch & 0xFF);
} else {
dst += Tcl_UniCharToUtf(ch, dst);
}
src += sizeof(Tcl_UniChar);
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
* UtfToUnicodeProc --
*
* Convert from UTF-8 to Unicode.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* TableEncodingData that specifies encoding. */
CONST char *src; /* Source string in UTF-8. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
CONST char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
int result, numChars;
Tcl_UniChar ch;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
dstEnd = dst + dstLen - sizeof(Tcl_UniChar);
result = TCL_OK;
for (numChars = 0; src < srcEnd; numChars++) {
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
src += TclUtfToUniChar(src, &ch);
/*
* Need to handle this in a way that won't cause misalignment
* by casting dst to a Tcl_UniChar. [Bug 1122671]
* XXX: This hard-codes the assumed size of Tcl_UniChar as 2.
*/
#ifdef WORDS_BIGENDIAN
*dst++ = (ch >> 8);
*dst++ = (ch & 0xFF);
#else
*dst++ = (ch & 0xFF);
*dst++ = (ch >> 8);
#endif
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
* TableToUtfProc --
*
* Convert from the encoding specified by the TableEncodingData into
* UTF-8.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* TableEncodingData that specifies
* encoding. */
CONST char *src; /* Source string in specified encoding. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
CONST char *srcStart, *srcEnd;
char *dstEnd, *dstStart, *prefixBytes;
int result, byte, numChars;
Tcl_UniChar ch;
unsigned short **toUnicode;
unsigned short *pageZero;
TableEncodingData *dataPtr;
srcStart = src;
srcEnd = src + srcLen;
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
dataPtr = (TableEncodingData *) clientData;
toUnicode = dataPtr->toUnicode;
prefixBytes = dataPtr->prefixBytes;
pageZero = toUnicode[0];
result = TCL_OK;
for (numChars = 0; src < srcEnd; numChars++) {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
byte = *((unsigned char *) src);
if (prefixBytes[byte]) {
src++;
if (src >= srcEnd) {
src--;
result = TCL_CONVERT_MULTIBYTE;
break;
}
ch = toUnicode[byte][*((unsigned char *) src)];
} else {
ch = pageZero[byte];
}
if ((ch == 0) && (byte != 0)) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_SYNTAX;
break;
}
if (prefixBytes[byte]) {
src--;
}
ch = (Tcl_UniChar) byte;
}
/*
* Special case for 1-byte utf chars for speed.
*/
if (ch && ch < 0x80) {
*dst++ = (char) ch;
} else {
dst += Tcl_UniCharToUtf(ch, dst);
}
src++;
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
* TableFromUtfProc --
*
* Convert from UTF-8 into the encoding specified by the
* TableEncodingData.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* TableEncodingData that specifies
* encoding. */
CONST char *src; /* Source string in UTF-8. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
CONST char *srcStart, *srcEnd, *srcClose;
char *dstStart, *dstEnd, *prefixBytes;
Tcl_UniChar ch;
int result, len, word, numChars;
TableEncodingData *dataPtr;
unsigned short **fromUnicode;
result = TCL_OK;
dataPtr = (TableEncodingData *) clientData;
prefixBytes = dataPtr->prefixBytes;
fromUnicode = dataPtr->fromUnicode;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
dstEnd = dst + dstLen - 1;
for (numChars = 0; src < srcEnd; numChars++) {
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
len = TclUtfToUniChar(src, &ch);
#if TCL_UTF_MAX > 3
/*
* This prevents a crash condition. More evaluation is required
* for full support of int Tcl_UniChar. [Bug 1004065]
*/
if (ch & 0xffff0000) {
word = 0;
} else
#endif
word = fromUnicode[(ch >> 8)][ch & 0xff];
if ((word == 0) && (ch != 0)) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
word = dataPtr->fallback;
}
if (prefixBytes[(word >> 8)] != 0) {
if (dst + 1 > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
dst[0] = (char) (word >> 8);
dst[1] = (char) word;
dst += 2;
} else {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
dst[0] = (char) word;
dst++;
}
src += len;
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*---------------------------------------------------------------------------
*
* TableFreeProc --
*
* This procedure is invoked when an encoding is deleted. It deletes
* the memory used by the TableEncodingData.
*
* Results:
* None.
*
* Side effects:
* Memory freed.
*
*---------------------------------------------------------------------------
*/
static void
TableFreeProc(clientData)
ClientData clientData; /* TableEncodingData that specifies
* encoding. */
{
TableEncodingData *dataPtr;
/*
* Make sure we aren't freeing twice on shutdown. [Bug #219314]
*/
dataPtr = (TableEncodingData *) clientData;
ckfree((char *) dataPtr->toUnicode);
ckfree((char *) dataPtr->fromUnicode);
ckfree((char *) dataPtr);
}
/*
*-------------------------------------------------------------------------
*
* EscapeToUtfProc --
*
* Convert from the encoding specified by the EscapeEncodingData into
* UTF-8.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* EscapeEncodingData that specifies
* encoding. */
CONST char *src; /* Source string in specified encoding. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
EscapeEncodingData *dataPtr;
char *prefixBytes, *tablePrefixBytes;
unsigned short **tableToUnicode;
Encoding *encodingPtr;
int state, result, numChars;
CONST char *srcStart, *srcEnd;
char *dstStart, *dstEnd;
result = TCL_OK;
tablePrefixBytes = NULL; /* lint. */
tableToUnicode = NULL; /* lint. */
dataPtr = (EscapeEncodingData *) clientData;
prefixBytes = dataPtr->prefixBytes;
encodingPtr = NULL;
srcStart = src;
srcEnd = src + srcLen;
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
state = (int) *statePtr;
if (flags & TCL_ENCODING_START) {
state = 0;
}
for (numChars = 0; src < srcEnd; ) {
int byte, hi, lo, ch;
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
byte = *((unsigned char *) src);
if (prefixBytes[byte]) {
unsigned int left, len, longest;
int checked, i;
EscapeSubTable *subTablePtr;
/*
* Saw the beginning of an escape sequence.
*/
left = srcEnd - src;
len = dataPtr->initLen;
longest = len;
checked = 0;
if (len <= left) {
checked++;
if ((len > 0) &&
(memcmp(src, dataPtr->init, len) == 0)) {
/*
* If we see initialization string, skip it, even if we're
* not at the beginning of the buffer.
*/
src += len;
continue;
}
}
len = dataPtr->finalLen;
if (len > longest) {
longest = len;
}
if (len <= left) {
checked++;
if ((len > 0) &&
(memcmp(src, dataPtr->final, len) == 0)) {
/*
* If we see finalization string, skip it, even if we're
* not at the end of the buffer.
*/
src += len;
continue;
}
}
subTablePtr = dataPtr->subTables;
for (i = 0; i < dataPtr->numSubTables; i++) {
len = subTablePtr->sequenceLen;
if (len > longest) {
longest = len;
}
if (len <= left) {
checked++;
if ((len > 0) &&
(memcmp(src, subTablePtr->sequence, len) == 0)) {
state = i;
encodingPtr = NULL;
subTablePtr = NULL;
src += len;
break;
}
}
subTablePtr++;
}
if (subTablePtr == NULL) {
/*
* A match was found, the escape sequence was consumed, and
* the state was updated.
*/
continue;
}
/*
* We have a split-up or unrecognized escape sequence. If we
* checked all the sequences, then it's a syntax error,
* otherwise we need more bytes to determine a match.
*/
if ((checked == dataPtr->numSubTables + 2)
|| (flags & TCL_ENCODING_END)) {
if ((flags & TCL_ENCODING_STOPONERROR) == 0) {
/*
* Skip the unknown escape sequence.
*/
src += longest;
continue;
}
result = TCL_CONVERT_SYNTAX;
} else {
result = TCL_CONVERT_MULTIBYTE;
}
break;
}
if (encodingPtr == NULL) {
TableEncodingData *tableDataPtr;
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
tablePrefixBytes = tableDataPtr->prefixBytes;
tableToUnicode = tableDataPtr->toUnicode;
}
if (tablePrefixBytes[byte]) {
src++;
if (src >= srcEnd) {
src--;
result = TCL_CONVERT_MULTIBYTE;
break;
}
hi = byte;
lo = *((unsigned char *) src);
} else {
hi = 0;
lo = byte;
}
ch = tableToUnicode[hi][lo];
dst += Tcl_UniCharToUtf(ch, dst);
src++;
numChars++;
}
*statePtr = (Tcl_EncodingState) state;
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
* EscapeFromUtfProc --
*
* Convert from UTF-8 into the encoding specified by the
* EscapeEncodingData.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* EscapeEncodingData that specifies
* encoding. */
CONST char *src; /* Source string in UTF-8. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
EscapeEncodingData *dataPtr;
Encoding *encodingPtr;
CONST char *srcStart, *srcEnd, *srcClose;
char *dstStart, *dstEnd;
int state, result, numChars;
TableEncodingData *tableDataPtr;
char *tablePrefixBytes;
unsigned short **tableFromUnicode;
result = TCL_OK;
dataPtr = (EscapeEncodingData *) clientData;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
dstEnd = dst + dstLen - 1;
/*
* RFC1468 states that the text starts in ASCII, and switches to Japanese
* characters, and that the text must end in ASCII. [Patch #474358]
*/
if (flags & TCL_ENCODING_START) {
state = 0;
if ((dst + dataPtr->initLen) > dstEnd) {
*srcReadPtr = 0;
*dstWrotePtr = 0;
return TCL_CONVERT_NOSPACE;
}
memcpy((VOID *) dst, (VOID *) dataPtr->init,
(size_t) dataPtr->initLen);
dst += dataPtr->initLen;
} else {
state = (int) *statePtr;
}
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
tablePrefixBytes = tableDataPtr->prefixBytes;
tableFromUnicode = tableDataPtr->fromUnicode;
for (numChars = 0; src < srcEnd; numChars++) {
unsigned int len;
int word;
Tcl_UniChar ch;
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
len = TclUtfToUniChar(src, &ch);
word = tableFromUnicode[(ch >> 8)][ch & 0xff];
if ((word == 0) && (ch != 0)) {
int oldState;
EscapeSubTable *subTablePtr;
oldState = state;
for (state = 0; state < dataPtr->numSubTables; state++) {
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff];
if (word != 0) {
break;
}
}
if (word == 0) {
state = oldState;
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
word = tableDataPtr->fallback;
}
tablePrefixBytes = tableDataPtr->prefixBytes;
tableFromUnicode = tableDataPtr->fromUnicode;
/*
* The state variable has the value of oldState when word is 0.
* In this case, the escape sequense should not be copied to dst
* because the current character set is not changed.
*/
if (state != oldState) {
subTablePtr = &dataPtr->subTables[state];
if ((dst + subTablePtr->sequenceLen) > dstEnd) {
/*
* If there is no space to write the escape sequence, the
* state variable must be changed to the value of oldState
* variable because this escape sequence must be written
* in the next conversion.
*/
state = oldState;
result = TCL_CONVERT_NOSPACE;
break;
}
memcpy((VOID *) dst, (VOID *) subTablePtr->sequence,
(size_t) subTablePtr->sequenceLen);
dst += subTablePtr->sequenceLen;
}
}
if (tablePrefixBytes[(word >> 8)] != 0) {
if (dst + 1 > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
dst[0] = (char) (word >> 8);
dst[1] = (char) word;
dst += 2;
} else {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
dst[0] = (char) word;
dst++;
}
src += len;
}
if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) {
unsigned int len = dataPtr->subTables[0].sequenceLen;
/*
* [Bug 1516109].
* Certain encodings like iso2022-jp need to write
* an escape sequence after all characters have
* been converted. This logic checks that enough
* room is available in the buffer for the escape bytes.
* The TCL_ENCODING_END flag is cleared after a final
* escape sequence has been added to the buffer so
* that another call to this method does not attempt
* to append escape bytes a second time.
*/
if ((dst + dataPtr->finalLen + (state?len:0)) > dstEnd) {
result = TCL_CONVERT_NOSPACE;
} else {
if (state) {
memcpy((VOID *) dst, (VOID *) dataPtr->subTables[0].sequence,
(size_t) len);
dst += len;
}
memcpy((VOID *) dst, (VOID *) dataPtr->final,
(size_t) dataPtr->finalLen);
dst += dataPtr->finalLen;
state &= ~TCL_ENCODING_END;
}
}
*statePtr = (Tcl_EncodingState) state;
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*---------------------------------------------------------------------------
*
* EscapeFreeProc --
*
* This procedure is invoked when an EscapeEncodingData encoding is
* deleted. It deletes the memory used by the encoding.
*
* Results:
* None.
*
* Side effects:
* Memory freed.
*
*---------------------------------------------------------------------------
*/
static void
EscapeFreeProc(clientData)
ClientData clientData; /* EscapeEncodingData that specifies encoding. */
{
EscapeEncodingData *dataPtr;
EscapeSubTable *subTablePtr;
int i;
dataPtr = (EscapeEncodingData *) clientData;
if (dataPtr == NULL) {
return;
}
/*
* The subTables should be freed recursively in normal operation but not
* during TclFinalizeEncodingSubsystem because they are also present as a
* weak reference in the toplevel encodingTable (ie they don't have a +1
* refcount for this), and unpredictable nuking order could remove them
* from under the following loop's feet [Bug 2891556].
*
* The encodingsInitialized flag, being reset on entry to TFES, can serve
* as a "not in finalization" test.
*/
if (encodingsInitialized)
{
subTablePtr = dataPtr->subTables;
for (i = 0; i < dataPtr->numSubTables; i++) {
FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr);
subTablePtr++;
}
}
ckfree((char *) dataPtr);
}
/*
*---------------------------------------------------------------------------
*
* GetTableEncoding --
*
* Helper function for the EscapeEncodingData conversions. Gets the
* encoding (of type TextEncodingData) that represents the specified
* state.
*
* Results:
* The return value is the encoding.
*
* Side effects:
* If the encoding that represents the specified state has not
* already been used by this EscapeEncoding, it will be loaded
* and cached in the dataPtr.
*
*---------------------------------------------------------------------------
*/
static Encoding *
GetTableEncoding(dataPtr, state)
EscapeEncodingData *dataPtr;/* Contains names of encodings. */
int state; /* Index in dataPtr of desired Encoding. */
{
EscapeSubTable *subTablePtr;
Encoding *encodingPtr;
subTablePtr = &dataPtr->subTables[state];
encodingPtr = subTablePtr->encodingPtr;
if (encodingPtr == NULL) {
/*
* Now that escape encodings load their sub-encodings first, and
* fail to load if any sub-encodings are missing, this branch should
* never happen.
*/
encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name);
if ((encodingPtr == NULL)
|| (encodingPtr->toUtfProc != TableToUtfProc)) {
panic("EscapeToUtfProc: invalid sub table");
}
subTablePtr->encodingPtr = encodingPtr;
}
return encodingPtr;
}
/*
*---------------------------------------------------------------------------
*
* unilen --
*
* A helper function for the Tcl_ExternalToUtf functions. This
* function is similar to strlen for double-byte characters: it
* returns the number of bytes in a 0x0000 terminated string.
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static size_t
unilen(src)
CONST char *src;
{
unsigned short *p;
p = (unsigned short *) src;
while (*p != 0x0000) {
p++;
}
return (char *) p - src;
}
/*
*-------------------------------------------------------------------------
*
* TclFindEncodings --
*
* Find and load the encoding file for this operating system.
* Before this is called, Tcl makes assumptions about the
* native string representation, but the true encoding is not
* assured.
*
* Results:
* Return result of TclpInitLibraryPath, which reports whether the
* path is clean (0) or dirty (1) UTF.
*
* Side effects:
* Varied, see the respective initialization routines.
*
*-------------------------------------------------------------------------
*/
static int
TclFindEncodings(argv0)
CONST char *argv0; /* Name of executable from argv[0] to main()
* in native multi-byte encoding. */
{
int mustCleanUtf = 0;
if (encodingsInitialized == 0) {
/*
* Double check inside the mutex. There may be calls
* back into this routine from some of the procedures below.
*/
TclpInitLock();
if (encodingsInitialized == 0) {
char *native;
Tcl_Obj *pathPtr;
Tcl_DString libPath, buffer;
/*
* Have to set this bit here to avoid deadlock with the
* routines below us that call into TclInitSubsystems.
*/
encodingsInitialized = 1;
native = TclpFindExecutable(argv0);
mustCleanUtf = TclpInitLibraryPath(native);
/*
* The library path was set in the TclpInitLibraryPath routine.
* The string set is a dirty UTF string. To preserve the value
* convert the UTF string back to native before setting the new
* default encoding.
*/
pathPtr = TclGetLibraryPath();
if ((pathPtr != NULL) && mustCleanUtf) {
Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), -1,
&libPath);
}
TclpSetInitialEncodings();
/*
* Now convert the native string back to UTF.
*/
if ((pathPtr != NULL) && mustCleanUtf) {
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&libPath), -1,
&buffer);
pathPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1);
TclSetLibraryPath(pathPtr);
Tcl_DStringFree(&libPath);
Tcl_DStringFree(&buffer);
}
}
TclpInitUnlock();
}
return mustCleanUtf;
}
tcl8.4.20/generic/tclLink.c 0000644 0036047 0045461 00000033751 11737050674 014110 0 ustar dgp 771div /*
* tclLink.c --
*
* This file implements linked variables (a C variable that is
* tied to a Tcl variable). The idea of linked variables was
* first suggested by Andreas Stolcke and this implementation is
* based heavily on a prototype implementation provided by
* him.
*
* Copyright (c) 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.
*/
#include "tclInt.h"
/*
* For each linked variable there is a data structure of the following
* type, which describes the link and is the clientData for the trace
* set on the Tcl variable.
*/
typedef struct Link {
Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
Tcl_Obj *varName; /* Name of variable (must be global). This
* is needed during trace callbacks, since
* the actual variable may be aliased at
* that time via upvar. */
char *addr; /* Location of C variable. */
int type; /* Type of link (TCL_LINK_INT, etc.). */
union {
int i;
double d;
Tcl_WideInt w;
} lastValue; /* Last known value of C variable; used to
* avoid string conversions. */
int flags; /* Miscellaneous one-bit values; see below
* for definitions. */
} Link;
/*
* Definitions for flag bits:
* LINK_READ_ONLY - 1 means errors should be generated if Tcl
* script attempts to write variable.
* LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar
* is in progress for this variable, so
* trace callbacks on the variable should
* be ignored.
*/
#define LINK_READ_ONLY 1
#define LINK_BEING_UPDATED 2
/*
* Forward references to procedures defined later in this file:
*/
static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
static Tcl_Obj * ObjValue _ANSI_ARGS_((Link *linkPtr));
/*
*----------------------------------------------------------------------
*
* Tcl_LinkVar --
*
* Link a C variable to a Tcl variable so that changes to either
* one causes the other to change.
*
* Results:
* The return value is TCL_OK if everything went well or TCL_ERROR
* if an error occurred (the interp's result is also set after
* errors).
*
* Side effects:
* The value at *addr is linked to the Tcl variable "varName",
* using "type" to convert between string values for Tcl and
* binary values for *addr.
*
*----------------------------------------------------------------------
*/
int
Tcl_LinkVar(interp, varName, addr, type)
Tcl_Interp *interp; /* Interpreter in which varName exists. */
CONST char *varName; /* Name of a global variable in interp. */
char *addr; /* Address of a C variable to be linked
* to varName. */
int type; /* Type of C variable: TCL_LINK_INT, etc.
* Also may have TCL_LINK_READ_ONLY
* OR'ed in. */
{
Tcl_Obj *objPtr, *resPtr;
Link *linkPtr;
int code;
linkPtr = (Link *) ckalloc(sizeof(Link));
linkPtr->interp = interp;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
} else {
linkPtr->flags = 0;
}
objPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(objPtr);
resPtr = Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(objPtr);
if (resPtr == NULL) {
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
return TCL_ERROR;
}
code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
(ClientData) linkPtr);
if (code != TCL_OK) {
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
}
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnlinkVar --
*
* Destroy the link between a Tcl variable and a C variable.
*
* Results:
* None.
*
* Side effects:
* If "varName" was previously linked to a C variable, the link
* is broken to make the variable independent. If there was no
* previous link for "varName" then nothing happens.
*
*----------------------------------------------------------------------
*/
void
Tcl_UnlinkVar(interp, varName)
Tcl_Interp *interp; /* Interpreter containing variable to unlink. */
CONST char *varName; /* Global variable in interp to unlink. */
{
Link *linkPtr;
linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
LinkTraceProc, (ClientData) NULL);
if (linkPtr == NULL) {
return;
}
Tcl_UntraceVar(interp, varName,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, (ClientData) linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpdateLinkedVar --
*
* This procedure is invoked after a linked variable has been
* changed by C code. It updates the Tcl variable so that
* traces on the variable will trigger.
*
* Results:
* None.
*
* Side effects:
* The Tcl variable "varName" is updated from its C value,
* causing traces on the variable to trigger.
*
*----------------------------------------------------------------------
*/
void
Tcl_UpdateLinkedVar(interp, varName)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *varName; /* Name of global variable that is linked. */
{
Link *linkPtr;
int savedFlag;
Tcl_Obj *objPtr;
linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
LinkTraceProc, (ClientData) NULL);
if (linkPtr == NULL) {
return;
}
savedFlag = linkPtr->flags & LINK_BEING_UPDATED;
linkPtr->flags |= LINK_BEING_UPDATED;
objPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
/*
* Callback may have unlinked the variable. [Bug 1740631]
*/
linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
LinkTraceProc, (ClientData) NULL);
if (linkPtr != NULL) {
linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
}
}
/*
*----------------------------------------------------------------------
*
* LinkTraceProc --
*
* This procedure is invoked when a linked Tcl variable is read,
* written, or unset from Tcl. It's responsible for keeping the
* C variable in sync with the Tcl variable.
*
* Results:
* If all goes well, NULL is returned; otherwise an error message
* is returned.
*
* Side effects:
* The C variable may be updated to make it consistent with the
* Tcl variable, or the Tcl variable may be overwritten to reject
* a modification.
*
*----------------------------------------------------------------------
*/
static char *
LinkTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Contains information about the link. */
Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
CONST char *name1; /* First part of variable name. */
CONST char *name2; /* Second part of variable name. */
int flags; /* Miscellaneous additional information. */
{
Link *linkPtr = (Link *) clientData;
int changed, valueLength;
CONST char *value;
char **pp, *result;
Tcl_Obj *objPtr, *valueObj, *tmpPtr;
/*
* If the variable is being unset, then just re-create it (with a
* trace) unless the whole interpreter is going away.
*/
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp)) {
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName),
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr);
}
return NULL;
}
/*
* If we were invoked because of a call to Tcl_UpdateLinkedVar, then
* don't do anything at all. In particular, we don't want to get
* upset that the variable is being modified, even if it is
* supposed to be read-only.
*/
if (linkPtr->flags & LINK_BEING_UPDATED) {
return NULL;
}
/*
* For read accesses, update the Tcl variable if the C variable
* has changed since the last time we updated the Tcl variable.
*/
if (flags & TCL_TRACE_READS) {
switch (linkPtr->type) {
case TCL_LINK_INT:
case TCL_LINK_BOOLEAN:
changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
break;
case TCL_LINK_DOUBLE:
changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
break;
case TCL_LINK_WIDE_INT:
changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w;
break;
case TCL_LINK_STRING:
changed = 1;
break;
default:
return "internal error: bad linked variable type";
}
if (changed) {
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
}
return NULL;
}
/*
* For writes, first make sure that the variable is writable. Then
* convert the Tcl value to C if possible. If the variable isn't
* writable or can't be converted, then restore the varaible's old
* value and return an error. Another tricky thing: we have to save
* and restore the interpreter's result, since the variable access
* could occur when the result has been partially set.
*/
if (linkPtr->flags & LINK_READ_ONLY) {
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
return "linked variable is read-only";
}
valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
if (valueObj == NULL) {
/*
* This shouldn't ever happen.
*/
return "internal error: linked variable couldn't be read";
}
objPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objPtr);
Tcl_ResetResult(interp);
result = NULL;
switch (linkPtr->type) {
case TCL_LINK_INT:
if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
result = "variable must have integer value";
goto end;
}
*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
break;
case TCL_LINK_WIDE_INT:
if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
result = "variable must have integer value";
goto end;
}
*(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
result = "variable must have real value";
goto end;
}
*(double *)(linkPtr->addr) = linkPtr->lastValue.d;
break;
case TCL_LINK_BOOLEAN:
if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
result = "variable must have boolean value";
goto end;
}
*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
break;
case TCL_LINK_STRING:
value = Tcl_GetStringFromObj(valueObj, &valueLength);
valueLength++;
pp = (char **)(linkPtr->addr);
if (*pp != NULL) {
ckfree(*pp);
}
*pp = (char *) ckalloc((unsigned) valueLength);
memcpy(*pp, value, (unsigned) valueLength);
break;
default:
return "internal error: bad linked variable type";
}
end:
Tcl_DecrRefCount(objPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* ObjValue --
*
* Converts the value of a C variable to a Tcl_Obj* for use in a
* Tcl variable to which it is linked.
*
* Results:
* The return value is a pointer to a Tcl_Obj that represents
* the value of the C variable given by linkPtr.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
ObjValue(linkPtr)
Link *linkPtr; /* Structure describing linked variable. */
{
char *p;
switch (linkPtr->type) {
case TCL_LINK_INT:
linkPtr->lastValue.i = *(int *)(linkPtr->addr);
return Tcl_NewIntObj(linkPtr->lastValue.i);
case TCL_LINK_WIDE_INT:
linkPtr->lastValue.w = *(Tcl_WideInt *)(linkPtr->addr);
return Tcl_NewWideIntObj(linkPtr->lastValue.w);
case TCL_LINK_DOUBLE:
linkPtr->lastValue.d = *(double *)(linkPtr->addr);
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
linkPtr->lastValue.i = *(int *)(linkPtr->addr);
return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
case TCL_LINK_STRING:
p = *(char **)(linkPtr->addr);
if (p == NULL) {
return Tcl_NewStringObj("NULL", 4);
}
return Tcl_NewStringObj(p, -1);
/*
* This code only gets executed if the link type is unknown
* (shouldn't ever happen).
*/
default:
return Tcl_NewStringObj("??", 2);
}
}
tcl8.4.20/generic/tclStringObj.c 0000644 0036047 0045461 00000157735 12052456744 015124 0 ustar dgp 771div /*
* tclStringObj.c --
*
* This file contains procedures that implement string operations on Tcl
* objects. Some string operations work with UTF strings and others
* require Unicode format. Functions that require knowledge of the width
* of each character, such as indexing, operate on Unicode data.
*
* A Unicode string is an internationalized string. Conceptually, a
* Unicode string is an array of 16-bit quantities organized as a sequence
* of properly formed UTF-8 characters. There is a one-to-one map between
* Unicode and UTF characters. Because Unicode characters have a fixed
* width, operations such as indexing operate on Unicode data. The String
* object is optimized for the case where each UTF char in a string is
* only one byte. In this case, we store the value of numChars, but we
* don't store the Unicode data (unless Tcl_GetUnicode is explicitly
* called).
*
* The String object type stores one or both formats. The default
* behavior is to store UTF. Once Unicode is calculated by a function, it
* is stored in the internal rep for future access (without an additional
* O(n) cost).
*
* To allow many appends to be done to an object without constantly
* reallocating the space for the string or Unicode representation, we
* allocate double the space for the string or Unicode and use the
* internal representation to keep track of how much space is used
* vs. allocated.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* Prototypes for procedures defined later in this file:
*/
static void AppendUnicodeToUnicodeRep _ANSI_ARGS_((
Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
int appendNumChars));
static void AppendUnicodeToUtfRep _ANSI_ARGS_((
Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
int numChars));
static void AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr,
CONST char *bytes, int numBytes));
static void AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr,
CONST char *bytes, int numBytes));
static void DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
Tcl_Obj *copyPtr));
static void FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void GrowUnicodeBuffer _ANSI_ARGS_((Tcl_Obj *objPtr,
int needed));
static int SetStringFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void SetUnicodeObj(Tcl_Obj *objPtr,
CONST Tcl_UniChar *unicode, int numChars);
static int UnicodeLength _ANSI_ARGS_((CONST Tcl_UniChar *unicode));
static void UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr));
/*
* The structure below defines the string Tcl object type by means of
* procedures that can be invoked by generic object code.
*/
Tcl_ObjType tclStringType = {
"string", /* name */
FreeStringInternalRep, /* freeIntRepPro */
DupStringInternalRep, /* dupIntRepProc */
UpdateStringOfString, /* updateStringProc */
SetStringFromAny /* setFromAnyProc */
};
/*
* The following structure is the internal rep for a String object.
* It keeps track of how much memory has been used and how much has been
* allocated for the Unicode and UTF string to enable growing and
* shrinking of the UTF and Unicode reps of the String object with fewer
* mallocs. To optimize string length and indexing operations, this
* structure also stores the number of characters (same of UTF and Unicode!)
* once that value has been computed.
*/
typedef struct String {
int numChars; /* The number of chars in the string.
* -1 means this value has not been
* calculated. >= 0 means that there is a
* valid Unicode rep, or that the number
* of UTF bytes == the number of chars. */
size_t allocated; /* The amount of space actually allocated
* for the UTF string (minus 1 byte for
* the termination char). */
size_t uallocated; /* The amount of space actually allocated
* for the Unicode string (minus 2 bytes for
* the termination char). */
int hasUnicode; /* Boolean determining whether the string
* has a Unicode representation. */
Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual
* size of this field depends on the
* 'uallocated' field above. */
} String;
#define STRING_MAXCHARS \
(1 + (int)(((size_t)UINT_MAX - sizeof(String))/sizeof(Tcl_UniChar)))
#define STRING_UALLOC(numChars) \
((numChars) * sizeof(Tcl_UniChar))
#define STRING_SIZE(ualloc) \
((unsigned) ((ualloc) \
? (sizeof(String) - sizeof(Tcl_UniChar) + (ualloc)) \
: sizeof(String)))
#define stringCheckLimits(numChars) \
if ((unsigned)(numChars) > (unsigned)(STRING_MAXCHARS)) { \
Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \
STRING_MAXCHARS); \
}
#define stringRealloc(ptr, numChars) \
(String *) ckrealloc((char *) ptr, \
(unsigned) STRING_SIZE(STRING_UALLOC(numChars)) )
#define stringAttemptRealloc(ptr, numChars) \
(String *) attemptckrealloc((char *) ptr, \
(unsigned) STRING_SIZE(STRING_UALLOC(numChars)) )
#define GET_STRING(objPtr) \
((String *) (objPtr)->internalRep.otherValuePtr)
#define SET_STRING(objPtr, stringPtr) \
(objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr)
/*
* TCL STRING GROWTH ALGORITHM
*
* When growing strings (during an append, for example), the following growth
* algorithm is used:
*
* Attempt to allocate 2 * (originalLength + appendLength)
* On failure:
* attempt to allocate originalLength + 2*appendLength +
* TCL_GROWTH_MIN_ALLOC
*
* This algorithm allows very good performance, as it rapidly increases the
* memory allocated for a given string, which minimizes the number of
* reallocations that must be performed. However, using only the doubling
* algorithm can lead to a significant waste of memory. In particular, it
* may fail even when there is sufficient memory available to complete the
* append request (but there is not 2 * totalLength memory available). So when
* the doubling fails (because there is not enough memory available), the
* algorithm requests a smaller amount of memory, which is still enough to
* cover the request, but which hopefully will be less than the total available
* memory.
*
* The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling
* of very small appends. Without this extra slush factor, a sequence
* of several small appends would cause several memory allocations.
* As long as TCL_GROWTH_MIN_ALLOC is a reasonable size, we can
* avoid that behavior.
*
* The growth algorithm can be tuned by adjusting the following parameters:
*
* TCL_GROWTH_MIN_ALLOC Additional space, in bytes, to allocate when
* the double allocation has failed.
* Default is 1024 (1 kilobyte).
*/
#ifndef TCL_GROWTH_MIN_ALLOC
#define TCL_GROWTH_MIN_ALLOC 1024
#endif
static void
GrowUnicodeBuffer(
Tcl_Obj *objPtr,
int needed)
{
/* Pre-conditions:
* objPtr->typePtr == &tclStringType
* STRING_UALLOC(needed) > stringPtr->uallocated
* needed < STRING_MAXCHARS
*/
String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
int attempt;
if (stringPtr->uallocated > 0) {
/* Subsequent appends - apply the growth algorithm. */
attempt = 2 * needed;
if (attempt >= 0 && attempt <= STRING_MAXCHARS) {
ptr = stringAttemptRealloc(stringPtr, attempt);
}
if (ptr == NULL) {
/*
* Take care computing the amount of modest growth to avoid
* overflow into invalid argument values for attempt.
*/
unsigned int limit = STRING_MAXCHARS - needed;
unsigned int extra = needed - stringPtr->numChars
+ TCL_GROWTH_MIN_ALLOC/sizeof(Tcl_UniChar);
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
ptr = stringAttemptRealloc(stringPtr, attempt);
}
}
if (ptr == NULL) {
/* First allocation - just big enough; or last chance fallback. */
attempt = needed;
ptr = stringRealloc(stringPtr, attempt);
}
stringPtr = ptr;
stringPtr->uallocated = STRING_UALLOC(attempt);
SET_STRING(objPtr, stringPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewStringObj --
*
* This procedure is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new string object and
* initializes it from the byte pointer and length arguments.
*
* When TCL_MEM_DEBUG is defined, this procedure just returns the
* result of calling the debugging version Tcl_DbNewStringObj.
*
* Results:
* A newly created string object is returned that has ref count zero.
*
* Side effects:
* The new object's internal string representation will be set to a
* copy of the length bytes starting at "bytes". If "length" is
* negative, use bytes up to the first NULL byte; i.e., assume "bytes"
* points to a C-style NULL-terminated string. The object's type is set
* to NULL. An extra NULL is added to the end of the new object's byte
* array.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj
Tcl_Obj *
Tcl_NewStringObj(bytes, length)
CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
int length; /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first
* NULL byte. */
{
return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewStringObj(bytes, length)
CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
int length; /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first
* NULL byte. */
{
register Tcl_Obj *objPtr;
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
}
TclNewObj(objPtr);
TclInitStringRep(objPtr, bytes, length);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewStringObj --
*
* This procedure is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new string objects. It is the
* same as the Tcl_NewStringObj procedure above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
* caller. This simplifies debugging since then the [memory active]
* command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
* result of calling Tcl_NewStringObj.
*
* Results:
* A newly created string object is returned that has ref count zero.
*
* Side effects:
* The new object's internal string representation will be set to a
* copy of the length bytes starting at "bytes". If "length" is
* negative, use bytes up to the first NULL byte; i.e., assume "bytes"
* points to a C-style NULL-terminated string. The object's type is set
* to NULL. An extra NULL is added to the end of the new object's byte
* array.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewStringObj(bytes, length, file, line)
CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
int length; /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first
* NULL byte. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
register Tcl_Obj *objPtr;
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
}
TclDbNewObj(objPtr, file, line);
TclInitStringRep(objPtr, bytes, length);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewStringObj(bytes, length, file, line)
CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
register int length; /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first
* NULL byte. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
return Tcl_NewStringObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
*
* Tcl_NewUnicodeObj --
*
* This procedure is creates a new String object and initializes
* it from the given Unicode String. If the Utf String is the same size
* as the Unicode string, don't duplicate the data.
*
* Results:
* The newly created object is returned. This object will have no
* initial string representation. The returned object has a ref count
* of 0.
*
* Side effects:
* Memory allocated for new object and copy of Unicode argument.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_NewUnicodeObj(unicode, numChars)
CONST Tcl_UniChar *unicode; /* The unicode string used to initialize
* the new object. */
int numChars; /* Number of characters in the unicode
* string. */
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
SetUnicodeObj(objPtr, unicode, numChars);
return objPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCharLength --
*
* Get the length of the Unicode string from the Tcl object.
*
* Results:
* Pointer to unicode string representing the unicode object.
*
* Side effects:
* Frees old internal rep. Allocates memory for new "String"
* internal rep.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetCharLength(objPtr)
Tcl_Obj *objPtr; /* The String object to get the num chars of. */
{
String *stringPtr;
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/*
* If numChars is unknown, then calculate the number of characaters
* while populating the Unicode string.
*/
if (stringPtr->numChars == -1) {
register int i = objPtr->length;
register unsigned char *str = (unsigned char *) objPtr->bytes;
/*
* This is a speed sensitive function, so run specially over the
* string to count continuous ascii characters before resorting
* to the Tcl_NumUtfChars call. This is a long form of:
stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length);
*/
while (i && (*str < 0xC0)) { i--; str++; }
stringPtr->numChars = objPtr->length - i;
if (i) {
stringPtr->numChars += Tcl_NumUtfChars(objPtr->bytes
+ (objPtr->length - i), i);
}
if (stringPtr->numChars == objPtr->length) {
/*
* Since we've just calculated the number of chars, and all
* UTF chars are 1-byte long, we don't need to store the
* unicode string.
*/
stringPtr->hasUnicode = 0;
} else {
/*
* Since we've just calucalated the number of chars, and not
* all UTF chars are 1-byte long, go ahead and populate the
* unicode string.
*/
FillUnicodeRep(objPtr);
/*
* We need to fetch the pointer again because we have just
* reallocated the structure to make room for the Unicode data.
*/
stringPtr = GET_STRING(objPtr);
}
}
return stringPtr->numChars;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetUniChar --
*
* Get the index'th Unicode character from the String object. The
* index is assumed to be in the appropriate range.
*
* Results:
* Returns the index'th Unicode character in the Object.
*
* Side effects:
* Fills unichar with the index'th Unicode character.
*
*----------------------------------------------------------------------
*/
Tcl_UniChar
Tcl_GetUniChar(objPtr, index)
Tcl_Obj *objPtr; /* The object to get the Unicode charater from. */
int index; /* Get the index'th Unicode character. */
{
Tcl_UniChar unichar;
String *stringPtr;
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->numChars == -1) {
/*
* We haven't yet calculated the length, so we don't have the
* Unicode str. We need to know the number of chars before we
* can do indexing.
*/
Tcl_GetCharLength(objPtr);
/*
* We need to fetch the pointer again because we may have just
* reallocated the structure.
*/
stringPtr = GET_STRING(objPtr);
}
if (stringPtr->hasUnicode == 0) {
/*
* All of the characters in the Utf string are 1 byte chars,
* so we don't store the unicode char. We get the Utf string
* and convert the index'th byte to a Unicode character.
*/
unichar = (Tcl_UniChar) objPtr->bytes[index];
} else {
unichar = stringPtr->unicode[index];
}
return unichar;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetUnicode --
*
* Get the Unicode form of the String object. If
* the object is not already a String object, it will be converted
* to one. If the String object does not have a Unicode rep, then
* one is create from the UTF string format.
*
* Results:
* Returns a pointer to the object's internal Unicode string.
*
* Side effects:
* Converts the object to have the String internal rep.
*
*----------------------------------------------------------------------
*/
Tcl_UniChar *
Tcl_GetUnicode(objPtr)
Tcl_Obj *objPtr; /* The object to find the unicode string for. */
{
String *stringPtr;
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
/*
* We haven't yet calculated the length, or all of the characters
* in the Utf string are 1 byte chars (so we didn't store the
* unicode str). Since this function must return a unicode string,
* and one has not yet been stored, force the Unicode to be
* calculated and stored now.
*/
FillUnicodeRep(objPtr);
/*
* We need to fetch the pointer again because we have just
* reallocated the structure to make room for the Unicode data.
*/
stringPtr = GET_STRING(objPtr);
}
return stringPtr->unicode;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetUnicodeFromObj --
*
* Get the Unicode form of the String object with length. If
* the object is not already a String object, it will be converted
* to one. If the String object does not have a Unicode rep, then
* one is create from the UTF string format.
*
* Results:
* Returns a pointer to the object's internal Unicode string.
*
* Side effects:
* Converts the object to have the String internal rep.
*
*----------------------------------------------------------------------
*/
Tcl_UniChar *
Tcl_GetUnicodeFromObj(objPtr, lengthPtr)
Tcl_Obj *objPtr; /* The object to find the unicode string for. */
int *lengthPtr; /* If non-NULL, the location where the
* string rep's unichar length should be
* stored. If NULL, no length is stored. */
{
String *stringPtr;
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
/*
* We haven't yet calculated the length, or all of the characters
* in the Utf string are 1 byte chars (so we didn't store the
* unicode str). Since this function must return a unicode string,
* and one has not yet been stored, force the Unicode to be
* calculated and stored now.
*/
FillUnicodeRep(objPtr);
/*
* We need to fetch the pointer again because we have just
* reallocated the structure to make room for the Unicode data.
*/
stringPtr = GET_STRING(objPtr);
}
if (lengthPtr != NULL) {
*lengthPtr = stringPtr->numChars;
}
return stringPtr->unicode;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetRange --
*
* Create a Tcl Object that contains the chars between first and last
* of the object indicated by "objPtr". If the object is not already
* a String object, convert it to one. The first and last indices
* are assumed to be in the appropriate range.
*
* Results:
* Returns a new Tcl Object of the String type.
*
* Side effects:
* Changes the internal rep of "objPtr" to the String type.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetRange(objPtr, first, last)
Tcl_Obj *objPtr; /* The Tcl object to find the range of. */
int first; /* First index of the range. */
int last; /* Last index of the range. */
{
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
String *stringPtr;
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->numChars == -1) {
/*
* We haven't yet calculated the length, so we don't have the
* Unicode str. We need to know the number of chars before we
* can do indexing.
*/
Tcl_GetCharLength(objPtr);
/*
* We need to fetch the pointer again because we may have just
* reallocated the structure.
*/
stringPtr = GET_STRING(objPtr);
}
if (objPtr->bytes && stringPtr->numChars == objPtr->length) {
char *str = Tcl_GetString(objPtr);
/*
* All of the characters in the Utf string are 1 byte chars,
* so we don't store the unicode char. Create a new string
* object containing the specified range of chars.
*/
newObjPtr = Tcl_NewStringObj(&str[first], last-first+1);
/*
* Since we know the new string only has 1-byte chars, we
* can set it's numChars field.
*/
SetStringFromAny(NULL, newObjPtr);
stringPtr = GET_STRING(newObjPtr);
stringPtr->numChars = last-first+1;
} else {
newObjPtr = Tcl_NewUnicodeObj(stringPtr->unicode + first,
last-first+1);
}
return newObjPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetStringObj --
*
* Modify an object to hold a string that is a copy of the bytes
* indicated by the byte pointer and length arguments.
*
* Results:
* None.
*
* Side effects:
* The object's string representation will be set to a copy of
* the "length" bytes starting at "bytes". If "length" is negative, use
* bytes up to the first NULL byte; i.e., assume "bytes" points to a
* C-style NULL-terminated string. The object's old string and internal
* representations are freed and the object's type is set NULL.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetStringObj(objPtr, bytes, length)
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the object. */
register int length; /* The number of bytes to copy from "bytes"
* when initializing the object. If
* negative, use bytes up to the first
* NULL byte.*/
{
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_SetStringObj called with shared object");
}
/*
* Set the type to NULL and free any internal rep for the old type.
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->typePtr = NULL;
/*
* Free any old string rep, then set the string rep to a copy of
* the length bytes starting at "bytes".
*/
Tcl_InvalidateStringRep(objPtr);
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
}
TclInitStringRep(objPtr, bytes, length);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjLength --
*
* This procedure changes the length of the string representation
* of an object.
*
* Results:
* None.
*
* Side effects:
* If the size of objPtr's string representation is greater than
* length, then it is reduced to length and a new terminating null
* byte is stored in the strength. If the length of the string
* representation is greater than length, the storage space is
* reallocated to the given length; a null byte is stored at the
* end, but other bytes past the end of the original string
* representation are undefined. The object's internal
* representation is changed to "expendable string".
*
*----------------------------------------------------------------------
*/
void
Tcl_SetObjLength(objPtr, length)
register Tcl_Obj *objPtr; /* Pointer to object. This object must
* not currently be shared. */
register int length; /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
String *stringPtr;
if (length < 0) {
/*
* Setting to a negative length is nonsense. This is probably the
* result of overflowing the signed integer range.
*/
Tcl_Panic("Tcl_SetObjLength: negative length requested: "
"%d (integer overflow?)", length);
}
if (Tcl_IsShared(objPtr)) {
panic("Tcl_SetObjLength called with shared object");
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/* Check that we're not extending a pure unicode string */
if ((size_t)length > stringPtr->allocated &&
(objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
char *new;
/*
* Not enough space in current string. Reallocate the string
* space and free the old string.
*/
if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) {
new = (char *) ckrealloc((char *)objPtr->bytes,
(unsigned)(length+1));
} else {
new = (char *) ckalloc((unsigned) (length+1));
if (objPtr->bytes != NULL && objPtr->length != 0) {
memcpy((VOID *) new, (VOID *) objPtr->bytes,
(size_t) objPtr->length);
Tcl_InvalidateStringRep(objPtr);
}
}
objPtr->bytes = new;
stringPtr->allocated = length;
/* Invalidate the unicode data. */
stringPtr->hasUnicode = 0;
}
if (objPtr->bytes != NULL) {
objPtr->length = length;
if (objPtr->bytes != tclEmptyStringRep) {
/* Ensure the string is NULL-terminated */
objPtr->bytes[length] = 0;
}
/* Invalidate the unicode data. */
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
} else {
/* Changing length of pure unicode string */
size_t uallocated = STRING_UALLOC(length);
stringCheckLimits(length);
if (uallocated > stringPtr->uallocated) {
stringPtr = stringRealloc(stringPtr, length);
SET_STRING(objPtr, stringPtr);
stringPtr->uallocated = uallocated;
}
stringPtr->numChars = length;
stringPtr->hasUnicode = (length > 0);
/* Ensure the string is NULL-terminated */
stringPtr->unicode[length] = 0;
stringPtr->allocated = 0;
objPtr->length = 0;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_AttemptSetObjLength --
*
* This procedure changes the length of the string representation
* of an object. It uses the attempt* (non-panic'ing) memory allocators.
*
* Results:
* 1 if the requested memory was allocated, 0 otherwise.
*
* Side effects:
* If the size of objPtr's string representation is greater than
* length, then it is reduced to length and a new terminating null
* byte is stored in the strength. If the length of the string
* representation is greater than length, the storage space is
* reallocated to the given length; a null byte is stored at the
* end, but other bytes past the end of the original string
* representation are undefined. The object's internal
* representation is changed to "expendable string".
*
*----------------------------------------------------------------------
*/
int
Tcl_AttemptSetObjLength(objPtr, length)
register Tcl_Obj *objPtr; /* Pointer to object. This object must
* not currently be shared. */
register int length; /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
String *stringPtr;
if (length < 0) {
/*
* Setting to a negative length is nonsense. This is probably the
* result of overflowing the signed integer range.
*/
return 0;
}
if (Tcl_IsShared(objPtr)) {
panic("Tcl_AttemptSetObjLength called with shared object");
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/* Check that we're not extending a pure unicode string */
if (length > (int) stringPtr->allocated &&
(objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
char *new;
/*
* Not enough space in current string. Reallocate the string
* space and free the old string.
*/
if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) {
new = (char *) attemptckrealloc((char *)objPtr->bytes,
(unsigned)(length+1));
if (new == NULL) {
return 0;
}
} else {
new = (char *) attemptckalloc((unsigned) (length+1));
if (new == NULL) {
return 0;
}
if (objPtr->bytes != NULL && objPtr->length != 0) {
memcpy((VOID *) new, (VOID *) objPtr->bytes,
(size_t) objPtr->length);
Tcl_InvalidateStringRep(objPtr);
}
}
objPtr->bytes = new;
stringPtr->allocated = length;
/* Invalidate the unicode data. */
stringPtr->hasUnicode = 0;
}
if (objPtr->bytes != NULL) {
objPtr->length = length;
if (objPtr->bytes != tclEmptyStringRep) {
/* Ensure the string is NULL-terminated */
objPtr->bytes[length] = 0;
}
/* Invalidate the unicode data. */
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
} else {
/* Changing length of pure unicode string */
size_t uallocated = STRING_UALLOC(length);
if (length > STRING_MAXCHARS) {
return 0;
}
if (uallocated > stringPtr->uallocated) {
stringPtr = stringAttemptRealloc(stringPtr, length);
if (stringPtr == NULL) {
return 0;
}
SET_STRING(objPtr, stringPtr);
stringPtr->uallocated = uallocated;
}
stringPtr->numChars = length;
stringPtr->hasUnicode = (length > 0);
/* Ensure the string is NULL-terminated */
stringPtr->unicode[length] = 0;
stringPtr->allocated = 0;
objPtr->length = 0;
}
return 1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_SetUnicodeObj --
*
* Modify an object to hold the Unicode string indicated by "unicode".
*
* Results:
* None.
*
* Side effects:
* Memory allocated for new "String" internal rep.
*
*---------------------------------------------------------------------------
*/
void
Tcl_SetUnicodeObj(objPtr, unicode, numChars)
Tcl_Obj *objPtr; /* The object to set the string of. */
CONST Tcl_UniChar *unicode; /* The unicode string used to initialize
* the object. */
int numChars; /* Number of characters in the unicode
* string. */
{
Tcl_ObjType *typePtr = objPtr->typePtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
}
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
typePtr->freeIntRepProc(objPtr);
}
SetUnicodeObj(objPtr, unicode, numChars);
}
static int
UnicodeLength(
CONST Tcl_UniChar *unicode)
{
int numChars = 0;
if (unicode) {
while (numChars >= 0 && unicode[numChars] != 0) {
numChars++;
}
}
stringCheckLimits(numChars);
return numChars;
}
static void
SetUnicodeObj(objPtr, unicode, numChars)
Tcl_Obj *objPtr; /* The object to set the string of. */
CONST Tcl_UniChar *unicode; /* The unicode string used to initialize
* the object. */
int numChars; /* Number of characters in the unicode
* string. */
{
String *stringPtr;
size_t uallocated;
if (numChars < 0) {
numChars = UnicodeLength(unicode);
}
/*
* Allocate enough space for the String structure + Unicode string.
*/
stringCheckLimits(numChars);
uallocated = STRING_UALLOC(numChars);
stringPtr = (String *) ckalloc(STRING_SIZE(uallocated));
stringPtr->numChars = numChars;
stringPtr->uallocated = uallocated;
stringPtr->hasUnicode = (numChars > 0);
stringPtr->allocated = 0;
memcpy((VOID *) stringPtr->unicode, (VOID *) unicode, uallocated);
stringPtr->unicode[numChars] = 0;
Tcl_InvalidateStringRep(objPtr);
objPtr->typePtr = &tclStringType;
SET_STRING(objPtr, stringPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendToObj --
*
* This procedure appends a sequence of bytes to an object.
*
* Results:
* None.
*
* Side effects:
* The bytes at *bytes are appended to the string representation
* of objPtr.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendToObj(objPtr, bytes, length)
register Tcl_Obj *objPtr; /* Points to the object to append to. */
CONST char *bytes; /* Points to the bytes to append to the
* object. */
register int length; /* The number of bytes to append from
* "bytes". If < 0, then append all bytes
* up to NULL byte. */
{
String *stringPtr;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_AppendToObj called with shared object");
}
SetStringFromAny(NULL, objPtr);
if (length < 0) {
length = (bytes ? strlen(bytes) : 0);
}
if (length == 0) {
return;
}
/*
* If objPtr has a valid Unicode rep, then append the Unicode
* conversion of "bytes" to the objPtr's Unicode rep, otherwise
* append "bytes" to objPtr's string rep.
*/
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode != 0) {
AppendUtfToUnicodeRep(objPtr, bytes, length);
stringPtr = GET_STRING(objPtr);
} else {
AppendUtfToUtfRep(objPtr, bytes, length);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendUnicodeToObj --
*
* This procedure appends a Unicode string to an object in the
* most efficient manner possible. Length must be >= 0.
*
* Results:
* None.
*
* Side effects:
* Invalidates the string rep and creates a new Unicode string.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendUnicodeToObj(objPtr, unicode, length)
register Tcl_Obj *objPtr; /* Points to the object to append to. */
CONST Tcl_UniChar *unicode; /* The unicode string to append to the
* object. */
int length; /* Number of chars in "unicode". */
{
String *stringPtr;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_AppendUnicodeToObj called with shared object");
}
if (length == 0) {
return;
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/*
* If objPtr has a valid Unicode rep, then append the "unicode"
* to the objPtr's Unicode rep, otherwise the UTF conversion of
* "unicode" to objPtr's string rep.
*/
if (stringPtr->hasUnicode != 0) {
AppendUnicodeToUnicodeRep(objPtr, unicode, length);
} else {
AppendUnicodeToUtfRep(objPtr, unicode, length);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendObjToObj --
*
* This procedure appends the string rep of one object to another.
* "objPtr" cannot be a shared object.
*
* Results:
* None.
*
* Side effects:
* The string rep of appendObjPtr is appended to the string
* representation of objPtr.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendObjToObj(objPtr, appendObjPtr)
Tcl_Obj *objPtr; /* Points to the object to append to. */
Tcl_Obj *appendObjPtr; /* Object to append. */
{
String *stringPtr;
int length, numChars, allOneByteChars;
char *bytes;
SetStringFromAny(NULL, objPtr);
/*
* If objPtr has a valid Unicode rep, then get a Unicode string
* from appendObjPtr and append it.
*/
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode != 0) {
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
if (appendObjPtr->typePtr == &tclStringType) {
stringPtr = GET_STRING(appendObjPtr);
if ((stringPtr->numChars == -1)
|| (stringPtr->hasUnicode == 0)) {
/*
* If appendObjPtr is a string obj with no valid Unicode
* rep, then fill its unicode rep.
*/
FillUnicodeRep(appendObjPtr);
stringPtr = GET_STRING(appendObjPtr);
}
AppendUnicodeToUnicodeRep(objPtr, stringPtr->unicode,
stringPtr->numChars);
} else {
bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
AppendUtfToUnicodeRep(objPtr, bytes, length);
}
return;
}
/*
* Append to objPtr's UTF string rep. If we know the number of
* characters in both objects before appending, then set the combined
* number of characters in the final (appended-to) object.
*/
bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
allOneByteChars = 0;
numChars = stringPtr->numChars;
if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) {
stringPtr = GET_STRING(appendObjPtr);
if ((stringPtr->numChars >= 0) && (stringPtr->numChars == length)) {
numChars += stringPtr->numChars;
allOneByteChars = 1;
}
}
AppendUtfToUtfRep(objPtr, bytes, length);
if (allOneByteChars) {
stringPtr = GET_STRING(objPtr);
stringPtr->numChars = numChars;
}
}
/*
*----------------------------------------------------------------------
*
* AppendUnicodeToUnicodeRep --
*
* This procedure appends the contents of "unicode" to the Unicode
* rep of "objPtr". objPtr must already have a valid Unicode rep.
*
* Results:
* None.
*
* Side effects:
* objPtr's internal rep is reallocated.
*
*----------------------------------------------------------------------
*/
static void
AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
Tcl_Obj *objPtr; /* Points to the object to append to. */
CONST Tcl_UniChar *unicode; /* String to append. */
int appendNumChars; /* Number of chars of "unicode" to append. */
{
String *stringPtr;
size_t numChars;
if (appendNumChars < 0) {
appendNumChars = UnicodeLength(unicode);
}
if (appendNumChars == 0) {
return;
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/*
* If not enough space has been allocated for the unicode rep,
* reallocate the internal rep object with additional space. First
* try to double the required allocation; if that fails, try a more
* modest increase. See the "TCL STRING GROWTH ALGORITHM" comment at
* the top of this file for an explanation of this growth algorithm.
*/
numChars = stringPtr->numChars + appendNumChars;
stringCheckLimits(numChars);
if (STRING_UALLOC(numChars) > stringPtr->uallocated) {
/*
* Protect against case where unicode points into the existing
* stringPtr->unicode array. Force it to follow any relocations
* due to the reallocs below.
*/
int offset = -1;
if (unicode >= stringPtr->unicode && unicode <= stringPtr->unicode
+ stringPtr->uallocated / sizeof(Tcl_UniChar)) {
offset = unicode - stringPtr->unicode;
}
GrowUnicodeBuffer(objPtr, numChars);
stringPtr = GET_STRING(objPtr);
/* Relocate unicode if needed; see above. */
if (offset >= 0) {
unicode = stringPtr->unicode + offset;
}
}
/*
* Copy the new string onto the end of the old string, then add the
* trailing null.
*/
memcpy((VOID*) (stringPtr->unicode + stringPtr->numChars), unicode,
appendNumChars * sizeof(Tcl_UniChar));
stringPtr->unicode[numChars] = 0;
stringPtr->numChars = numChars;
stringPtr->allocated = 0;
Tcl_InvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* AppendUnicodeToUtfRep --
*
* This procedure converts the contents of "unicode" to UTF and
* appends the UTF to the string rep of "objPtr".
*
* Results:
* None.
*
* Side effects:
* objPtr's internal rep is reallocated.
*
*----------------------------------------------------------------------
*/
static void
AppendUnicodeToUtfRep(objPtr, unicode, numChars)
Tcl_Obj *objPtr; /* Points to the object to append to. */
CONST Tcl_UniChar *unicode; /* String to convert to UTF. */
int numChars; /* Number of chars of "unicode" to convert. */
{
Tcl_DString dsPtr;
CONST char *bytes;
if (numChars < 0) {
numChars = UnicodeLength(unicode);
}
if (numChars == 0) {
return;
}
Tcl_DStringInit(&dsPtr);
bytes = Tcl_UniCharToUtfDString(unicode, numChars, &dsPtr);
AppendUtfToUtfRep(objPtr, bytes, Tcl_DStringLength(&dsPtr));
Tcl_DStringFree(&dsPtr);
}
/*
*----------------------------------------------------------------------
*
* AppendUtfToUnicodeRep --
*
* This procedure converts the contents of "bytes" to Unicode and
* appends the Unicode to the Unicode rep of "objPtr". objPtr must
* already have a valid Unicode rep.
*
* Results:
* None.
*
* Side effects:
* objPtr's internal rep is reallocated.
*
*----------------------------------------------------------------------
*/
static void
AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
Tcl_Obj *objPtr; /* Points to the object to append to. */
CONST char *bytes; /* String to convert to Unicode. */
int numBytes; /* Number of bytes of "bytes" to convert. */
{
Tcl_DString dsPtr;
int numChars;
Tcl_UniChar *unicode;
if (numBytes < 0) {
numBytes = (bytes ? strlen(bytes) : 0);
}
if (numBytes == 0) {
return;
}
Tcl_DStringInit(&dsPtr);
numChars = Tcl_NumUtfChars(bytes, numBytes);
unicode = (Tcl_UniChar *)Tcl_UtfToUniCharDString(bytes, numBytes, &dsPtr);
AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
Tcl_DStringFree(&dsPtr);
}
/*
*----------------------------------------------------------------------
*
* AppendUtfToUtfRep --
*
* This procedure appends "numBytes" bytes of "bytes" to the UTF string
* rep of "objPtr". objPtr must already have a valid String rep.
*
* Results:
* None.
*
* Side effects:
* objPtr's internal rep is reallocated.
*
*----------------------------------------------------------------------
*/
static void
AppendUtfToUtfRep(objPtr, bytes, numBytes)
Tcl_Obj *objPtr; /* Points to the object to append to. */
CONST char *bytes; /* String to append. */
int numBytes; /* Number of bytes of "bytes" to append. */
{
String *stringPtr;
int newLength, oldLength;
if (numBytes < 0) {
numBytes = (bytes ? strlen(bytes) : 0);
}
if (numBytes == 0) {
return;
}
/*
* Copy the new string onto the end of the old string, then add the
* trailing null.
*/
oldLength = objPtr->length;
newLength = numBytes + oldLength;
if (newLength < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
stringPtr = GET_STRING(objPtr);
if (newLength > (int) stringPtr->allocated) {
/*
* Protect against case where unicode points into the existing
* stringPtr->unicode array. Force it to follow any relocations
* due to the reallocs below.
*/
int offset = -1;
if (bytes >= objPtr->bytes
&& bytes <= objPtr->bytes + objPtr->length) {
offset = bytes - objPtr->bytes;
}
/*
* There isn't currently enough space in the string representation
* so allocate additional space. First, try to double the length
* required. If that fails, try a more modest allocation. See the
* "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
* explanation of this growth algorithm.
*/
if (Tcl_AttemptSetObjLength(objPtr, 2 * newLength) == 0) {
/*
* Take care computing the amount of modest growth to avoid
* overflow into invalid argument values for Tcl_SetObjLength.
*/
unsigned int limit = INT_MAX - newLength;
unsigned int extra = numBytes + TCL_GROWTH_MIN_ALLOC;
int growth = (int) ((extra > limit) ? limit : extra);
Tcl_SetObjLength(objPtr, newLength + growth);
}
/* Relocate bytes if needed; see above. */
if (offset >=0) {
bytes = objPtr->bytes + offset;
}
}
/*
* Invalidate the unicode data.
*/
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
memcpy((VOID *) (objPtr->bytes + oldLength), (VOID *) bytes,
(size_t) numBytes);
objPtr->bytes[newLength] = 0;
objPtr->length = newLength;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendStringsToObjVA --
*
* This procedure appends one or more null-terminated strings
* to an object.
*
* Results:
* None.
*
* Side effects:
* The contents of all the string arguments are appended to the
* string representation of objPtr.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendStringsToObjVA (objPtr, argList)
Tcl_Obj *objPtr; /* Points to the object to append to. */
va_list argList; /* Variable argument list. */
{
#define STATIC_LIST_SIZE 16
String *stringPtr;
int newLength, oldLength, attemptLength;
register char *string, *dst;
char *static_list[STATIC_LIST_SIZE];
char **args = static_list;
int nargs_space = STATIC_LIST_SIZE;
int nargs, i;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_AppendStringsToObj called with shared object");
}
SetStringFromAny(NULL, objPtr);
/*
* Force the existence of a string rep. so we avoid crashes operating
* on a pure unicode value. [Bug 2597185]
*/
(void) Tcl_GetStringFromObj(objPtr, &oldLength);
/*
* Figure out how much space is needed for all the strings, and
* expand the string representation if it isn't big enough. If no
* bytes would be appended, just return. Note that on some platforms
* (notably OS/390) the argList is an array so we need to use memcpy.
*/
nargs = 0;
newLength = 0;
while (1) {
string = va_arg(argList, char *);
if (string == NULL) {
break;
}
if (nargs >= nargs_space) {
/*
* Expand the args buffer
*/
nargs_space += STATIC_LIST_SIZE;
if (args == static_list) {
args = (void *)ckalloc(nargs_space * sizeof(char *));
for (i = 0; i < nargs; ++i) {
args[i] = static_list[i];
}
} else {
args = (void *)ckrealloc((void *)args,
nargs_space * sizeof(char *));
}
}
newLength += strlen(string);
args[nargs++] = string;
}
if (newLength == 0) {
goto done;
}
stringPtr = GET_STRING(objPtr);
if (oldLength + newLength > (int) stringPtr->allocated) {
/*
* There isn't currently enough space in the string
* representation, so allocate additional space. If the current
* string representation isn't empty (i.e. it looks like we're
* doing a series of appends) then try to allocate extra space to
* accomodate future growth: first try to double the required memory;
* if that fails, try a more modest allocation. See the "TCL STRING
* GROWTH ALGORITHM" comment at the top of this file for an explanation
* of this growth algorithm. Otherwise, if the current string
* representation is empty, exactly enough memory is allocated.
*/
if (oldLength == 0) {
Tcl_SetObjLength(objPtr, newLength);
} else {
attemptLength = 2 * (oldLength + newLength);
if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) {
attemptLength = oldLength + (2 * newLength) +
TCL_GROWTH_MIN_ALLOC;
Tcl_SetObjLength(objPtr, attemptLength);
}
}
}
/*
* Make a second pass through the arguments, appending all the
* strings to the object.
*/
dst = objPtr->bytes + oldLength;
for (i = 0; i < nargs; ++i) {
string = args[i];
if (string == NULL) {
break;
}
while (*string != 0) {
*dst = *string;
dst++;
string++;
}
}
/*
* Add a null byte to terminate the string. However, be careful:
* it's possible that the object is totally empty (if it was empty
* originally and there was nothing to append). In this case dst is
* NULL; just leave everything alone.
*/
if (dst != NULL) {
*dst = 0;
}
objPtr->length = oldLength + newLength;
done:
/*
* If we had to allocate a buffer from the heap,
* free it now.
*/
if (args != static_list) {
ckfree((void *)args);
}
#undef STATIC_LIST_SIZE
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendStringsToObj --
*
* This procedure appends one or more null-terminated strings
* to an object.
*
* Results:
* None.
*
* Side effects:
* The contents of all the string arguments are appended to the
* string representation of objPtr.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1)
{
register Tcl_Obj *objPtr;
va_list argList;
objPtr = TCL_VARARGS_START(Tcl_Obj *,arg1,argList);
Tcl_AppendStringsToObjVA(objPtr, argList);
va_end(argList);
}
/*
*---------------------------------------------------------------------------
*
* FillUnicodeRep --
*
* Populate the Unicode internal rep with the Unicode form of its string
* rep. The object must alread have a "String" internal rep.
*
* Results:
* None.
*
* Side effects:
* Reallocates the String internal rep.
*
*---------------------------------------------------------------------------
*/
static void
FillUnicodeRep(objPtr)
Tcl_Obj *objPtr; /* The object in which to fill the unicode rep. */
{
String *stringPtr;
size_t uallocated;
char *src, *srcEnd;
Tcl_UniChar *dst;
src = objPtr->bytes;
stringPtr = GET_STRING(objPtr);
if (stringPtr->numChars == -1) {
stringPtr->numChars = Tcl_NumUtfChars(src, objPtr->length);
}
stringPtr->hasUnicode = (stringPtr->numChars > 0);
stringCheckLimits(stringPtr->numChars);
uallocated = STRING_UALLOC(stringPtr->numChars);
if (uallocated > stringPtr->uallocated) {
GrowUnicodeBuffer(objPtr, stringPtr->numChars);
stringPtr = GET_STRING(objPtr);
}
/*
* Convert src to Unicode and store the coverted data in "unicode".
*/
srcEnd = src + objPtr->length;
for (dst = stringPtr->unicode; src < srcEnd; dst++) {
src += TclUtfToUniChar(src, dst);
}
*dst = 0;
SET_STRING(objPtr, stringPtr);
}
/*
*----------------------------------------------------------------------
*
* DupStringInternalRep --
*
* Initialize the internal representation of a new Tcl_Obj to a
* copy of the internal representation of an existing string object.
*
* Results:
* None.
*
* Side effects:
* copyPtr's internal rep is set to a copy of srcPtr's internal
* representation.
*
*----------------------------------------------------------------------
*/
static void
DupStringInternalRep(srcPtr, copyPtr)
register Tcl_Obj *srcPtr; /* Object with internal rep to copy. Must
* have an internal rep of type "String". */
register Tcl_Obj *copyPtr; /* Object with internal rep to set. Must
* not currently have an internal rep.*/
{
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
/*
* If the src obj is a string of 1-byte Utf chars, then copy the
* string rep of the source object and create an "empty" Unicode
* internal rep for the new object. Otherwise, copy Unicode
* internal rep, and invalidate the string rep of the new object.
*/
if (srcStringPtr->hasUnicode == 0) {
copyStringPtr = (String *) ckalloc(sizeof(String));
copyStringPtr->uallocated = 0;
} else {
copyStringPtr = (String *) ckalloc(
STRING_SIZE(srcStringPtr->uallocated));
copyStringPtr->uallocated = srcStringPtr->uallocated;
memcpy((VOID *) copyStringPtr->unicode,
(VOID *) srcStringPtr->unicode,
(size_t) srcStringPtr->numChars * sizeof(Tcl_UniChar));
copyStringPtr->unicode[srcStringPtr->numChars] = 0;
}
copyStringPtr->numChars = srcStringPtr->numChars;
copyStringPtr->hasUnicode = srcStringPtr->hasUnicode;
copyStringPtr->allocated = srcStringPtr->allocated;
/*
* Tricky point: the string value was copied by generic object
* management code, so it doesn't contain any extra bytes that
* might exist in the source object.
*/
copyStringPtr->allocated = copyPtr->length;
SET_STRING(copyPtr, copyStringPtr);
copyPtr->typePtr = &tclStringType;
}
/*
*----------------------------------------------------------------------
*
* SetStringFromAny --
*
* Create an internal representation of type "String" for an object.
*
* Results:
* This operation always succeeds and returns TCL_OK.
*
* Side effects:
* Any old internal reputation for objPtr is freed and the
* internal representation is set to "String".
*
*----------------------------------------------------------------------
*/
static int
SetStringFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
/*
* The Unicode object is optimized for the case where each UTF char
* in a string is only one byte. In this case, we store the value of
* numChars, but we don't copy the bytes to the unicodeObj->unicode.
*/
if (objPtr->typePtr != &tclStringType) {
String *stringPtr;
if (objPtr->typePtr != NULL) {
if (objPtr->bytes == NULL) {
objPtr->typePtr->updateStringProc(objPtr);
}
if ((objPtr->typePtr->freeIntRepProc) != NULL) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
}
objPtr->typePtr = &tclStringType;
/*
* Allocate enough space for the basic String structure.
*/
stringPtr = (String *) ckalloc(sizeof(String));
stringPtr->numChars = -1;
stringPtr->uallocated = 0;
stringPtr->hasUnicode = 0;
if (objPtr->bytes != NULL) {
stringPtr->allocated = objPtr->length;
if (objPtr->bytes != tclEmptyStringRep) {
objPtr->bytes[objPtr->length] = 0;
}
} else {
objPtr->length = 0;
}
SET_STRING(objPtr, stringPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfString --
*
* Update the string representation for an object whose internal
* representation is "String".
*
* Results:
* None.
*
* Side effects:
* The object's string may be set by converting its Unicode
* represention to UTF format.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfString(objPtr)
Tcl_Obj *objPtr; /* Object with string rep to update. */
{
int i, size;
Tcl_UniChar *unicode;
char dummy[TCL_UTF_MAX];
char *dst;
String *stringPtr;
stringPtr = GET_STRING(objPtr);
if ((objPtr->bytes == NULL) || (stringPtr->allocated == 0)) {
if (stringPtr->numChars <= 0) {
/*
* If there is no Unicode rep, or the string has 0 chars,
* then set the string rep to an empty string.
*/
objPtr->bytes = tclEmptyStringRep;
objPtr->length = 0;
return;
}
unicode = stringPtr->unicode;
/*
* Translate the Unicode string to UTF. "size" will hold the
* amount of space the UTF string needs.
*/
if (stringPtr->numChars <= INT_MAX/TCL_UTF_MAX
&& stringPtr->allocated >= (size_t) (stringPtr->numChars * TCL_UTF_MAX)) {
goto copyBytes;
}
size = 0;
for (i = 0; i < stringPtr->numChars && size >= 0; i++) {
size += Tcl_UniCharToUtf((int) unicode[i], dummy);
}
if (size < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
objPtr->bytes = (char *) ckalloc((unsigned) (size + 1));
objPtr->length = size;
stringPtr->allocated = size;
copyBytes:
dst = objPtr->bytes;
for (i = 0; i < stringPtr->numChars; i++) {
dst += Tcl_UniCharToUtf(unicode[i], dst);
}
*dst = '\0';
}
return;
}
/*
*----------------------------------------------------------------------
*
* FreeStringInternalRep --
*
* Deallocate the storage associated with a String data object's
* internal representation.
*
* Results:
* None.
*
* Side effects:
* Frees memory.
*
*----------------------------------------------------------------------
*/
static void
FreeStringInternalRep(objPtr)
Tcl_Obj *objPtr; /* Object with internal rep to free. */
{
ckfree((char *) GET_STRING(objPtr));
}
tcl8.4.20/generic/tclLoadNone.c 0000644 0036047 0045461 00000007206 11737050674 014706 0 ustar dgp 771div /*
* tclLoadNone.c --
*
* This procedure provides a version of the TclLoadFile for use
* in systems that don't support dynamic loading; it just returns
* an error.
*
* Copyright (c) 1995-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.
*/
#include "tclInt.h"
/*
*----------------------------------------------------------------------
*
* TclpDlopen --
*
* This procedure is called to carry out dynamic loading of binary
* code; it is intended for use only on systems that don't support
* dynamic loading (it returns an error).
*
* Results:
* The result is TCL_ERROR, and an error message is left in
* the interp's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr;
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for
* this file. */
{
Tcl_SetResult(interp,
"dynamic loading is not currently available on this system",
TCL_STATIC);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclpFindSymbol --
*
* Looks up a symbol, by name, through a handle associated with
* a previously loaded piece of code (shared library).
*
* Results:
* Returns a pointer to the function associated with 'symbol' if
* it is found. Otherwise returns NULL and may leave an error
* message in the interp's result.
*
*----------------------------------------------------------------------
*/
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
{
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
* If the "load" command is invoked without providing a package
* name, this procedure is invoked to try to figure it out.
*
* Results:
* Always returns 0 to indicate that we couldn't figure out a
* package name; generic code will then try to guess the package
* from the file name. A return value of 1 would have meant that
* we figured out the package name and put it in bufPtr.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclGuessPackageName(fileName, bufPtr)
CONST char *fileName; /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr; /* Initialized empty dstring. Append
* package name to this if possible. */
{
return 0;
}
/*
*----------------------------------------------------------------------
*
* TclpUnloadFile --
*
* This procedure is called to carry out dynamic unloading of binary
* code; it is intended for use only on systems that don't support
* dynamic loading (it does nothing).
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclpUnloadFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
}
tcl8.4.20/generic/tclLiteral.c 0000644 0036047 0045461 00000075241 11737050674 014607 0 ustar dgp 771div /*
* tclLiteral.c --
*
* Implementation of the global and ByteCode-local literal tables
* used to manage the Tcl objects created for literal values during
* compilation of Tcl scripts. This implementation borrows heavily
* from the more general hashtable implementation of Tcl hash tables
* that appears in tclHash.c.
*
* Copyright (c) 1997-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.
*/
#include "tclInt.h"
#include "tclCompile.h"
#include "tclPort.h"
/*
* When there are this many entries per bucket, on average, rebuild
* a literal's hash table to make it larger.
*/
#define REBUILD_MULTIPLIER 3
/*
* Procedure prototypes for static procedures in this file:
*/
static int AddLocalLiteralEntry _ANSI_ARGS_((
CompileEnv *envPtr, LiteralEntry *globalPtr,
int localHash));
static void ExpandLocalLiteralArray _ANSI_ARGS_((
CompileEnv *envPtr));
static unsigned int HashString _ANSI_ARGS_((CONST char *bytes,
int length));
static void RebuildLiteralTable _ANSI_ARGS_((
LiteralTable *tablePtr));
/*
*----------------------------------------------------------------------
*
* TclInitLiteralTable --
*
* This procedure is called to initialize the fields of a literal table
* structure for either an interpreter or a compilation's CompileEnv
* structure.
*
* Results:
* None.
*
* Side effects:
* The literal table is made ready for use.
*
*----------------------------------------------------------------------
*/
void
TclInitLiteralTable(tablePtr)
register LiteralTable *tablePtr; /* Pointer to table structure, which
* is supplied by the caller. */
{
#if (TCL_SMALL_HASH_TABLE != 4)
panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
TCL_SMALL_HASH_TABLE);
#endif
tablePtr->buckets = tablePtr->staticBuckets;
tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
tablePtr->numEntries = 0;
tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
tablePtr->mask = 3;
}
/*
*----------------------------------------------------------------------
*
* TclDeleteLiteralTable --
*
* This procedure frees up everything associated with a literal table
* except for the table's structure itself.
*
* Results:
* None.
*
* Side effects:
* Each literal in the table is released: i.e., its reference count
* in the global literal table is decremented and, if it becomes zero,
* the literal is freed. In addition, the table's bucket array is
* freed.
*
*----------------------------------------------------------------------
*/
void
TclDeleteLiteralTable(interp, tablePtr)
Tcl_Interp *interp; /* Interpreter containing shared literals
* referenced by the table to delete. */
LiteralTable *tablePtr; /* Points to the literal table to delete. */
{
LiteralEntry *entryPtr;
int i, start;
/*
* Release remaining literals in the table. Note that releasing a
* literal might release other literals, modifying the table, so we
* restart the search from the bucket chain we last found an entry.
*/
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable((Interp *) interp);
#endif /*TCL_COMPILE_DEBUG*/
start = 0;
while (tablePtr->numEntries > 0) {
for (i = start; i < tablePtr->numBuckets; i++) {
entryPtr = tablePtr->buckets[i];
if (entryPtr != NULL) {
TclReleaseLiteral(interp, entryPtr->objPtr);
start = i;
break;
}
}
}
/*
* Free up the table's bucket array if it was dynamically allocated.
*/
if (tablePtr->buckets != tablePtr->staticBuckets) {
ckfree((char *) tablePtr->buckets);
}
}
/*
*----------------------------------------------------------------------
*
* TclRegisterLiteral --
*
* Find, or if necessary create, an object in a CompileEnv literal
* array that has a string representation matching the argument string.
*
* Results:
* The index in the CompileEnv's literal array that references a
* shared literal matching the string. The object is created if
* necessary.
*
* Side effects:
* To maximize sharing, we look up the string in the interpreter's
* global literal table. If not found, we create a new shared literal
* in the global table. We then add a reference to the shared
* literal in the CompileEnv's literal array.
*
* If onHeap is 1, this procedure is given ownership of the string: if
* an object is created then its string representation is set directly
* from string, otherwise the string is freed. Typically, a caller sets
* onHeap 1 if "string" is an already heap-allocated buffer holding the
* result of backslash substitutions.
*
*----------------------------------------------------------------------
*/
int
TclRegisterLiteral(envPtr, bytes, length, onHeap)
CompileEnv *envPtr; /* Points to the CompileEnv in whose object
* array an object is found or created. */
register char *bytes; /* Points to string for which to find or
* create an object in CompileEnv's object
* array. */
int length; /* Number of bytes in the string. If < 0,
* the string consists of all bytes up to
* the first null character. */
int onHeap; /* If 1 then the caller already malloc'd
* bytes and ownership is passed to this
* procedure. */
{
Interp *iPtr = envPtr->iPtr;
LiteralTable *globalTablePtr = &(iPtr->literalTable);
LiteralTable *localTablePtr = &(envPtr->localLitTable);
register LiteralEntry *globalPtr, *localPtr;
register Tcl_Obj *objPtr;
unsigned int hash;
int localHash, globalHash, objIndex;
long n;
char buf[TCL_INTEGER_SPACE];
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
}
hash = HashString(bytes, length);
/*
* Is the literal already in the CompileEnv's local literal array?
* If so, just return its index.
*/
localHash = (hash & localTablePtr->mask);
for (localPtr = localTablePtr->buckets[localHash];
localPtr != NULL; localPtr = localPtr->nextPtr) {
objPtr = localPtr->objPtr;
if ((objPtr->length == length) && ((length == 0)
|| ((objPtr->bytes[0] == bytes[0])
&& (memcmp(objPtr->bytes, bytes, (unsigned) length)
== 0)))) {
if (onHeap) {
ckfree(bytes);
}
objIndex = (localPtr - envPtr->literalArrayPtr);
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/
return objIndex;
}
}
/*
* The literal is new to this CompileEnv. Is it in the interpreter's
* global literal table?
*/
globalHash = (hash & globalTablePtr->mask);
for (globalPtr = globalTablePtr->buckets[globalHash];
globalPtr != NULL; globalPtr = globalPtr->nextPtr) {
objPtr = globalPtr->objPtr;
if ((objPtr->length == length) && ((length == 0)
|| ((objPtr->bytes[0] == bytes[0])
&& (memcmp(objPtr->bytes, bytes, (unsigned) length)
== 0)))) {
/*
* A global literal was found. Add an entry to the CompileEnv's
* local literal array.
*/
if (onHeap) {
ckfree(bytes);
}
objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
if (globalPtr->refCount < 1) {
panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
(length>60? 60 : length), bytes,
globalPtr->refCount);
}
TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/
return objIndex;
}
}
/*
* The literal is new to the interpreter. Add it to the global literal
* table then add an entry to the CompileEnv's local literal array.
* Convert the object to an integer object if possible.
*/
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
if (onHeap) {
objPtr->bytes = bytes;
objPtr->length = length;
} else {
TclInitStringRep(objPtr, bytes, length);
}
if (TclLooksLikeInt(bytes, length)) {
/*
* From here we use the objPtr, because it is NULL terminated
*/
if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) {
TclFormatInt(buf, n);
if (strcmp(objPtr->bytes, buf) == 0) {
objPtr->internalRep.longValue = n;
objPtr->typePtr = &tclIntType;
}
}
}
#ifdef TCL_COMPILE_DEBUG
if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
(length>60? 60 : length), bytes);
}
#endif
globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
globalPtr->objPtr = objPtr;
globalPtr->refCount = 0;
globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
globalTablePtr->buckets[globalHash] = globalPtr;
globalTablePtr->numEntries++;
/*
* If the global literal table has exceeded a decent size, rebuild it
* with more buckets.
*/
if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
RebuildLiteralTable(globalTablePtr);
}
objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable(iPtr);
TclVerifyLocalLiteralTable(envPtr);
{
LiteralEntry *entryPtr;
int found, i;
found = 0;
for (i = 0; i < globalTablePtr->numBuckets; i++) {
for (entryPtr = globalTablePtr->buckets[i];
entryPtr != NULL; entryPtr = entryPtr->nextPtr) {
if ((entryPtr == globalPtr)
&& (entryPtr->objPtr == objPtr)) {
found = 1;
}
}
}
if (!found) {
panic("TclRegisterLiteral: literal \"%.*s\" wasn't global",
(length>60? 60 : length), bytes);
}
}
#endif /*TCL_COMPILE_DEBUG*/
#ifdef TCL_COMPILE_STATS
iPtr->stats.numLiteralsCreated++;
iPtr->stats.totalLitStringBytes += (double) (length + 1);
iPtr->stats.currentLitStringBytes += (double) (length + 1);
iPtr->stats.literalCount[TclLog2(length)]++;
#endif /*TCL_COMPILE_STATS*/
return objIndex;
}
/*
*----------------------------------------------------------------------
*
* TclLookupLiteralEntry --
*
* Finds the LiteralEntry that corresponds to a literal Tcl object
* holding a literal.
*
* Results:
* Returns the matching LiteralEntry if found, otherwise NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
LiteralEntry *
TclLookupLiteralEntry(interp, objPtr)
Tcl_Interp *interp; /* Interpreter for which objPtr was created
* to hold a literal. */
register Tcl_Obj *objPtr; /* Points to a Tcl object holding a
* literal that was previously created by a
* call to TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &(iPtr->literalTable);
register LiteralEntry *entryPtr;
char *bytes;
int length, globalHash;
bytes = Tcl_GetStringFromObj(objPtr, &length);
globalHash = (HashString(bytes, length) & globalTablePtr->mask);
for (entryPtr = globalTablePtr->buckets[globalHash];
entryPtr != NULL; entryPtr = entryPtr->nextPtr) {
if (entryPtr->objPtr == objPtr) {
return entryPtr;
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclHideLiteral --
*
* Remove a literal entry from the literal hash tables, leaving it in
* the literal array so existing references continue to function.
* This makes it possible to turn a shared literal into a private
* literal that cannot be shared.
*
* Results:
* None.
*
* Side effects:
* Removes the literal from the local hash table and decrements the
* global hash entry's reference count.
*
*----------------------------------------------------------------------
*/
void
TclHideLiteral(interp, envPtr, index)
Tcl_Interp *interp; /* Interpreter for which objPtr was created
* to hold a literal. */
register CompileEnv *envPtr; /* Points to CompileEnv whose literal array
* contains the entry being hidden. */
int index; /* The index of the entry in the literal
* array. */
{
LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
LiteralTable *localTablePtr = &(envPtr->localLitTable);
int localHash, length;
char *bytes;
Tcl_Obj *newObjPtr;
lPtr = &(envPtr->literalArrayPtr[index]);
/*
* To avoid unwanted sharing we need to copy the object and remove it from
* the local and global literal tables. It still has a slot in the literal
* array so it can be referred to by byte codes, but it will not be matched
* by literal searches.
*/
newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
Tcl_IncrRefCount(newObjPtr);
TclReleaseLiteral(interp, lPtr->objPtr);
lPtr->objPtr = newObjPtr;
bytes = Tcl_GetStringFromObj(newObjPtr, &length);
localHash = (HashString(bytes, length) & localTablePtr->mask);
nextPtrPtr = &localTablePtr->buckets[localHash];
for (entryPtr = *nextPtrPtr; entryPtr != NULL; entryPtr = *nextPtrPtr) {
if (entryPtr == lPtr) {
*nextPtrPtr = lPtr->nextPtr;
lPtr->nextPtr = NULL;
localTablePtr->numEntries--;
break;
}
nextPtrPtr = &entryPtr->nextPtr;
}
}
/*
*----------------------------------------------------------------------
*
* TclAddLiteralObj --
*
* Add a single literal object to the literal array. This
* function does not add the literal to the local or global
* literal tables. The caller is expected to add the entry
* to whatever tables are appropriate.
*
* Results:
* The index in the CompileEnv's literal array that references the
* literal. Stores the pointer to the new literal entry in the
* location referenced by the localPtrPtr argument.
*
* Side effects:
* Expands the literal array if necessary. Increments the refcount
* on the literal object.
*
*----------------------------------------------------------------------
*/
int
TclAddLiteralObj(envPtr, objPtr, litPtrPtr)
register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
* array the object is to be inserted. */
Tcl_Obj *objPtr; /* The object to insert into the array. */
LiteralEntry **litPtrPtr; /* The location where the pointer to the
* new literal entry should be stored.
* May be NULL. */
{
register LiteralEntry *lPtr;
int objIndex;
if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
ExpandLocalLiteralArray(envPtr);
}
objIndex = envPtr->literalArrayNext;
envPtr->literalArrayNext++;
lPtr = &(envPtr->literalArrayPtr[objIndex]);
lPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
lPtr->refCount = -1; /* i.e., unused */
lPtr->nextPtr = NULL;
if (litPtrPtr) {
*litPtrPtr = lPtr;
}
return objIndex;
}
/*
*----------------------------------------------------------------------
*
* AddLocalLiteralEntry --
*
* Insert a new literal into a CompileEnv's local literal array.
*
* Results:
* The index in the CompileEnv's literal array that references the
* literal.
*
* Side effects:
* Increments the ref count of the global LiteralEntry since the
* CompileEnv now refers to the literal. Expands the literal array
* if necessary. May rebuild the hash bucket array of the CompileEnv's
* literal array if it becomes too large.
*
*----------------------------------------------------------------------
*/
static int
AddLocalLiteralEntry(envPtr, globalPtr, localHash)
register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
* array the object is to be inserted. */
LiteralEntry *globalPtr; /* Points to the global LiteralEntry for
* the literal to add to the CompileEnv. */
int localHash; /* Hash value for the literal's string. */
{
register LiteralTable *localTablePtr = &(envPtr->localLitTable);
LiteralEntry *localPtr;
int objIndex;
objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr);
/*
* Add the literal to the local table.
*/
localPtr->nextPtr = localTablePtr->buckets[localHash];
localTablePtr->buckets[localHash] = localPtr;
localTablePtr->numEntries++;
globalPtr->refCount++;
/*
* If the CompileEnv's local literal table has exceeded a decent size,
* rebuild it with more buckets.
*/
if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {
RebuildLiteralTable(localTablePtr);
}
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(envPtr);
{
char *bytes;
int length, found, i;
found = 0;
for (i = 0; i < localTablePtr->numBuckets; i++) {
for (localPtr = localTablePtr->buckets[i];
localPtr != NULL; localPtr = localPtr->nextPtr) {
if (localPtr->objPtr == globalPtr->objPtr) {
found = 1;
}
}
}
if (!found) {
bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",
(length>60? 60 : length), bytes);
}
}
#endif /*TCL_COMPILE_DEBUG*/
return objIndex;
}
/*
*----------------------------------------------------------------------
*
* ExpandLocalLiteralArray --
*
* Procedure that uses malloc to allocate more storage for a
* CompileEnv's local literal array.
*
* Results:
* None.
*
* Side effects:
* The literal array in *envPtr is reallocated to a new array of
* double the size, and if envPtr->mallocedLiteralArray is non-zero
* the old array is freed. Entries are copied from the old array
* to the new one. The local literal table is updated to refer to
* the new entries.
*
*----------------------------------------------------------------------
*/
static void
ExpandLocalLiteralArray(envPtr)
register CompileEnv *envPtr; /* Points to the CompileEnv whose object
* array must be enlarged. */
{
/*
* The current allocated local literal entries are stored between
* elements 0 and (envPtr->literalArrayNext - 1) [inclusive].
*/
LiteralTable *localTablePtr = &(envPtr->localLitTable);
int currElems = envPtr->literalArrayNext;
size_t currBytes = (currElems * sizeof(LiteralEntry));
register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
register LiteralEntry *newArrayPtr =
(LiteralEntry *) ckalloc((unsigned) (2 * currBytes));
int i;
/*
* Copy from the old literal array to the new, then update the local
* literal table's bucket array.
*/
memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes);
for (i = 0; i < currElems; i++) {
if (currArrayPtr[i].nextPtr == NULL) {
newArrayPtr[i].nextPtr = NULL;
} else {
newArrayPtr[i].nextPtr = newArrayPtr
+ (currArrayPtr[i].nextPtr - currArrayPtr);
}
}
for (i = 0; i < localTablePtr->numBuckets; i++) {
if (localTablePtr->buckets[i] != NULL) {
localTablePtr->buckets[i] = newArrayPtr
+ (localTablePtr->buckets[i] - currArrayPtr);
}
}
/*
* Free the old literal array if needed, and mark the new literal
* array as malloced.
*/
if (envPtr->mallocedLiteralArray) {
ckfree((char *) currArrayPtr);
}
envPtr->literalArrayPtr = newArrayPtr;
envPtr->literalArrayEnd = (2 * currElems);
envPtr->mallocedLiteralArray = 1;
}
/*
*----------------------------------------------------------------------
*
* TclReleaseLiteral --
*
* This procedure releases a reference to one of the shared Tcl objects
* that hold literals. It is called to release the literals referenced
* by a ByteCode that is being destroyed, and it is also called by
* TclDeleteLiteralTable.
*
* Results:
* None.
*
* Side effects:
* The reference count for the global LiteralTable entry that
* corresponds to the literal is decremented. If no other reference
* to a global literal object remains, it is freed.
*
*----------------------------------------------------------------------
*/
void
TclReleaseLiteral(interp, objPtr)
Tcl_Interp *interp; /* Interpreter for which objPtr was created
* to hold a literal. */
register Tcl_Obj *objPtr; /* Points to a literal object that was
* previously created by a call to
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &(iPtr->literalTable);
register LiteralEntry *entryPtr, *prevPtr;
ByteCode* codePtr;
char *bytes;
int length, index;
bytes = Tcl_GetStringFromObj(objPtr, &length);
index = (HashString(bytes, length) & globalTablePtr->mask);
/*
* Check to see if the object is in the global literal table and
* remove this reference. The object may not be in the table if
* it is a hidden local literal.
*/
for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index];
entryPtr != NULL;
prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) {
if (entryPtr->objPtr == objPtr) {
entryPtr->refCount--;
/*
* If the literal is no longer being used by any ByteCode,
* delete the entry then remove the reference corresponding
* to the global literal table entry (decrement the ref count
* of the object).
*/
if (entryPtr->refCount == 0) {
if (prevPtr == NULL) {
globalTablePtr->buckets[index] = entryPtr->nextPtr;
} else {
prevPtr->nextPtr = entryPtr->nextPtr;
}
ckfree((char *) entryPtr);
globalTablePtr->numEntries--;
TclDecrRefCount(objPtr);
/*
* Check if the LiteralEntry is only being kept alive by
* a circular reference from a ByteCode stored as its
* internal rep. In that case, set the ByteCode object array
* entry NULL to signal to TclCleanupByteCode to not try to
* release this about to be freed literal again.
*/
if (objPtr->typePtr == &tclByteCodeType) {
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
if ((codePtr->numLitObjects == 1)
&& (codePtr->objArrayPtr[0] == objPtr)) {
codePtr->objArrayPtr[0] = NULL;
}
}
#ifdef TCL_COMPILE_STATS
iPtr->stats.currentLitStringBytes -= (double) (length + 1);
#endif /*TCL_COMPILE_STATS*/
}
break;
}
}
/*
* Remove the reference corresponding to the local literal table
* entry.
*/
Tcl_DecrRefCount(objPtr);
}
/*
*----------------------------------------------------------------------
*
* HashString --
*
* Compute a one-word summary of a text string, which can be
* used to generate a hash index.
*
* Results:
* The return value is a one-word summary of the information in
* string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static unsigned int
HashString(bytes, length)
register CONST char *bytes; /* String for which to compute hash
* value. */
int length; /* Number of bytes in the string. */
{
register unsigned int result;
register int i;
/*
* I tried a zillion different hash functions and asked many other
* people for advice. Many people had their own favorite functions,
* all different, but no-one had much idea why they were good ones.
* I chose the one below (multiply by 9 and add new character)
* because of the following reasons:
*
* 1. Multiplying by 10 is perfect for keys that are decimal strings,
* and multiplying by 9 is just about as good.
* 2. Times-9 is (shift-left-3) plus (old). This means that each
* character's bits hang around in the low-order bits of the
* hash value for ever, plus they spread fairly rapidly up to
* the high-order bits to fill out the hash value. This seems
* works well both for decimal and non-decimal strings.
*/
result = 0;
for (i = 0; i < length; i++) {
result += (result<<3) + *bytes++;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* RebuildLiteralTable --
*
* This procedure is invoked when the ratio of entries to hash buckets
* becomes too large in a local or global literal table. It allocates
* a larger bucket array and moves the entries into the new buckets.
*
* Results:
* None.
*
* Side effects:
* Memory gets reallocated and entries get rehashed into new buckets.
*
*----------------------------------------------------------------------
*/
static void
RebuildLiteralTable(tablePtr)
register LiteralTable *tablePtr; /* Local or global table to enlarge. */
{
LiteralEntry **oldBuckets;
register LiteralEntry **oldChainPtr, **newChainPtr;
register LiteralEntry *entryPtr;
LiteralEntry **bucketPtr;
char *bytes;
int oldSize, count, index, length;
oldSize = tablePtr->numBuckets;
oldBuckets = tablePtr->buckets;
/*
* Allocate and initialize the new bucket array, and set up
* hashing constants for new array size.
*/
tablePtr->numBuckets *= 4;
tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
(tablePtr->numBuckets * sizeof(LiteralEntry *)));
for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
count > 0;
count--, newChainPtr++) {
*newChainPtr = NULL;
}
tablePtr->rebuildSize *= 4;
tablePtr->mask = (tablePtr->mask << 2) + 3;
/*
* Rehash all of the existing entries into the new bucket array.
*/
for (oldChainPtr = oldBuckets;
oldSize > 0;
oldSize--, oldChainPtr++) {
for (entryPtr = *oldChainPtr; entryPtr != NULL;
entryPtr = *oldChainPtr) {
bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);
index = (HashString(bytes, length) & tablePtr->mask);
*oldChainPtr = entryPtr->nextPtr;
bucketPtr = &(tablePtr->buckets[index]);
entryPtr->nextPtr = *bucketPtr;
*bucketPtr = entryPtr;
}
}
/*
* Free up the old bucket array, if it was dynamically allocated.
*/
if (oldBuckets != tablePtr->staticBuckets) {
ckfree((char *) oldBuckets);
}
}
#ifdef TCL_COMPILE_STATS
/*
*----------------------------------------------------------------------
*
* TclLiteralStats --
*
* Return statistics describing the layout of the hash table
* in its hash buckets.
*
* Results:
* The return value is a malloc-ed string containing information
* about tablePtr. It is the caller's responsibility to free
* this string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
TclLiteralStats(tablePtr)
LiteralTable *tablePtr; /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
int count[NUM_COUNTERS], overflow, i, j;
double average, tmp;
register LiteralEntry *entryPtr;
char *result, *p;
/*
* Compute a histogram of bucket usage. For each bucket chain i,
* j is the number of entries in the chain.
*/
for (i = 0; i < NUM_COUNTERS; i++) {
count[i] = 0;
}
overflow = 0;
average = 0.0;
for (i = 0; i < tablePtr->numBuckets; i++) {
j = 0;
for (entryPtr = tablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
j++;
}
if (j < NUM_COUNTERS) {
count[j]++;
} else {
overflow++;
}
tmp = j;
average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
}
/*
* Print out the histogram and a few other pieces of information.
*/
result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
sprintf(result, "%d entries in table, %d buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i = 0; i < NUM_COUNTERS; i++) {
sprintf(p, "number of buckets with %d entries: %d\n",
i, count[i]);
p += strlen(p);
}
sprintf(p, "number of buckets with %d or more entries: %d\n",
NUM_COUNTERS, overflow);
p += strlen(p);
sprintf(p, "average search distance for entry: %.1f", average);
return result;
}
#endif /*TCL_COMPILE_STATS*/
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
* TclVerifyLocalLiteralTable --
*
* Check a CompileEnv's local literal table for consistency.
*
* Results:
* None.
*
* Side effects:
* Panics if problems are found.
*
*----------------------------------------------------------------------
*/
void
TclVerifyLocalLiteralTable(envPtr)
CompileEnv *envPtr; /* Points to CompileEnv whose literal
* table is to be validated. */
{
register LiteralTable *localTablePtr = &(envPtr->localLitTable);
register LiteralEntry *localPtr;
char *bytes;
register int i;
int length, count;
count = 0;
for (i = 0; i < localTablePtr->numBuckets; i++) {
for (localPtr = localTablePtr->buckets[i];
localPtr != NULL; localPtr = localPtr->nextPtr) {
count++;
if (localPtr->refCount != -1) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
(length>60? 60 : length), bytes,
localPtr->refCount);
}
if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
localPtr->objPtr) == NULL) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
(length>60? 60 : length), bytes);
}
if (localPtr->objPtr->bytes == NULL) {
panic("TclVerifyLocalLiteralTable: literal has NULL string rep");
}
}
}
if (count != localTablePtr->numEntries) {
panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",
count, localTablePtr->numEntries);
}
}
/*
*----------------------------------------------------------------------
*
* TclVerifyGlobalLiteralTable --
*
* Check an interpreter's global literal table literal for consistency.
*
* Results:
* None.
*
* Side effects:
* Panics if problems are found.
*
*----------------------------------------------------------------------
*/
void
TclVerifyGlobalLiteralTable(iPtr)
Interp *iPtr; /* Points to interpreter whose global
* literal table is to be validated. */
{
register LiteralTable *globalTablePtr = &(iPtr->literalTable);
register LiteralEntry *globalPtr;
char *bytes;
register int i;
int length, count;
count = 0;
for (i = 0; i < globalTablePtr->numBuckets; i++) {
for (globalPtr = globalTablePtr->buckets[i];
globalPtr != NULL; globalPtr = globalPtr->nextPtr) {
count++;
if (globalPtr->refCount < 1) {
bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d",
(length>60? 60 : length), bytes,
globalPtr->refCount);
}
if (globalPtr->objPtr->bytes == NULL) {
panic("TclVerifyGlobalLiteralTable: literal has NULL string rep");
}
}
}
if (count != globalTablePtr->numEntries) {
panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d",
count, globalTablePtr->numEntries);
}
}
#endif /*TCL_COMPILE_DEBUG*/
tcl8.4.20/generic/tclIOSock.c 0000644 0036047 0045461 00000005565 12052456744 014343 0 ustar dgp 771div /*
* tclIOSock.c --
*
* Common routines used by all socket based channel types.
*
* Copyright (c) 1995-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.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
*---------------------------------------------------------------------------
*
* TclSockGetPort --
*
* Maps from a string, which could be a service name, to a port.
* Used by socket creation code to get port numbers and resolve
* registered service names to port numbers.
*
* Results:
* A standard Tcl result. On success, the port number is returned
* in portPtr. On failure, an error message is left in the interp's
* result.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
TclSockGetPort(interp, string, proto, portPtr)
Tcl_Interp *interp;
char *string; /* Integer or service name */
char *proto; /* "tcp" or "udp", typically */
int *portPtr; /* Return port number */
{
struct servent *sp; /* Protocol info for named services */
Tcl_DString ds;
CONST char *native;
if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) {
/*
* Don't bother translating 'proto' to native.
*/
native = Tcl_UtfToExternalDString(NULL, string, -1, &ds);
sp = getservbyname(native, proto); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (sp != NULL) {
*portPtr = ntohs((unsigned short) sp->s_port);
return TCL_OK;
}
}
if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) {
return TCL_ERROR;
}
if (*portPtr > 0xFFFF) {
Tcl_AppendResult(interp, "couldn't open socket: port number too high",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclSockMinimumBuffers --
*
* Ensure minimum buffer sizes (non zero).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets SO_SNDBUF and SO_RCVBUF sizes.
*
*----------------------------------------------------------------------
*/
#undef TclSockMinimumBuffers
#if !defined(_WIN32) && !defined(__CYGWIN__)
# define SOCKET int
#endif
int
TclSockMinimumBuffers(sock, size)
void *sock; /* Socket file descriptor */
int size; /* Minimum buffer size */
{
int current;
socklen_t len;
len = sizeof(int);
getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len);
if (current < size) {
len = sizeof(int);
setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len);
}
len = sizeof(int);
getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len);
if (current < size) {
len = sizeof(int);
setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len);
}
return TCL_OK;
}
tcl8.4.20/generic/tclResult.c 0000644 0036047 0045461 00000067334 11737050674 014475 0 ustar dgp 771div /*
* tclResult.c --
*
* This file contains code to manage the interpreter result.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* Function prototypes for local procedures in this file:
*/
static void ResetObjResult _ANSI_ARGS_((Interp *iPtr));
static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
int newSpace));
/*
*----------------------------------------------------------------------
*
* Tcl_SaveResult --
*
* Takes a snapshot of the current result state of the interpreter.
* The snapshot can be restored at any point by
* Tcl_RestoreResult. Note that this routine does not
* preserve the errorCode, errorInfo, or flags fields so it
* should not be used if an error is in progress.
*
* Once a snapshot is saved, it must be restored by calling
* Tcl_RestoreResult, or discarded by calling
* Tcl_DiscardResult.
*
* Results:
* None.
*
* Side effects:
* Resets the interpreter result.
*
*----------------------------------------------------------------------
*/
void
Tcl_SaveResult(interp, statePtr)
Tcl_Interp *interp; /* Interpreter to save. */
Tcl_SavedResult *statePtr; /* Pointer to state structure. */
{
Interp *iPtr = (Interp *) interp;
/*
* Move the result object into the save state. Note that we don't need
* to change its refcount because we're moving it, not adding a new
* reference. Put an empty object into the interpreter.
*/
statePtr->objResultPtr = iPtr->objResultPtr;
iPtr->objResultPtr = Tcl_NewObj();
Tcl_IncrRefCount(iPtr->objResultPtr);
/*
* Save the string result.
*/
statePtr->freeProc = iPtr->freeProc;
if (iPtr->result == iPtr->resultSpace) {
/*
* Copy the static string data out of the interp buffer.
*/
statePtr->result = statePtr->resultSpace;
strcpy(statePtr->result, iPtr->result);
statePtr->appendResult = NULL;
} else if (iPtr->result == iPtr->appendResult) {
/*
* Move the append buffer out of the interp.
*/
statePtr->appendResult = iPtr->appendResult;
statePtr->appendAvl = iPtr->appendAvl;
statePtr->appendUsed = iPtr->appendUsed;
statePtr->result = statePtr->appendResult;
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
} else {
/*
* Move the dynamic or static string out of the interpreter.
*/
statePtr->result = iPtr->result;
statePtr->appendResult = NULL;
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
iPtr->freeProc = 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RestoreResult --
*
* Restores the state of the interpreter to a snapshot taken
* by Tcl_SaveResult. After this call, the token for
* the interpreter state is no longer valid.
*
* Results:
* None.
*
* Side effects:
* Restores the interpreter result.
*
*----------------------------------------------------------------------
*/
void
Tcl_RestoreResult(interp, statePtr)
Tcl_Interp* interp; /* Interpreter being restored. */
Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
{
Interp *iPtr = (Interp *) interp;
Tcl_ResetResult(interp);
/*
* Restore the string result.
*/
iPtr->freeProc = statePtr->freeProc;
if (statePtr->result == statePtr->resultSpace) {
/*
* Copy the static string data into the interp buffer.
*/
iPtr->result = iPtr->resultSpace;
strcpy(iPtr->result, statePtr->result);
} else if (statePtr->result == statePtr->appendResult) {
/*
* Move the append buffer back into the interp.
*/
if (iPtr->appendResult != NULL) {
ckfree((char *)iPtr->appendResult);
}
iPtr->appendResult = statePtr->appendResult;
iPtr->appendAvl = statePtr->appendAvl;
iPtr->appendUsed = statePtr->appendUsed;
iPtr->result = iPtr->appendResult;
} else {
/*
* Move the dynamic or static string back into the interpreter.
*/
iPtr->result = statePtr->result;
}
/*
* Restore the object result.
*/
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = statePtr->objResultPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DiscardResult --
*
* Frees the memory associated with an interpreter snapshot
* taken by Tcl_SaveResult. If the snapshot is not
* restored, this procedure must be called to discard it,
* or the memory will be lost.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_DiscardResult(statePtr)
Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
{
TclDecrRefCount(statePtr->objResultPtr);
if (statePtr->result == statePtr->appendResult) {
ckfree(statePtr->appendResult);
} else if (statePtr->freeProc) {
if (statePtr->freeProc == TCL_DYNAMIC) {
ckfree(statePtr->result);
} else {
(*statePtr->freeProc)(statePtr->result);
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetResult --
*
* Arrange for "string" to be the Tcl return value.
*
* Results:
* None.
*
* Side effects:
* interp->result is left pointing either to "string" (if "copy" is 0)
* or to a copy of string. Also, the object result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetResult(interp, string, freeProc)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return value. */
register char *string; /* Value to be returned. If NULL, the
* result is set to an empty string. */
Tcl_FreeProc *freeProc; /* Gives information about the string:
* TCL_STATIC, TCL_VOLATILE, or the address
* of a Tcl_FreeProc such as free. */
{
Interp *iPtr = (Interp *) interp;
int length;
register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
char *oldResult = iPtr->result;
if (string == NULL) {
iPtr->resultSpace[0] = 0;
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
} else if (freeProc == TCL_VOLATILE) {
length = strlen(string);
if (length > TCL_RESULT_SIZE) {
iPtr->result = (char *) ckalloc((unsigned) length+1);
iPtr->freeProc = TCL_DYNAMIC;
} else {
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
}
strcpy(iPtr->result, string);
} else {
iPtr->result = string;
iPtr->freeProc = freeProc;
}
/*
* If the old result was dynamically-allocated, free it up. Do it
* here, rather than at the beginning, in case the new result value
* was part of the old result value.
*/
if (oldFreeProc != 0) {
if (oldFreeProc == TCL_DYNAMIC) {
ckfree(oldResult);
} else {
(*oldFreeProc)(oldResult);
}
}
/*
* Reset the object result since we just set the string result.
*/
ResetObjResult(iPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetStringResult --
*
* Returns an interpreter's result value as a string.
*
* Results:
* The interpreter's result as a string.
*
* Side effects:
* If the string result is empty, the object result is moved to the
* string result, then the object result is reset.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_GetStringResult(interp)
register Tcl_Interp *interp; /* Interpreter whose result to return. */
{
/*
* If the string result is empty, move the object result to the
* string result, then reset the object result.
*/
if (*(interp->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
return interp->result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjResult --
*
* Arrange for objPtr to be an interpreter's result value.
*
* Results:
* None.
*
* Side effects:
* interp->objResultPtr is left pointing to the object referenced
* by objPtr. The object's reference count is incremented since
* there is now a new reference to it. The reference count for any
* old objResultPtr value is decremented. Also, the string result
* is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetObjResult(interp, objPtr)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return object value. */
register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
* obj result is made an empty string
* object. */
{
register Interp *iPtr = (Interp *) interp;
register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
iPtr->objResultPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
/*
* We wait until the end to release the old object result, in case
* we are setting the result to itself.
*/
TclDecrRefCount(oldObjResult);
/*
* Reset the string result since we just set the result object.
*/
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetObjResult --
*
* Returns an interpreter's result value as a Tcl object. The object's
* reference count is not modified; the caller must do that if it
* needs to hold on to a long-term reference to it.
*
* Results:
* The interpreter's result as an object.
*
* Side effects:
* If the interpreter has a non-empty string result, the result object
* is either empty or stale because some procedure set interp->result
* directly. If so, the string result is moved to the result object
* then the string result is reset.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetObjResult(interp)
Tcl_Interp *interp; /* Interpreter whose result to return. */
{
register Interp *iPtr = (Interp *) interp;
Tcl_Obj *objResultPtr;
int length;
/*
* If the string result is non-empty, move the string result to the
* object result, then reset the string result.
*/
if (*(iPtr->result) != 0) {
ResetObjResult(iPtr);
objResultPtr = iPtr->objResultPtr;
length = strlen(iPtr->result);
TclInitStringRep(objResultPtr, iPtr->result, length);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
}
return iPtr->objResultPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendResultVA --
*
* Append a variable number of strings onto the interpreter's string
* result.
*
* Results:
* None.
*
* Side effects:
* The result of the interpreter given by the first argument is
* extended by the strings in the va_list (up to a terminating NULL
* argument).
*
* If the string result is empty, the object result is moved to the
* string result, then the object result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendResultVA (interp, argList)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return value. */
va_list argList; /* Variable argument list. */
{
#define STATIC_LIST_SIZE 16
Interp *iPtr = (Interp *) interp;
char *string, *static_list[STATIC_LIST_SIZE];
char **args = static_list;
int nargs_space = STATIC_LIST_SIZE;
int nargs, newSpace, i;
/*
* If the string result is empty, move the object result to the
* string result, then reset the object result.
*/
if (*(iPtr->result) == 0) {
Tcl_SetResult((Tcl_Interp *) iPtr,
TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)),
TCL_VOLATILE);
}
/*
* Scan through all the arguments to see how much space is needed
* and save pointers to the arguments in the args array,
* reallocating as necessary.
*/
nargs = 0;
newSpace = 0;
while (1) {
string = va_arg(argList, char *);
if (string == NULL) {
break;
}
if (nargs >= nargs_space) {
/*
* Expand the args buffer
*/
nargs_space += STATIC_LIST_SIZE;
if (args == static_list) {
args = (void *)ckalloc(nargs_space * sizeof(char *));
for (i = 0; i < nargs; ++i) {
args[i] = static_list[i];
}
} else {
args = (void *)ckrealloc((void *)args,
nargs_space * sizeof(char *));
}
}
newSpace += strlen(string);
args[nargs++] = string;
}
/*
* If the append buffer isn't already setup and large enough to hold
* the new data, set it up.
*/
if ((iPtr->result != iPtr->appendResult)
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|| ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
SetupAppendBuffer(iPtr, newSpace);
}
/*
* Now go through all the argument strings again, copying them into the
* buffer.
*/
for (i = 0; i < nargs; ++i) {
string = args[i];
strcpy(iPtr->appendResult + iPtr->appendUsed, string);
iPtr->appendUsed += strlen(string);
}
/*
* If we had to allocate a buffer from the heap,
* free it now.
*/
if (args != static_list) {
ckfree((void *)args);
}
#undef STATIC_LIST_SIZE
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendResult --
*
* Append a variable number of strings onto the interpreter's string
* result.
*
* Results:
* None.
*
* Side effects:
* The result of the interpreter given by the first argument is
* extended by the strings given by the second and following arguments
* (up to a terminating NULL argument).
*
* If the string result is empty, the object result is moved to the
* string result, then the object result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
Tcl_Interp *interp;
va_list argList;
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
Tcl_AppendResultVA(interp, argList);
va_end(argList);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendElement --
*
* Convert a string to a valid Tcl list element and append it to the
* result (which is ostensibly a list).
*
* Results:
* None.
*
* Side effects:
* The result in the interpreter given by the first argument is
* extended with a list element converted from string. A separator
* space is added before the converted list element unless the current
* result is empty, contains the single character "{", or ends in " {".
*
* If the string result is empty, the object result is moved to the
* string result, then the object result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendElement(interp, string)
Tcl_Interp *interp; /* Interpreter whose result is to be
* extended. */
CONST char *string; /* String to convert to list element and
* add to result. */
{
Interp *iPtr = (Interp *) interp;
char *dst;
int size;
int flags;
/*
* If the string result is empty, move the object result to the
* string result, then reset the object result.
*/
if (*(iPtr->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
/*
* See how much space is needed, and grow the append buffer if
* needed to accommodate the list element.
*/
size = Tcl_ScanElement(string, &flags) + 1;
if ((iPtr->result != iPtr->appendResult)
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|| ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
}
/*
* Convert the string into a list element and copy it to the
* buffer that's forming, with a space separator if needed.
*/
dst = iPtr->appendResult + iPtr->appendUsed;
if (TclNeedSpace(iPtr->appendResult, dst)) {
iPtr->appendUsed++;
*dst = ' ';
dst++;
}
iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
}
/*
*----------------------------------------------------------------------
*
* SetupAppendBuffer --
*
* This procedure makes sure that there is an append buffer properly
* initialized, if necessary, from the interpreter's result, and
* that it has at least enough room to accommodate newSpace new
* bytes of information.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
SetupAppendBuffer(iPtr, newSpace)
Interp *iPtr; /* Interpreter whose result is being set up. */
int newSpace; /* Make sure that at least this many bytes
* of new information may be added. */
{
int totalSpace;
/*
* Make the append buffer larger, if that's necessary, then copy the
* result into the append buffer and make the append buffer the official
* Tcl result.
*/
if (iPtr->result != iPtr->appendResult) {
/*
* If an oversized buffer was used recently, then free it up
* so we go back to a smaller buffer. This avoids tying up
* memory forever after a large operation.
*/
if (iPtr->appendAvl > 500) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
}
iPtr->appendUsed = strlen(iPtr->result);
} else if (iPtr->result[iPtr->appendUsed] != 0) {
/*
* Most likely someone has modified a result created by
* Tcl_AppendResult et al. so that it has a different size.
* Just recompute the size.
*/
iPtr->appendUsed = strlen(iPtr->result);
}
totalSpace = newSpace + iPtr->appendUsed;
if (totalSpace >= iPtr->appendAvl) {
char *new;
if (totalSpace < 100) {
totalSpace = 200;
} else {
totalSpace *= 2;
}
new = (char *) ckalloc((unsigned) totalSpace);
strcpy(new, iPtr->result);
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
}
iPtr->appendResult = new;
iPtr->appendAvl = totalSpace;
} else if (iPtr->result != iPtr->appendResult) {
strcpy(iPtr->appendResult, iPtr->result);
}
Tcl_FreeResult((Tcl_Interp *) iPtr);
iPtr->result = iPtr->appendResult;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FreeResult --
*
* This procedure frees up the memory associated with an interpreter's
* string result. It also resets the interpreter's result object.
* Tcl_FreeResult is most commonly used when a procedure is about to
* replace one result value with another.
*
* Results:
* None.
*
* Side effects:
* Frees the memory associated with interp's string result and sets
* interp->freeProc to zero, but does not change interp->result or
* clear error state. Resets interp's result object to an unshared
* empty object.
*
*----------------------------------------------------------------------
*/
void
Tcl_FreeResult(interp)
register Tcl_Interp *interp; /* Interpreter for which to free result. */
{
register Interp *iPtr = (Interp *) interp;
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
ResetObjResult(iPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ResetResult --
*
* This procedure resets both the interpreter's string and object
* results.
*
* Results:
* None.
*
* Side effects:
* It resets the result object to an unshared empty object. It
* then restores the interpreter's string result area to its default
* initialized state, freeing up any memory that may have been
* allocated. It also clears any error information for the interpreter.
*
*----------------------------------------------------------------------
*/
void
Tcl_ResetResult(interp)
register Tcl_Interp *interp; /* Interpreter for which to clear result. */
{
register Interp *iPtr = (Interp *) interp;
ResetObjResult(iPtr);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
}
/*
*----------------------------------------------------------------------
*
* ResetObjResult --
*
* Procedure used to reset an interpreter's Tcl result object.
*
* Results:
* None.
*
* Side effects:
* Resets the interpreter's result object to an unshared empty string
* object with ref count one. It does not clear any error information
* in the interpreter.
*
*----------------------------------------------------------------------
*/
static void
ResetObjResult(iPtr)
register Interp *iPtr; /* Points to the interpreter whose result
* object should be reset. */
{
register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
if (Tcl_IsShared(objResultPtr)) {
TclDecrRefCount(objResultPtr);
TclNewObj(objResultPtr);
Tcl_IncrRefCount(objResultPtr);
iPtr->objResultPtr = objResultPtr;
} else {
if ((objResultPtr->bytes != NULL)
&& (objResultPtr->bytes != tclEmptyStringRep)) {
ckfree((char *) objResultPtr->bytes);
}
objResultPtr->bytes = tclEmptyStringRep;
objResultPtr->length = 0;
if ((objResultPtr->typePtr != NULL)
&& (objResultPtr->typePtr->freeIntRepProc != NULL)) {
objResultPtr->typePtr->freeIntRepProc(objResultPtr);
}
objResultPtr->typePtr = (Tcl_ObjType *) NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetErrorCodeVA --
*
* This procedure is called to record machine-readable information
* about an error that is about to be returned.
*
* Results:
* None.
*
* Side effects:
* The errorCode global variable is modified to hold all of the
* arguments to this procedure, in a list form with each argument
* becoming one element of the list. A flag is set internally
* to remember that errorCode has been set, so the variable doesn't
* get set automatically when the error is returned.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetErrorCodeVA (interp, argList)
Tcl_Interp *interp; /* Interpreter in which to access the errorCode
* variable. */
va_list argList; /* Variable argument list. */
{
char *string;
int flags;
Interp *iPtr = (Interp *) interp;
/*
* Scan through the arguments one at a time, appending them to
* $errorCode as list elements.
*/
flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
while (1) {
string = va_arg(argList, char *);
if (string == NULL) {
break;
}
(void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
(char *) NULL, string, flags);
flags |= TCL_APPEND_VALUE;
}
iPtr->flags |= ERROR_CODE_SET;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetErrorCode --
*
* This procedure is called to record machine-readable information
* about an error that is about to be returned.
*
* Results:
* None.
*
* Side effects:
* The errorCode global variable is modified to hold all of the
* arguments to this procedure, in a list form with each argument
* becoming one element of the list. A flag is set internally
* to remember that errorCode has been set, so the variable doesn't
* get set automatically when the error is returned.
*
*----------------------------------------------------------------------
*/
/* VARARGS2 */
void
Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
Tcl_Interp *interp;
va_list argList;
/*
* Scan through the arguments one at a time, appending them to
* $errorCode as list elements.
*/
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
Tcl_SetErrorCodeVA(interp, argList);
va_end(argList);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjErrorCode --
*
* This procedure is called to record machine-readable information
* about an error that is about to be returned. The caller should
* build a list object up and pass it to this routine.
*
* Results:
* None.
*
* Side effects:
* The errorCode global variable is modified to be the new value.
* A flag is set internally to remember that errorCode has been
* set, so the variable doesn't get set automatically when the
* error is returned.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetObjErrorCode(interp, errorObjPtr)
Tcl_Interp *interp;
Tcl_Obj *errorObjPtr;
{
Interp *iPtr;
iPtr = (Interp *) interp;
Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY);
iPtr->flags |= ERROR_CODE_SET;
}
/*
*-------------------------------------------------------------------------
*
* TclTransferResult --
*
* Copy the result (and error information) from one interp to
* another. Used when one interp has caused another interp to
* evaluate a script and then wants to transfer the results back
* to itself.
*
* This routine copies the string reps of the result and error
* information. It does not simply increment the refcounts of the
* result and error information objects themselves.
* It is not legal to exchange objects between interps, because an
* object may be kept alive by one interp, but have an internal rep
* that is only valid while some other interp is alive.
*
* Results:
* The target interp's result is set to a copy of the source interp's
* result. The source's error information "$errorInfo" may be
* appended to the target's error information and the source's error
* code "$errorCode" may be stored in the target's error code.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
void
TclTransferResult(sourceInterp, result, targetInterp)
Tcl_Interp *sourceInterp; /* Interp whose result and error information
* should be moved to the target interp.
* After moving result, this interp's result
* is reset. */
int result; /* TCL_OK if just the result should be copied,
* TCL_ERROR if both the result and error
* information should be copied. */
Tcl_Interp *targetInterp; /* Interp where result and error information
* should be stored. If source and target
* are the same, nothing is done. */
{
Interp *iPtr;
Tcl_Obj *objPtr;
if (sourceInterp == targetInterp) {
return;
}
if (result == TCL_ERROR) {
/*
* An error occurred, so transfer error information from the source
* interpreter to the target interpreter. Setting the flags tells
* the target interp that it has inherited a partial traceback
* chain, not just a simple error message.
*/
iPtr = (Interp *) sourceInterp;
if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) {
Tcl_AddErrorInfo(sourceInterp, "");
}
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_ResetResult(targetInterp);
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
if (objPtr) {
Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
TCL_GLOBAL_ONLY);
((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS;
}
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
if (objPtr) {
Tcl_SetObjErrorCode(targetInterp, objPtr);
}
}
((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode;
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
Tcl_ResetResult(sourceInterp);
}
tcl8.4.20/generic/tclVar.c 0000644 0036047 0045461 00000503104 12144442333 013723 0 ustar dgp 771div /*
* tclVar.c --
*
* This file contains routines that implement Tcl variables
* (both scalars and arrays).
*
* The implementation of arrays is modelled after an initial
* implementation by Mark Diekhans and Karl Lehenbauer.
*
* Copyright (c) 1987-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* The strings below are used to indicate what went wrong when a
* variable access is denied.
*/
static CONST char *noSuchVar = "no such variable";
static CONST char *isArray = "variable is array";
static CONST char *needArray = "variable isn't array";
static CONST char *noSuchElement = "no such element in array";
static CONST char *danglingElement =
"upvar refers to element in deleted array";
static CONST char *danglingVar =
"upvar refers to variable in deleted namespace";
static CONST char *badNamespace = "parent namespace doesn't exist";
static CONST char *missingName = "missing variable name";
static CONST char *isArrayElement = "name refers to an element in an array";
/*
* Forward references to procedures defined later in this file:
*/
static int CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
Var *varPtr, CONST char *part1, CONST char *part2,
int flags, CONST int leaveErrMsg));
static void CleanupVar _ANSI_ARGS_((Var *varPtr,
Var *arrayPtr));
static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
static void DeleteArray _ANSI_ARGS_((Interp *iPtr,
CONST char *arrayName, Var *varPtr, int flags));
static void DisposeTraceResult _ANSI_ARGS_((int flags,
char *result));
static int ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp,
CallFrame *framePtr, Tcl_Obj *otherP1Ptr,
CONST char *otherP2, CONST int otherFlags,
CONST char *myName, int myFlags, int index));
static Var * NewVar _ANSI_ARGS_((void));
static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
CONST Var *varPtr, CONST char *varName,
Tcl_Obj *handleObj));
static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *part1, CONST char *part2,
CONST char *operation, CONST char *reason));
static int SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void UnsetVarStruct _ANSI_ARGS_((Var *varPtr, Var *arrayPtr,
Interp *iPtr, CONST char *part1, CONST char *part2,
int flags));
/*
* Functions defined in this file that may be exported in the future
* for use by the bytecode compiler and engine or to the public interface.
*/
Var * TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *varName, int flags, CONST int create,
CONST char **errMsgPtr, int *indexPtr));
int TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *part1Ptr, CONST char *part2, int flags));
static Tcl_FreeInternalRepProc FreeLocalVarName;
static Tcl_DupInternalRepProc DupLocalVarName;
static Tcl_UpdateStringProc UpdateLocalVarName;
static Tcl_FreeInternalRepProc FreeNsVarName;
static Tcl_DupInternalRepProc DupNsVarName;
static Tcl_FreeInternalRepProc FreeParsedVarName;
static Tcl_DupInternalRepProc DupParsedVarName;
static Tcl_UpdateStringProc UpdateParsedVarName;
/*
* Types of Tcl_Objs used to cache variable lookups.
*
*
* localVarName - INTERNALREP DEFINITION:
* twoPtrValue.ptr1 = pointer to the corresponding Proc
* twoPtrValue.ptr2 = index into locals table
*
* nsVarName - INTERNALREP DEFINITION:
* twoPtrValue.ptr1: pointer to the namespace containing the
* reference
* twoPtrValue.ptr2: pointer to the corresponding Var
*
* parsedVarName - INTERNALREP DEFINITION:
* twoPtrValue.ptr1 = pointer to the array name Tcl_Obj,
* or NULL if it is a scalar variable
* twoPtrValue.ptr2 = pointer to the element name string
* (owned by this Tcl_Obj), or NULL if
* it is a scalar variable
*/
static Tcl_ObjType tclLocalVarNameType = {
"localVarName",
FreeLocalVarName, DupLocalVarName, UpdateLocalVarName, NULL
};
static Tcl_ObjType tclNsVarNameType = {
"namespaceVarName",
FreeNsVarName, DupNsVarName, NULL, NULL
};
static Tcl_ObjType tclParsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, NULL
};
/*
* Type of Tcl_Objs used to speed up array searches.
*
* INTERNALREP DEFINITION:
* twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL
* twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL
*
* Note that the value stored in ptr2 is the offset into the string of
* the start of the variable name and not the address of the variable
* name itself, as this can be safely copied.
*/
Tcl_ObjType tclArraySearchType = {
"array search",
NULL, NULL, NULL, SetArraySearchObj
};
/*
*----------------------------------------------------------------------
*
* TclLookupVar --
*
* This procedure is used to locate a variable given its name(s). It
* has been mostly superseded by TclObjLookupVar, it is now only used
* by the string-based interfaces. It is kept in tcl8.4 mainly because
* it is in the internal stubs table, so that some extension may be
* calling it.
*
* Results:
* The return value is a pointer to the variable structure indicated by
* part1 and part2, or NULL if the variable couldn't be found. If the
* variable is found, *arrayPtrPtr is filled in with the address of the
* variable structure for the array that contains the variable (or NULL
* if the variable is a scalar). If the variable can't be found and
* either createPart1 or createPart2 are 1, a new as-yet-undefined
* (VAR_UNDEFINED) variable structure is created, entered into a hash
* table, and returned.
*
* If the variable isn't found and creation wasn't specified, or some
* other error occurs, NULL is returned and an error message is left in
* the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
*
* Note: it's possible for the variable returned to be VAR_UNDEFINED
* even if createPart1 or createPart2 are 1 (these only cause the hash
* table entry or array to be created). For example, the variable might
* be a global that has been unset but is still referenced by a
* procedure, or a variable that has been unset but it only being kept
* in existence (if VAR_UNDEFINED) by a trace.
*
* Side effects:
* New hashtable entries may be created if createPart1 or createPart2
* are 1.
*
*----------------------------------------------------------------------
*/
Var *
TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
arrayPtrPtr)
Tcl_Interp *interp; /* Interpreter to use for lookup. */
CONST char *part1; /* If part2 isn't NULL, this is the name of
* an array. Otherwise, this
* is a full variable name that could
* include a parenthesized array element. */
CONST char *part2; /* Name of element within array, or NULL. */
int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* and TCL_LEAVE_ERR_MSG bits matter. */
CONST char *msg; /* Verb to use in error messages, e.g.
* "read" or "set". Only needed if
* TCL_LEAVE_ERR_MSG is set in flags. */
int createPart1; /* If 1, create hash table entry for part 1
* of name, if it doesn't already exist. If
* 0, return error if it doesn't exist. */
int createPart2; /* If 1, create hash table entry for part 2
* of name, if it doesn't already exist. If
* 0, return error if it doesn't exist. */
Var **arrayPtrPtr; /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise
* this is set to NULL. */
{
Var *varPtr;
CONST char *elName; /* Name of array element or NULL; may be
* same as part2, or may be openParen+1. */
int openParen, closeParen;
/* If this procedure parses a name into
* array and index, these are the offsets to
* the parens around the index. Otherwise
* they are -1. */
register CONST char *p;
CONST char *errMsg = NULL;
int index;
#define VAR_NAME_BUF_SIZE 26
char buffer[VAR_NAME_BUF_SIZE];
char *newVarName = buffer;
varPtr = NULL;
*arrayPtrPtr = NULL;
openParen = closeParen = -1;
/*
* Parse part1 into array name and index.
* Always check if part1 is an array element name and allow it only if
* part2 is not given.
* (if one does not care about creating array elements that can't be used
* from tcl, and prefer slightly better performance, one can put
* the following in an if (part2 == NULL) { ... } block and remove
* the part2's test and error reporting or move that code in array set)
*/
elName = part2;
for (p = part1; *p ; p++) {
if (*p == '(') {
openParen = p - part1;
do {
p++;
} while (*p != '\0');
p--;
if (*p == ')') {
if (part2 != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, msg, needArray);
}
return NULL;
}
closeParen = p - part1;
} else {
openParen = -1;
}
break;
}
}
if (openParen != -1) {
if (closeParen >= VAR_NAME_BUF_SIZE) {
newVarName = ckalloc((unsigned int) (closeParen+1));
}
memcpy(newVarName, part1, (unsigned int) closeParen);
newVarName[openParen] = '\0';
newVarName[closeParen] = '\0';
part1 = newVarName;
elName = newVarName + openParen + 1;
}
varPtr = TclLookupSimpleVar(interp, part1, flags,
createPart1, &errMsg, &index);
if (varPtr == NULL) {
if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
VarErrMsg(interp, part1, elName, msg, errMsg);
}
} else {
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (elName != NULL) {
*arrayPtrPtr = varPtr;
varPtr = TclLookupArrayElement(interp, part1, elName, flags,
msg, createPart1, createPart2, varPtr);
}
}
if (newVarName != buffer) {
ckfree(newVarName);
}
return varPtr;
#undef VAR_NAME_BUF_SIZE
}
/*
*----------------------------------------------------------------------
*
* TclObjLookupVar --
*
* This procedure is used by virtually all of the variable code to
* locate a variable given its name(s). The parsing into array/element
* components and (if possible) the lookup results are cached in
* part1Ptr, which is converted to one of the varNameTypes.
*
* Results:
* The return value is a pointer to the variable structure indicated by
* part1Ptr and part2, or NULL if the variable couldn't be found. If
* the variable is found, *arrayPtrPtr is filled with the address of the
* variable structure for the array that contains the variable (or NULL
* if the variable is a scalar). If the variable can't be found and
* either createPart1 or createPart2 are 1, a new as-yet-undefined
* (VAR_UNDEFINED) variable structure is created, entered into a hash
* table, and returned.
*
* If the variable isn't found and creation wasn't specified, or some
* other error occurs, NULL is returned and an error message is left in
* the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
*
* Note: it's possible for the variable returned to be VAR_UNDEFINED
* even if createPart1 or createPart2 are 1 (these only cause the hash
* table entry or array to be created). For example, the variable might
* be a global that has been unset but is still referenced by a
* procedure, or a variable that has been unset but it only being kept
* in existence (if VAR_UNDEFINED) by a trace.
*
* Side effects:
* New hashtable entries may be created if createPart1 or createPart2
* are 1.
* The object part1Ptr is converted to one of tclLocalVarNameType,
* tclNsVarNameType or tclParsedVarNameType and caches as much of the
* lookup as it can.
*
*----------------------------------------------------------------------
*/
Var *
TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2,
arrayPtrPtr)
Tcl_Interp *interp; /* Interpreter to use for lookup. */
register Tcl_Obj *part1Ptr; /* If part2 isn't NULL, this is the name
* of an array. Otherwise, this is a full
* variable name that could include a parenthesized
* array element. */
CONST char *part2; /* Name of element within array, or NULL. */
int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* and TCL_LEAVE_ERR_MSG bits matter. */
CONST char *msg; /* Verb to use in error messages, e.g.
* "read" or "set". Only needed if
* TCL_LEAVE_ERR_MSG is set in flags. */
CONST int createPart1; /* If 1, create hash table entry for part 1
* of name, if it doesn't already exist. If
* 0, return error if it doesn't exist. */
CONST int createPart2; /* If 1, create hash table entry for part 2
* of name, if it doesn't already exist. If
* 0, return error if it doesn't exist. */
Var **arrayPtrPtr; /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise
* this is set to NULL. */
{
Interp *iPtr = (Interp *) interp;
register Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
char *part1;
int index, len1, len2;
int parsed = 0;
Tcl_Obj *objPtr;
Tcl_ObjType *typePtr = part1Ptr->typePtr;
CONST char *errMsg = NULL;
CallFrame *varFramePtr = iPtr->varFramePtr;
Namespace *nsPtr;
/*
* If part1Ptr is a tclParsedVarNameType, separate it into the
* pre-parsed parts.
*/
*arrayPtrPtr = NULL;
if (typePtr == &tclParsedVarNameType) {
if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
if (part2 != NULL) {
/*
* ERROR: part1Ptr is already an array element, cannot
* specify a part2.
*/
if (flags & TCL_LEAVE_ERR_MSG) {
part1 = TclGetString(part1Ptr);
VarErrMsg(interp, part1, part2, msg, needArray);
}
return NULL;
}
part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2;
part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1;
typePtr = part1Ptr->typePtr;
}
parsed = 1;
}
part1 = Tcl_GetStringFromObj(part1Ptr, &len1);
nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr);
if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
goto doParse;
}
if (typePtr == &tclLocalVarNameType) {
Proc *procPtr = (Proc *) part1Ptr->internalRep.twoPtrValue.ptr1;
int localIndex = (int) part1Ptr->internalRep.twoPtrValue.ptr2;
int useLocal;
useLocal = ((varFramePtr != NULL) && varFramePtr->isProcCallFrame
&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)));
if (useLocal && (procPtr == varFramePtr->procPtr)) {
/*
* part1Ptr points to an indexed local variable of the
* correct procedure: use the cached value.
*/
varPtr = &(varFramePtr->compiledLocals[localIndex]);
goto donePart1;
}
goto doneParsing;
} else if (typePtr == &tclNsVarNameType) {
Namespace *cachedNsPtr;
int useGlobal, useReference;
varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2;
cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1;
useGlobal = (cachedNsPtr == iPtr->globalNsPtr)
&& ((flags & TCL_GLOBAL_ONLY)
|| ((*part1 == ':') && (*(part1+1) == ':'))
|| (varFramePtr == NULL)
|| (!varFramePtr->isProcCallFrame
&& (nsPtr == iPtr->globalNsPtr)));
useReference = useGlobal || ((cachedNsPtr == nsPtr)
&& ((flags & TCL_NAMESPACE_ONLY)
|| (varFramePtr && !varFramePtr->isProcCallFrame
&& !(flags & TCL_GLOBAL_ONLY)
/* careful: an undefined ns variable could
* be hiding a valid global reference. */
&& !(varPtr->flags & VAR_UNDEFINED))));
if (useReference && (varPtr->hPtr != NULL)) {
/*
* A straight global or namespace reference, use it. It isn't
* so simple to deal with 'implicit' namespace references, i.e.,
* those where the reference could be to either a namespace
* or a global variable. Those we lookup again.
*
* If (varPtr->hPtr == NULL), this might be a reference to a
* variable in a deleted namespace, kept alive by e.g. part1Ptr.
* We could conceivably be so unlucky that a new namespace was
* created at the same address as the deleted one, so to be
* safe we test for a valid hPtr.
*/
goto donePart1;
}
goto doneParsing;
}
doParse:
if (!parsed && (*(part1 + len1 - 1) == ')')) {
/*
* part1Ptr is possibly an unparsed array element.
*/
register int i;
char *newPart2;
len2 = -1;
for (i = 0; i < len1; i++) {
if (*(part1 + i) == '(') {
if (part2 != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, msg, needArray);
}
}
/*
* part1Ptr points to an array element; first copy
* the element name to a new string part2.
*/
part2 = part1 + i + 1;
len2 = len1 - i - 2;
len1 = i;
newPart2 = ckalloc((unsigned int) (len2+1));
memcpy(newPart2, part2, (unsigned int) len2);
*(newPart2+len2) = '\0';
part2 = newPart2;
/*
* Free the internal rep of the original part1Ptr, now
* renamed objPtr, and set it to tclParsedVarNameType.
*/
objPtr = part1Ptr;
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
typePtr->freeIntRepProc(objPtr);
}
objPtr->typePtr = &tclParsedVarNameType;
/*
* Define a new string object to hold the new part1Ptr, i.e.,
* the array name. Set the internal rep of objPtr, reset
* typePtr and part1 to contain the references to the
* array name.
*/
part1Ptr = Tcl_NewStringObj(part1, len1);
Tcl_IncrRefCount(part1Ptr);
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr;
objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2;
typePtr = part1Ptr->typePtr;
part1 = TclGetString(part1Ptr);
break;
}
}
}
doneParsing:
/*
* part1Ptr is not an array element; look it up, and convert
* it to one of the cached types if possible.
*/
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
typePtr->freeIntRepProc(part1Ptr);
part1Ptr->typePtr = NULL;
}
varPtr = TclLookupSimpleVar(interp, part1, flags,
createPart1, &errMsg, &index);
if (varPtr == NULL) {
if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
VarErrMsg(interp, part1, part2, msg, errMsg);
}
return NULL;
}
/*
* Cache the newly found variable if possible.
*/
if (index >= 0) {
/*
* An indexed local variable.
*/
Proc *procPtr = ((Interp *) interp)->varFramePtr->procPtr;
part1Ptr->typePtr = &tclLocalVarNameType;
procPtr->refCount++;
part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
#if 0
/*
* TEMPORARYLY DISABLED tclNsVarNameType
*
* This optimisation will hopefully be turned back on soon.
* Miguel Sofer, 2004-05-22
*/
} else if (index > -3) {
/*
* A cacheable namespace or global variable.
*/
Namespace *nsPtr;
nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr);
varPtr->refCount++;
part1Ptr->typePtr = &tclNsVarNameType;
part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
#endif
} else {
/*
* At least mark part1Ptr as already parsed.
*/
part1Ptr->typePtr = &tclParsedVarNameType;
part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
}
donePart1:
#if 0
if (varPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
part1 = TclGetString(part1Ptr);
VarErrMsg(interp, part1, part2, msg,
"Cached variable reference is NULL.");
}
return NULL;
}
#endif
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (part2 != NULL) {
/*
* Array element sought: look it up.
*/
part1 = TclGetString(part1Ptr);
*arrayPtrPtr = varPtr;
varPtr = TclLookupArrayElement(interp, part1, part2,
flags, msg, createPart1, createPart2, varPtr);
}
return varPtr;
}
/*
* This flag bit should not interfere with TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* or TCL_LEAVE_ERR_MSG; it signals that the variable lookup is performed for
* upvar (or similar) purposes, with slightly different rules:
* - Bug #696893 - variable is either proc-local or in the current
* namespace; never follow the second (global) resolution path
* - Bug #631741 - do not use special namespace or interp resolvers
*/
#define LOOKUP_FOR_UPVAR 0x40000
/*
*----------------------------------------------------------------------
*
* TclLookupSimpleVar --
*
* This procedure is used by to locate a simple variable (i.e., not
* an array element) given its name.
*
* Results:
* The return value is a pointer to the variable structure indicated by
* varName, or NULL if the variable couldn't be found. If the variable
* can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED)
* variable structure is created, entered into a hash table, and returned.
*
* If the current CallFrame corresponds to a proc and the variable found is
* one of the compiledLocals, its index is placed in *indexPtr. Otherwise,
* *indexPtr will be set to (according to the needs of TclObjLookupVar):
* -1 a global reference
* -2 a reference to a namespace variable
* -3 a non-cachable reference, i.e., one of:
* . non-indexed local var
* . a reference of unknown origin;
* . resolution by a namespace or interp resolver
*
* If the variable isn't found and creation wasn't specified, or some
* other error occurs, NULL is returned and the corresponding error
* message is left in *errMsgPtr.
*
* Note: it's possible for the variable returned to be VAR_UNDEFINED
* even if create is 1 (this only causes the hash table entry to be
* created). For example, the variable might be a global that has been
* unset but is still referenced by a procedure, or a variable that has
* been unset but it only being kept in existence (if VAR_UNDEFINED) by
* a trace.
*
* Side effects:
* A new hashtable entry may be created if create is 1.
*
*----------------------------------------------------------------------
*/
Var *
TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
Tcl_Interp *interp; /* Interpreter to use for lookup. */
CONST char *varName; /* This is a simple variable name that could
* representa scalar or an array. */
int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits
* matter. */
CONST int create; /* If 1, create hash table entry for varname,
* if it doesn't already exist. If 0, return
* error if it doesn't exist. */
CONST char **errMsgPtr;
int *indexPtr;
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
/* Points to the procedure call frame whose
* variables are currently in use. Same as
* the current procedure's frame, if any,
* unless an "uplevel" is executing. */
Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which
* to look up the variable. */
Tcl_Var var; /* Used to search for global names. */
Var *varPtr; /* Points to the Var structure returned for
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
ResolverScheme *resPtr;
Tcl_HashEntry *hPtr;
int new, i, result;
varPtr = NULL;
varNsPtr = NULL; /* set non-NULL if a nonlocal variable */
*indexPtr = -3;
if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) {
cxtNsPtr = iPtr->globalNsPtr;
} else {
cxtNsPtr = iPtr->varFramePtr->nsPtr;
}
/*
* If this namespace has a variable resolver, then give it first
* crack at the variable resolution. It may return a Tcl_Var
* value, it may signal to continue onward, or it may signal
* an error.
*/
if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL)
&& !(flags & LOOKUP_FOR_UPVAR)) {
resPtr = iPtr->resolverPtr;
if (cxtNsPtr->varResProc) {
result = (*cxtNsPtr->varResProc)(interp, varName,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
} else {
result = TCL_CONTINUE;
}
while (result == TCL_CONTINUE && resPtr) {
if (resPtr->varResProc) {
result = (*resPtr->varResProc)(interp, varName,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
}
resPtr = resPtr->nextPtr;
}
if (result == TCL_OK) {
varPtr = (Var *) var;
return varPtr;
} else if (result != TCL_CONTINUE) {
return NULL;
}
}
/*
* Look up varName. Look it up as either a namespace variable or as a
* local variable in a procedure call frame (varFramePtr).
* Interpret varName as a namespace variable if:
* 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag,
* 2) there is no active frame (we're at the global :: scope),
* 3) the active frame was pushed to define the namespace context
* for a "namespace eval" or "namespace inscope" command,
* 4) the name has namespace qualifiers ("::"s).
* Otherwise, if varName is a local variable, search first in the
* frame's array of compiler-allocated local variables, then in its
* hashtable for runtime-created local variables.
*
* If create and the variable isn't found, create the variable and,
* if necessary, create varFramePtr's local var hashtable.
*/
if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
|| (varFramePtr == NULL)
|| !varFramePtr->isProcCallFrame
|| (strstr(varName, "::") != NULL)) {
CONST char *tail;
int lookGlobal;
lookGlobal = (flags & TCL_GLOBAL_ONLY)
|| (cxtNsPtr == iPtr->globalNsPtr)
|| ((*varName == ':') && (*(varName+1) == ':'));
if (lookGlobal) {
*indexPtr = -1;
flags = (flags | TCL_GLOBAL_ONLY) & ~(TCL_NAMESPACE_ONLY|LOOKUP_FOR_UPVAR);
} else {
if (flags & LOOKUP_FOR_UPVAR) {
flags = (flags | TCL_NAMESPACE_ONLY) & ~LOOKUP_FOR_UPVAR;
}
if (flags & TCL_NAMESPACE_ONLY) {
*indexPtr = -2;
}
}
/*
* Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable,
* or otherwise generate our own error!
*/
var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr,
flags & ~TCL_LEAVE_ERR_MSG);
if (var != (Tcl_Var) NULL) {
varPtr = (Var *) var;
}
if (varPtr == NULL) {
if (create) { /* var wasn't found so create it */
TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
if (varNsPtr == NULL) {
*errMsgPtr = badNamespace;
return NULL;
}
if (tail == NULL) {
*errMsgPtr = missingName;
return NULL;
}
hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
varPtr = NewVar();
Tcl_SetHashValue(hPtr, varPtr);
varPtr->hPtr = hPtr;
varPtr->nsPtr = varNsPtr;
if ((lookGlobal) || (varNsPtr == NULL)) {
/*
* The variable was created starting from the global
* namespace: a global reference is returned even if
* it wasn't explicitly requested.
*/
*indexPtr = -1;
} else {
*indexPtr = -2;
}
} else { /* var wasn't found and not to create it */
*errMsgPtr = noSuchVar;
return NULL;
}
}
} else { /* local var: look in frame varFramePtr */
Proc *procPtr = varFramePtr->procPtr;
int localCt = procPtr->numCompiledLocals;
CompiledLocal *localPtr = procPtr->firstLocalPtr;
Var *localVarPtr = varFramePtr->compiledLocals;
int varNameLen = strlen(varName);
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
register char *localName = localVarPtr->name;
if ((varName[0] == localName[0])
&& (varNameLen == localPtr->nameLength)
&& (strcmp(varName, localName) == 0)) {
*indexPtr = i;
return localVarPtr;
}
}
localVarPtr++;
localPtr = localPtr->nextPtr;
}
tablePtr = varFramePtr->varTablePtr;
if (create) {
if (tablePtr == NULL) {
tablePtr = (Tcl_HashTable *)
ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
varFramePtr->varTablePtr = tablePtr;
}
hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new);
if (new) {
varPtr = NewVar();
Tcl_SetHashValue(hPtr, varPtr);
varPtr->hPtr = hPtr;
varPtr->nsPtr = NULL; /* a local variable */
} else {
varPtr = (Var *) Tcl_GetHashValue(hPtr);
}
} else {
hPtr = NULL;
if (tablePtr != NULL) {
hPtr = Tcl_FindHashEntry(tablePtr, varName);
}
if (hPtr == NULL) {
*errMsgPtr = noSuchVar;
return NULL;
}
varPtr = (Var *) Tcl_GetHashValue(hPtr);
}
}
return varPtr;
}
/*
*----------------------------------------------------------------------
*
* TclLookupArrayElement --
*
* This procedure is used to locate a variable which is in an array's
* hashtable given a pointer to the array's Var structure and the
* element's name.
*
* Results:
* The return value is a pointer to the variable structure , or NULL if
* the variable couldn't be found.
*
* If arrayPtr points to a variable that isn't an array and createPart1
* is 1, the corresponding variable will be converted to an array.
* Otherwise, NULL is returned and an error message is left in
* the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
*
* If the variable is not found and createPart2 is 1, the variable is
* created. Otherwise, NULL is returned and an error message is left in
* the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
*
* Note: it's possible for the variable returned to be VAR_UNDEFINED
* even if createPart1 or createPart2 are 1 (these only cause the hash
* table entry or array to be created). For example, the variable might
* be a global that has been unset but is still referenced by a
* procedure, or a variable that has been unset but it only being kept
* in existence (if VAR_UNDEFINED) by a trace.
*
* Side effects:
* The variable at arrayPtr may be converted to be an array if
* createPart1 is 1. A new hashtable entry may be created if createPart2
* is 1.
*
*----------------------------------------------------------------------
*/
Var *
TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr)
Tcl_Interp *interp; /* Interpreter to use for lookup. */
CONST char *arrayName; /* This is the name of the array. */
CONST char *elName; /* Name of element within array. */
CONST int flags; /* Only TCL_LEAVE_ERR_MSG bit matters. */
CONST char *msg; /* Verb to use in error messages, e.g.
* "read" or "set". Only needed if
* TCL_LEAVE_ERR_MSG is set in flags. */
CONST int createArray; /* If 1, transform arrayName to be an array
* if it isn't one yet and the transformation
* is possible. If 0, return error if it
* isn't already an array. */
CONST int createElem; /* If 1, create hash table entry for the
* element, if it doesn't already exist. If
* 0, return error if it doesn't exist. */
Var *arrayPtr; /* Pointer to the array's Var structure. */
{
Tcl_HashEntry *hPtr;
int new;
Var *varPtr;
/*
* We're dealing with an array element. Make sure the variable is an
* array and look up the element (create the element if desired).
*/
if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
if (!createArray) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elName, msg, noSuchVar);
}
return NULL;
}
/*
* Make sure we are not resurrecting a namespace variable from a
* deleted namespace!
*/
if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elName, msg, danglingVar);
}
return NULL;
}
TclSetVarArray(arrayPtr);
TclClearVarUndefined(arrayPtr);
arrayPtr->value.tablePtr =
(Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
} else if (!TclIsVarArray(arrayPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elName, msg, needArray);
}
return NULL;
}
if (createElem) {
hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new);
if (new) {
if (arrayPtr->searchPtr != NULL) {
DeleteSearches(arrayPtr);
}
varPtr = NewVar();
Tcl_SetHashValue(hPtr, varPtr);
varPtr->hPtr = hPtr;
varPtr->nsPtr = arrayPtr->nsPtr;
TclSetVarArrayElement(varPtr);
}
} else {
hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elName);
if (hPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elName, msg, noSuchElement);
}
return NULL;
}
}
return (Var *) Tcl_GetHashValue(hPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetVar --
*
* Return the value of a Tcl variable as a string.
*
* Results:
* The return value points to the current value of varName as a string.
* If the variable is not defined or can't be read because of a clash
* in array usage then a NULL pointer is returned and an error message
* is left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set.
* Note: the return value is only valid up until the next change to the
* variable; if you depend on the value lasting longer than that, then
* make yourself a private copy.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#undef Tcl_GetVar
CONST char *
Tcl_GetVar(interp, varName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
CONST char *varName; /* Name of a variable in interp. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
* bits. */
{
return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetVar2 --
*
* Return the value of a Tcl variable as a string, given a two-part
* name consisting of array name and element within array.
*
* Results:
* The return value points to the current value of the variable given
* by part1 and part2 as a string. If the specified variable doesn't
* exist, or if there is a clash in array usage, then NULL is returned
* and a message will be left in the interp's result if the
* TCL_LEAVE_ERR_MSG flag is set. Note: the return value is only valid
* up until the next change to the variable; if you depend on the value
* lasting longer than that, then make yourself a private copy.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_GetVar2(interp, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
CONST char *part1; /* Name of an array (if part2 is non-NULL)
* or the name of a variable. */
CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG
* bits. */
{
Tcl_Obj *objPtr;
objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags);
if (objPtr == NULL) {
return NULL;
}
return TclGetString(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetVar2Ex --
*
* Return the value of a Tcl variable as a Tcl object, given a
* two-part name consisting of array name and element within array.
*
* Results:
* The return value points to the current object value of the variable
* given by part1Ptr and part2Ptr. If the specified variable doesn't
* exist, or if there is a clash in array usage, then NULL is returned
* and a message will be left in the interpreter's result if the
* TCL_LEAVE_ERR_MSG flag is set.
*
* Side effects:
* The ref count for the returned object is _not_ incremented to
* reflect the returned reference; if you want to keep a reference to
* the object you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetVar2Ex(interp, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
CONST char *part1; /* Name of an array (if part2 is non-NULL)
* or the name of a variable. */
CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* and TCL_LEAVE_ERR_MSG bits. */
{
Var *varPtr, *arrayPtr;
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
varPtr = TclLookupVar(interp, part1, part2, flags, "read",
/*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ObjGetVar2 --
*
* Return the value of a Tcl variable as a Tcl object, given a
* two-part name consisting of array name and element within array.
*
* Results:
* The return value points to the current object value of the variable
* given by part1Ptr and part2Ptr. If the specified variable doesn't
* exist, or if there is a clash in array usage, then NULL is returned
* and a message will be left in the interpreter's result if the
* TCL_LEAVE_ERR_MSG flag is set.
*
* Side effects:
* The ref count for the returned object is _not_ incremented to
* reflect the returned reference; if you want to keep a reference to
* the object you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
register Tcl_Obj *part1Ptr; /* Points to an object holding the name of
* an array (if part2 is non-NULL) or the
* name of a variable. */
register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and
* TCL_LEAVE_ERR_MSG bits. */
{
Var *varPtr, *arrayPtr;
char *part1, *part2;
part1 = Tcl_GetString(part1Ptr);
part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
/*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}
/*
*----------------------------------------------------------------------
*
* TclPtrGetVar --
*
* Return the value of a Tcl variable as a Tcl object, given the
* pointers to the variable's (and possibly containing array's)
* VAR structure.
*
* Results:
* The return value points to the current object value of the variable
* given by varPtr. If the specified variable doesn't exist, or if there
* is a clash in array usage, then NULL is returned and a message will be
* left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set.
*
* Side effects:
* The ref count for the returned object is _not_ incremented to
* reflect the returned reference; if you want to keep a reference to
* the object you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
register Var *varPtr; /* The variable to be read.*/
Var *arrayPtr; /* NULL for scalar variables, pointer to
* the containing array otherwise. */
CONST char *part1; /* Name of an array (if part2 is non-NULL)
* or the name of a variable. */
CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* and TCL_LEAVE_ERR_MSG bits. */
{
Interp *iPtr = (Interp *) interp;
CONST char *msg;
/*
* Invoke any traces that have been set for the variable.
*/
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
(flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY))
| TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
goto errorReturn;
}
}
/*
* Return the element if it's an existing scalar variable.
*/
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
return varPtr->value.objPtr;
}
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL)
&& !TclIsVarUndefined(arrayPtr)) {
msg = noSuchElement;
} else if (TclIsVarArray(varPtr)) {
msg = isArray;
} else {
msg = noSuchVar;
}
VarErrMsg(interp, part1, part2, "read", msg);
}
/*
* An error. If the variable doesn't exist anymore and no-one's using
* it, then free up the relevant structures and hash table entries.
*/
errorReturn:
if (TclIsVarUndefined(varPtr)) {
CleanupVar(varPtr, arrayPtr);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjCmd --
*
* This procedure is invoked to process the "set" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result value.
*
* Side effects:
* A variable's value may be changed.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SetObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *varValueObj;
if (objc == 2) {
varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (varValueObj == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varValueObj);
return TCL_OK;
} else if (objc == 3) {
varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2],
TCL_LEAVE_ERR_MSG);
if (varValueObj == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varValueObj);
return TCL_OK;
} else {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?");
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetVar --
*
* Change the value of a variable.
*
* Results:
* Returns a pointer to the malloc'ed string which is the character
* representation of the variable's new value. The caller must not
* modify this string. If the write operation was disallowed then NULL
* is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an
* explanatory message will be left in the interp's result. Note that the
* returned string may not be the same as newValue; this is because
* variable traces may modify the variable's value.
*
* Side effects:
* If varName is defined as a local or global variable in interp,
* its value is changed to newValue. If varName isn't currently
* defined, then a new global variable by that name is created.
*
*----------------------------------------------------------------------
*/
#undef Tcl_SetVar
CONST char *
Tcl_SetVar(interp, varName, newValue, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
CONST char *varName; /* Name of a variable in interp. */
CONST char *newValue; /* New value for varName. */
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetVar2 --
*
* Given a two-part variable name, which may refer either to a
* scalar variable or an element of an array, change the value
* of the variable. If the named scalar or array or element
* doesn't exist then create one.
*
* Results:
* Returns a pointer to the malloc'ed string which is the character
* representation of the variable's new value. The caller must not
* modify this string. If the write operation was disallowed because an
* array was expected but not found (or vice versa), then NULL is
* returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory
* message will be left in the interp's result. Note that the returned
* string may not be the same as newValue; this is because variable
* traces may modify the variable's value.
*
* Side effects:
* The value of the given variable is set. If either the array
* or the entry didn't exist then a new one is created.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_SetVar2(interp, part1, part2, newValue, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
CONST char *part1; /* If part2 is NULL, this is name of scalar
* variable. Otherwise it is the name of
* an array. */
CONST char *part2; /* Name of an element within an array, or
* NULL. */
CONST char *newValue; /* New value for variable. */
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG */
{
register Tcl_Obj *valuePtr;
Tcl_Obj *varValuePtr;
/*
* Create an object holding the variable's new value and use
* Tcl_SetVar2Ex to actually set the variable.
*/
valuePtr = Tcl_NewStringObj(newValue, -1);
Tcl_IncrRefCount(valuePtr);
varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags);
Tcl_DecrRefCount(valuePtr); /* done with the object */
if (varValuePtr == NULL) {
return NULL;
}
return TclGetString(varValuePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetVar2Ex --
*
* Given a two-part variable name, which may refer either to a scalar
* variable or an element of an array, change the value of the variable
* to a new Tcl object value. If the named scalar or array or element
* doesn't exist then create one.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
* variable. If the write operation was disallowed because an array was
* expected but not found (or vice versa), then NULL is returned; if
* the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
* be left in the interpreter's result. Note that the returned object
* may not be the same one referenced by newValuePtr; this is because
* variable traces may modify the variable's value.
*
* Side effects:
* The value of the given variable is set. If either the array or the
* entry didn't exist then a new variable is created.
*
* The reference count is decremented for any old value of the variable
* and incremented for its new value. If the new value for the variable
* is not the same one referenced by newValuePtr (perhaps as a result
* of a variable trace), then newValuePtr's ref count is left unchanged
* by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if
* we are appending it as a string value: that is, if "flags" includes
* TCL_APPEND_VALUE but not TCL_LIST_ELEMENT.
*
* The reference count for the returned object is _not_ incremented: if
* you want to keep a reference to the object you must increment its
* ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
CONST char *part1; /* Name of an array (if part2 is non-NULL)
* or the name of a variable. */
CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
Tcl_Obj *newValuePtr; /* New value for variable. */
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
Var *varPtr, *arrayPtr;
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
varPtr = TclLookupVar(interp, part1, part2, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
newValuePtr, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ObjSetVar2 --
*
* This function is the same as Tcl_SetVar2Ex above, except the
* variable names are passed in Tcl object instead of strings.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
* variable. If the write operation was disallowed because an array was
* expected but not found (or vice versa), then NULL is returned; if
* the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
* be left in the interpreter's result. Note that the returned object
* may not be the same one referenced by newValuePtr; this is because
* variable traces may modify the variable's value.
*
* Side effects:
* The value of the given variable is set. If either the array or the
* entry didn't exist then a new variable is created.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
register Tcl_Obj *part1Ptr; /* Points to an object holding the name of
* an array (if part2 is non-NULL) or the
* name of a variable. */
register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *newValuePtr; /* New value for variable. */
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */
{
Var *varPtr, *arrayPtr;
char *part1, *part2;
part1 = TclGetString(part1Ptr);
part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
newValuePtr, flags);
}
/*
*----------------------------------------------------------------------
*
* TclPtrSetVar --
*
* This function is the same as Tcl_SetVar2Ex above, except that
* it requires pointers to the variable's Var structs in addition
* to the variable names.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
* variable. If the write operation was disallowed because an array was
* expected but not found (or vice versa), then NULL is returned; if
* the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
* be left in the interpreter's result. Note that the returned object
* may not be the same one referenced by newValuePtr; this is because
* variable traces may modify the variable's value.
*
* Side effects:
* The value of the given variable is set. If either the array or the
* entry didn't exist then a new variable is created.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
register Var *varPtr;
Var *arrayPtr;
CONST char *part1; /* Name of an array (if part2 is non-NULL)
* or the name of a variable. */
CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
Tcl_Obj *newValuePtr; /* New value for variable. */
CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* and TCL_LEAVE_ERR_MSG bits. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *oldValuePtr;
Tcl_Obj *resultPtr = NULL;
int result;
/*
* If the variable is in a hashtable and its hPtr field is NULL, then we
* may have an upvar to an array element where the array was deleted
* or an upvar to a namespace variable whose namespace was deleted.
* Generate an error (allowing the variable to be reset would screw up
* our storage allocation and is meaningless anyway).
*/
if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarArrayElement(varPtr)) {
VarErrMsg(interp, part1, part2, "set", danglingElement);
} else {
VarErrMsg(interp, part1, part2, "set", danglingVar);
}
}
return NULL;
}
/*
* It's an error to try to set an array variable itself.
*/
if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, "set", isArray);
}
return NULL;
}
/*
* Invoke any read traces that have been set for the variable if it
* requested. This was done for INST_LAPPEND_* but that was inconsistent
* with the non-bc instruction, and would cause failures trying to
* lappend to any non-existing ::env var, which is inconsistent with
* documented behavior. [Bug #3057639].
*/
if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
return NULL;
}
}
/*
* Set the variable's new value. If appending, append the new value to
* the variable, either as a list element or as a string. Also, if
* appending, then if the variable's old value is unshared we can modify
* it directly, otherwise we must create a new copy to modify: this is
* "copy on write".
*/
if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) {
TclSetVarUndefined(varPtr);
}
oldValuePtr = varPtr->value.objPtr;
if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
Tcl_DecrRefCount(oldValuePtr); /* discard old value */
varPtr->value.objPtr = NULL;
oldValuePtr = NULL;
}
if (flags & TCL_LIST_ELEMENT) { /* append list element */
if (oldValuePtr == NULL) {
TclNewObj(oldValuePtr);
varPtr->value.objPtr = oldValuePtr;
Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
} else if (Tcl_IsShared(oldValuePtr)) {
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
Tcl_DecrRefCount(oldValuePtr);
oldValuePtr = varPtr->value.objPtr;
Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
}
result = Tcl_ListObjAppendElement(interp, oldValuePtr,
newValuePtr);
if (result != TCL_OK) {
return NULL;
}
} else { /* append string */
/*
* We append newValuePtr's bytes but don't change its ref count.
*/
if (oldValuePtr == NULL) {
varPtr->value.objPtr = newValuePtr;
Tcl_IncrRefCount(newValuePtr);
} else {
if (Tcl_IsShared(oldValuePtr)) { /* append to copy */
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
#ifdef TCL_TIP280
/*
* TIP #280.
* Ensure that the continuation line data for the
* string is not lost and applies to the extended
* script as well.
*/
TclContinuationsCopy (varPtr->value.objPtr, oldValuePtr);
#endif
TclDecrRefCount(oldValuePtr);
oldValuePtr = varPtr->value.objPtr;
Tcl_IncrRefCount(oldValuePtr); /* since var is ref */
}
Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
}
}
} else if (newValuePtr != oldValuePtr) {
/*
* In this case we are replacing the value, so we don't need to
* do more than swap the objects.
*/
varPtr->value.objPtr = newValuePtr;
Tcl_IncrRefCount(newValuePtr); /* var is another ref */
if (oldValuePtr != NULL) {
TclDecrRefCount(oldValuePtr); /* discard old value */
}
}
TclSetVarScalar(varPtr);
TclClearVarUndefined(varPtr);
if (arrayPtr != NULL) {
TclClearVarUndefined(arrayPtr);
}
/*
* Invoke any write traces for the variable.
*/
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
| TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) {
goto cleanup;
}
}
/*
* Return the variable's value unless the variable was changed in some
* gross way by a trace (e.g. it was unset and then recreated as an
* array).
*/
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
return varPtr->value.objPtr;
}
/*
* A trace changed the value in some gross way. Return an empty string
* object.
*/
resultPtr = iPtr->emptyObjPtr;
/*
* If the variable doesn't exist anymore and no-one's using it, then
* free up the relevant structures and hash table entries.
*/
cleanup:
if (TclIsVarUndefined(varPtr)) {
CleanupVar(varPtr, arrayPtr);
}
return resultPtr;
}
/*
*----------------------------------------------------------------------
*
* TclIncrVar2 --
*
* Given a two-part variable name, which may refer either to a scalar
* variable or an element of an array, increment the Tcl object value
* of the variable by a specified amount.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
* variable. If the specified variable doesn't exist, or there is a
* clash in array usage, or an error occurs while executing variable
* traces, then NULL is returned and a message will be left in
* the interpreter's result.
*
* Side effects:
* The value of the given variable is incremented by the specified
* amount. If either the array or the entry didn't exist then a new
* variable is created. The ref count for the returned object is _not_
* incremented to reflect the returned reference; if you want to keep a
* reference to the object you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
Tcl_Obj *part1Ptr; /* Points to an object holding the name of
* an array (if part2 is non-NULL) or the
* name of a variable. */
Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
long incrAmount; /* Amount to be added to variable. */
int flags; /* Various flags that tell how to incr value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
Var *varPtr, *arrayPtr;
char *part1, *part2;
part1 = TclGetString(part1Ptr);
part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
0, 1, &arrayPtr);
if (varPtr == NULL) {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
return NULL;
}
return TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2,
incrAmount, flags);
}
/*
*----------------------------------------------------------------------
*
* TclPtrIncrVar --
*
* Given the pointers to a variable and possible containing array,
* increment the Tcl object value of the variable by a specified
* amount.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
* variable. If the specified variable doesn't exist, or there is a
* clash in array usage, or an error occurs while executing variable
* traces, then NULL is returned and a message will be left in
* the interpreter's result.
*
* Side effects:
* The value of the given variable is incremented by the specified
* amount. If either the array or the entry didn't exist then a new
* variable is created. The ref count for the returned object is _not_
* incremented to reflect the returned reference; if you want to keep a
* reference to the object you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
Var *varPtr;
Var *arrayPtr;
CONST char *part1; /* Points to an object holding the name of
* an array (if part2 is non-NULL) or the
* name of a variable. */
CONST char *part2; /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
CONST long incrAmount; /* Amount to be added to variable. */
CONST int flags; /* Various flags that tell how to incr value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
register Tcl_Obj *varValuePtr;
int createdNewObj; /* Set 1 if var's value object is shared
* so we must increment a copy (i.e. copy
* on write). */
long i;
varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
if (varValuePtr == NULL) {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
return NULL;
}
/*
* Increment the variable's value. If the object is unshared we can
* modify it directly, otherwise we must create a new copy to modify:
* this is "copy on write". Then free the variable's old string
* representation, if any, since it will no longer be valid.
*/
createdNewObj = 0;
if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
createdNewObj = 1;
}
if (varValuePtr->typePtr == &tclWideIntType) {
Tcl_WideInt wide;
TclGetWide(wide,varValuePtr);
Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
} else if (varValuePtr->typePtr == &tclIntType) {
i = varValuePtr->internalRep.longValue;
Tcl_SetIntObj(varValuePtr, i + incrAmount);
} else {
/*
* Not an integer or wide internal-rep...
*/
Tcl_WideInt wide;
if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) {
if (createdNewObj) {
Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
}
return NULL;
}
if (wide <= Tcl_LongAsWide(LONG_MAX)
&& wide >= Tcl_LongAsWide(LONG_MIN)) {
Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount);
} else {
Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
}
}
/*
* Store the variable's new value and run any write traces.
*/
return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
varValuePtr, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnsetVar --
*
* Delete a variable, so that it may not be accessed anymore.
*
* Results:
* Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
* if the variable can't be unset. In the event of an error,
* if the TCL_LEAVE_ERR_MSG flag is set then an error message
* is left in the interp's result.
*
* Side effects:
* If varName is defined as a local or global variable in interp,
* it is deleted.
*
*----------------------------------------------------------------------
*/
#undef Tcl_UnsetVar
int
Tcl_UnsetVar(interp, varName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
CONST char *varName; /* Name of a variable in interp. May be
* either a scalar name or an array name
* or an element in an array. */
int flags; /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or
* TCL_LEAVE_ERR_MSG. */
{
return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnsetVar2 --
*
* Delete a variable, given a 2-part name.
*
* Results:
* Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
* if the variable can't be unset. In the event of an error,
* if the TCL_LEAVE_ERR_MSG flag is set then an error message
* is left in the interp's result.
*
* Side effects:
* If part1 and part2 indicate a local or global variable in interp,
* it is deleted. If part1 is an array name and part2 is NULL, then
* the whole array is deleted.
*
*----------------------------------------------------------------------
*/
int
Tcl_UnsetVar2(interp, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
CONST char *part1; /* Name of variable or array. */
CONST char *part2; /* Name of element within array or NULL. */
int flags; /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
{
int result;
Tcl_Obj *part1Ptr;
part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
result = TclObjUnsetVar2(interp, part1Ptr, part2, flags);
TclDecrRefCount(part1Ptr);
return result;
}
/*
*----------------------------------------------------------------------
*
* TclObjUnsetVar2 --
*
* Delete a variable, given a 2-object name.
*
* Results:
* Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
* if the variable can't be unset. In the event of an error,
* if the TCL_LEAVE_ERR_MSG flag is set then an error message
* is left in the interp's result.
*
* Side effects:
* If part1ptr and part2Ptr indicate a local or global variable in interp,
* it is deleted. If part1Ptr is an array name and part2Ptr is NULL, then
* the whole array is deleted.
*
*----------------------------------------------------------------------
*/
int
TclObjUnsetVar2(interp, part1Ptr, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
Tcl_Obj *part1Ptr; /* Name of variable or array. */
CONST char *part2; /* Name of element within array or NULL. */
int flags; /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
{
Var *varPtr;
Interp *iPtr = (Interp *) interp;
Var *arrayPtr;
int result;
char *part1;
part1 = TclGetString(part1Ptr);
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset",
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);
/*
* Keep the variable alive until we're done with it. We used to
* increase/decrease the refCount for each operation, making it
* hard to find [Bug 735335] - caused by unsetting the variable
* whose value was the variable's name.
*/
varPtr->refCount++;
UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags);
/*
* It's an error to unset an undefined variable.
*/
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, "unset",
((arrayPtr == NULL) ? noSuchVar : noSuchElement));
}
}
/*
* Try to avoid keeping the Var struct allocated due to a tclNsVarNameType
* keeping a reference. This removes some additional exteriorisations of
* [Bug 736729], but may be a good thing independently of the bug.
*/
if (part1Ptr->typePtr == &tclNsVarNameType) {
part1Ptr->typePtr->freeIntRepProc(part1Ptr);
part1Ptr->typePtr = NULL;
}
/*
* Finally, if the variable is truly not in use then free up its Var
* structure and remove it from its hash table, if any. The ref count of
* its value object, if any, was decremented above.
*/
varPtr->refCount--;
CleanupVar(varPtr, arrayPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* UnsetVarStruct --
*
* Unset and delete a variable. This does the internal work for
* TclObjUnsetVar2 and TclDeleteNamespaceVars, which call here for each
* variable to be unset and deleted.
*
* Results:
* None.
*
* Side effects:
* If the arguments indicate a local or global variable in iPtr, it is
* unset and deleted.
*
*----------------------------------------------------------------------
*/
static void
UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags)
Var *varPtr;
Var *arrayPtr;
Interp *iPtr;
CONST char *part1;
CONST char *part2;
int flags;
{
Var dummyVar;
Var *dummyVarPtr;
ActiveVarTrace *activePtr;
if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
DeleteSearches(arrayPtr);
}
/*
* For global/upvar variables referenced in procedures, decrement
* the reference count on the variable referred to, and free
* the referenced variable if it's no longer needed.
*/
if (TclIsVarLink(varPtr)) {
Var *linkPtr = varPtr->value.linkPtr;
linkPtr->refCount--;
if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
&& (linkPtr->tracePtr == NULL)
&& (linkPtr->flags & VAR_IN_HASHTABLE)) {
if (linkPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(linkPtr->hPtr);
}
ckfree((char *) linkPtr);
}
}
/*
* The code below is tricky, because of the possibility that
* a trace procedure might try to access a variable being
* deleted. To handle this situation gracefully, do things
* in three steps:
* 1. Copy the contents of the variable to a dummy variable
* structure, and mark the original Var structure as undefined.
* 2. Invoke traces and clean up the variable, using the dummy copy.
* 3. If at the end of this the original variable is still
* undefined and has no outstanding references, then delete
* it (but it could have gotten recreated by a trace).
*/
dummyVar = *varPtr;
TclSetVarUndefined(varPtr);
TclSetVarScalar(varPtr);
varPtr->value.objPtr = NULL; /* dummyVar points to any value object */
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
/*
* Call trace procedures for the variable being deleted. Then delete
* its traces. Be sure to abort any other traces for the variable
* that are still pending. Special tricks:
* 1. We need to increment varPtr's refCount around this: CallVarTraces
* will use dummyVar so it won't increment varPtr's refCount itself.
* 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
* call unset traces even if other traces are pending.
*/
if ((dummyVar.tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
dummyVar.flags &= ~VAR_TRACE_ACTIVE;
CallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
| TCL_TRACE_UNSETS, /* leaveErrMsg */ 0);
while (dummyVar.tracePtr != NULL) {
VarTrace *tracePtr = dummyVar.tracePtr;
dummyVar.tracePtr = tracePtr->nextPtr;
Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
}
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == varPtr) {
activePtr->nextTracePtr = NULL;
}
}
}
/*
* If the variable is an array, delete all of its elements. This must be
* done after calling the traces on the array, above (that's the way
* traces are defined). If it is a scalar, "discard" its object
* (decrement the ref count of its object, if any).
*/
dummyVarPtr = &dummyVar;
if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) {
DeleteArray(iPtr, part1, dummyVarPtr, (flags
& (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS);
}
if (TclIsVarScalar(dummyVarPtr)
&& (dummyVarPtr->value.objPtr != NULL)) {
Tcl_Obj *objPtr = dummyVarPtr->value.objPtr;
TclDecrRefCount(objPtr);
dummyVarPtr->value.objPtr = NULL;
}
/*
* If the variable was a namespace variable, decrement its reference count.
*/
if (varPtr->flags & VAR_NAMESPACE_VAR) {
varPtr->flags &= ~VAR_NAMESPACE_VAR;
varPtr->refCount--;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_TraceVar --
*
* Arrange for reads and/or writes to a variable to cause a
* procedure to be invoked, which can monitor the operations
* and/or change their actions.
*
* Results:
* A standard Tcl return value.
*
* Side effects:
* A trace is set up on the variable given by varName, such that
* future references to the variable will be intermediated by
* proc. See the manual entry for complete details on the calling
* sequence for proc.
*
*----------------------------------------------------------------------
*/
#undef Tcl_TraceVar
int
Tcl_TraceVar(interp, varName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which variable is
* to be traced. */
CONST char *varName; /* Name of variable; may end with "(index)"
* to signify an array reference. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
* invoked upon varName. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
return Tcl_TraceVar2(interp, varName, (char *) NULL,
flags, proc, clientData);
}
/*
*----------------------------------------------------------------------
*
* Tcl_TraceVar2 --
*
* Arrange for reads and/or writes to a variable to cause a
* procedure to be invoked, which can monitor the operations
* and/or change their actions.
*
* Results:
* A standard Tcl return value.
*
* Side effects:
* A trace is set up on the variable given by part1 and part2, such
* that future references to the variable will be intermediated by
* proc. See the manual entry for complete details on the calling
* sequence for proc.
*
*----------------------------------------------------------------------
*/
int
Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which variable is
* to be traced. */
CONST char *part1; /* Name of scalar variable or array. */
CONST char *part2; /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
* and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
* invoked upon varName. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
Var *varPtr, *arrayPtr;
register VarTrace *tracePtr;
int flagMask;
/*
* We strip 'flags' down to just the parts which are relevant to
* TclLookupVar, to avoid conflicts between trace flags and
* internal namespace flags such as 'FIND_ONLY_NS'. This can
* now occur since we have trace flags with values 0x1000 and higher.
*/
flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
varPtr = TclLookupVar(interp, part1, part2,
(flags & flagMask) | TCL_LEAVE_ERR_MSG,
"trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
/*
* Check for a nonsense flag combination. Note that this is a
* panic() because there should be no code path that ever sets
* both flags.
*/
if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) {
panic("bad result flag combination");
}
/*
* Set up trace information.
*/
flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags & flagMask;
tracePtr->nextPtr = varPtr->tracePtr;
varPtr->tracePtr = tracePtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UntraceVar --
*
* Remove a previously-created trace for a variable.
*
* Results:
* None.
*
* Side effects:
* If there exists a trace for the variable given by varName
* with the given flags, proc, and clientData, then that trace
* is removed.
*
*----------------------------------------------------------------------
*/
#undef Tcl_UntraceVar
void
Tcl_UntraceVar(interp, varName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *varName; /* Name of variable; may end with "(index)"
* to signify an array reference. */
int flags; /* OR-ed collection of bits describing
* current trace, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY
* and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UntraceVar2 --
*
* Remove a previously-created trace for a variable.
*
* Results:
* None.
*
* Side effects:
* If there exists a trace for the variable given by part1
* and part2 with the given flags, proc, and clientData, then
* that trace is removed.
*
*----------------------------------------------------------------------
*/
void
Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *part1; /* Name of variable or array. */
CONST char *part2; /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed collection of bits describing
* current trace, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
* and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
register VarTrace *tracePtr;
VarTrace *prevPtr;
Var *varPtr, *arrayPtr;
Interp *iPtr = (Interp *) interp;
ActiveVarTrace *activePtr;
int flagMask;
/*
* Set up a mask to mask out the parts of the flags that we are not
* interested in now.
*/
flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
varPtr = TclLookupVar(interp, part1, part2, flags & flagMask,
/*msg*/ (char *) NULL,
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
if (varPtr == NULL) {
return;
}
/*
* Set up a mask to mask out the parts of the flags that we are not
* interested in now.
*/
flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
flags &= flagMask;
for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
return;
}
if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
&& (tracePtr->clientData == clientData)) {
break;
}
}
/*
* The code below makes it possible to delete traces while traces
* are active: it makes sure that the deleted trace won't be
* processed by CallVarTraces.
*/
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
activePtr->nextTracePtr = tracePtr->nextPtr;
}
}
if (prevPtr == NULL) {
varPtr->tracePtr = tracePtr->nextPtr;
} else {
prevPtr->nextPtr = tracePtr->nextPtr;
}
Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
/*
* If this is the last trace on the variable, and the variable is
* unset and unused, then free up the variable.
*/
if (TclIsVarUndefined(varPtr)) {
CleanupVar(varPtr, (Var *) NULL);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_VarTraceInfo --
*
* Return the clientData value associated with a trace on a
* variable. This procedure can also be used to step through
* all of the traces on a particular variable that have the
* same trace procedure.
*
* Results:
* The return value is the clientData value associated with
* a trace on the given variable. Information will only be
* returned for a trace with proc as trace procedure. If
* the clientData argument is NULL then the first such trace is
* returned; otherwise, the next relevant one after the one
* given by clientData will be returned. If the variable
* doesn't exist, or if there are no (more) traces for it,
* then NULL is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#undef Tcl_VarTraceInfo
ClientData
Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *varName; /* Name of variable; may end with "(index)"
* to signify an array reference. */
int flags; /* OR-ed combo or TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY (can be 0). */
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
ClientData prevClientData; /* If non-NULL, gives last value returned
* by this procedure, so this call will
* return the next trace after that one.
* If NULL, this call will return the
* first trace. */
{
return Tcl_VarTraceInfo2(interp, varName, (char *) NULL,
flags, proc, prevClientData);
}
/*
*----------------------------------------------------------------------
*
* Tcl_VarTraceInfo2 --
*
* Same as Tcl_VarTraceInfo, except takes name in two pieces
* instead of one.
*
* Results:
* Same as Tcl_VarTraceInfo.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *part1; /* Name of variable or array. */
CONST char *part2; /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
ClientData prevClientData; /* If non-NULL, gives last value returned
* by this procedure, so this call will
* return the next trace after that one.
* If NULL, this call will return the
* first trace. */
{
register VarTrace *tracePtr;
Var *varPtr, *arrayPtr;
varPtr = TclLookupVar(interp, part1, part2,
flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY),
/*msg*/ (char *) NULL,
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
/*
* Find the relevant trace, if any, and return its clientData.
*/
tracePtr = varPtr->tracePtr;
if (prevClientData != NULL) {
for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if ((tracePtr->clientData == prevClientData)
&& (tracePtr->traceProc == proc)) {
tracePtr = tracePtr->nextPtr;
break;
}
}
}
for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if (tracePtr->traceProc == proc) {
return tracePtr->clientData;
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnsetObjCmd --
*
* This object-based procedure is invoked to process the "unset" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_UnsetObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register int i, flags = TCL_LEAVE_ERR_MSG;
register char *name;
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-nocomplain? ?--? ?varName varName ...?");
return TCL_ERROR;
} else if (objc == 1) {
/*
* Do nothing if no arguments supplied, so as to match
* command documentation.
*/
return TCL_OK;
}
/*
* Simple, restrictive argument parsing. The only options are --
* and -nocomplain (which must come first and be given exactly to
* be an option).
*/
i = 1;
name = TclGetString(objv[i]);
if (name[0] == '-') {
if (strcmp("-nocomplain", name) == 0) {
i++;
if (i == objc) {
return TCL_OK;
}
flags = 0;
name = TclGetString(objv[i]);
}
if (strcmp("--", name) == 0) {
i++;
}
}
for (; i < objc; i++) {
if ((TclObjUnsetVar2(interp, objv[i], NULL, flags) != TCL_OK)
&& (flags == TCL_LEAVE_ERR_MSG)) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendObjCmd --
*
* This object-based procedure is invoked to process the "append"
* Tcl command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* A variable's value may be changed.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_AppendObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Var *varPtr, *arrayPtr;
char *part1;
register Tcl_Obj *varValuePtr = NULL;
/* Initialized to avoid compiler
* warning. */
int i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
return TCL_ERROR;
}
if (objc == 2) {
varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
} else {
varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
part1 = TclGetString(objv[1]);
if (varPtr == NULL) {
return TCL_ERROR;
}
for (i = 2; i < objc; i++) {
/*
* Note that we do not need to increase the refCount of
* the Var pointers: should a trace delete the variable,
* the return value of TclPtrSetVar will be NULL, and we
* will not access the variable again.
*/
varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
if ((varValuePtr == NULL) ||
(varValuePtr == ((Interp *) interp)->emptyObjPtr)) {
return TCL_ERROR;
}
}
}
Tcl_SetObjResult(interp, varValuePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LappendObjCmd --
*
* This object-based procedure is invoked to process the "lappend"
* Tcl command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* A variable's value may be changed.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_LappendObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *varValuePtr, *newValuePtr;
register List *listRepPtr;
register Tcl_Obj **elemPtrs;
int numElems, numRequired, createdNewObj, i, j;
Var *varPtr, *arrayPtr;
char *part1;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
return TCL_ERROR;
}
if (objc == 2) {
newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0);
if (newValuePtr == NULL) {
/*
* The variable doesn't exist yet. Just create it with an empty
* initial value.
*/
varValuePtr = Tcl_NewObj();
Tcl_IncrRefCount(varValuePtr);
newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(varValuePtr);
if (newValuePtr == NULL) {
return TCL_ERROR;
}
} else {
int result;
result = Tcl_ListObjLength(interp, newValuePtr, &numElems);
if (result != TCL_OK) {
return result;
}
}
} else {
/*
* We have arguments to append. We used to call Tcl_SetVar2 to
* append each argument one at a time to ensure that traces were run
* for each append step. We now append the arguments all at once
* because it's faster. Note that a read trace and a write trace for
* the variable will now each only be called once. Also, if the
* variable's old value is unshared we modify it directly, otherwise
* we create a new copy to modify: this is "copy on write".
*
* Note that you have to protect the variable pointers around
* the TclPtrGetVar call to insure that they remain valid
* even if the variable was undefined and unused.
*/
varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
varPtr->refCount++;
if (arrayPtr != NULL) {
arrayPtr->refCount++;
}
part1 = TclGetString(objv[1]);
varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL,
TCL_LEAVE_ERR_MSG);
varPtr->refCount--;
if (arrayPtr != NULL) {
arrayPtr->refCount--;
}
createdNewObj = 0;
if (varValuePtr == NULL) {
/*
* We couldn't read the old value: either the var doesn't yet
* exist or it's an array element. If it's new, we will try to
* create it with Tcl_ObjSetVar2 below.
*/
varValuePtr = Tcl_NewObj();
createdNewObj = 1;
} else if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
createdNewObj = 1;
}
/*
* Convert the variable's old value to a list object if necessary.
*/
if (varValuePtr->typePtr != &tclListType) {
int result = tclListType.setFromAnyProc(interp, varValuePtr);
if (result != TCL_OK) {
if (createdNewObj) {
Tcl_DecrRefCount(varValuePtr); /* free unneeded obj. */
}
return result;
}
}
listRepPtr = (List *) varValuePtr->internalRep.twoPtrValue.ptr1;
elemPtrs = listRepPtr->elements;
numElems = listRepPtr->elemCount;
/*
* If there is no room in the current array of element pointers,
* allocate a new, larger array and copy the pointers to it.
*/
numRequired = numElems + (objc-2);
if (numRequired > listRepPtr->maxElemCount) {
int newMax = (2 * numRequired);
Tcl_Obj **newElemPtrs = (Tcl_Obj **)
ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *)));
memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs,
(size_t) (numElems * sizeof(Tcl_Obj *)));
listRepPtr->maxElemCount = newMax;
listRepPtr->elements = newElemPtrs;
ckfree((char *) elemPtrs);
elemPtrs = newElemPtrs;
}
/*
* Insert the new elements at the end of the list.
*/
for (i = 2, j = numElems; i < objc; i++, j++) {
elemPtrs[j] = objv[i];
Tcl_IncrRefCount(objv[i]);
}
listRepPtr->elemCount = numRequired;
/*
* Invalidate and free any old string representation since it no
* longer reflects the list's internal representation.
*/
Tcl_InvalidateStringRep(varValuePtr);
/*
* Now store the list object back into the variable. If there is an
* error setting the new value, decrement its ref count if it
* was new and we didn't create the variable.
*/
Tcl_IncrRefCount(varValuePtr);
newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
varValuePtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(varValuePtr);
if (newValuePtr == NULL) {
return TCL_ERROR;
}
}
/*
* Set the interpreter's object result to refer to the variable's value
* object.
*/
Tcl_SetObjResult(interp, newValuePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ArrayObjCmd --
*
* This object-based procedure is invoked to process the "array" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result object.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ArrayObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
/*
* The list of constants below should match the arrayOptions string array
* below.
*/
enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET,
ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE,
ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET};
static CONST char *arrayOptions[] = {
"anymore", "donesearch", "exists", "get", "names", "nextelement",
"set", "size", "startsearch", "statistics", "unset", (char *) NULL
};
Interp *iPtr = (Interp *) interp;
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
Tcl_Obj *resultPtr, *varNamePtr;
int notArray;
char *varName;
int index, result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
/*
* Locate the array variable
*/
varNamePtr = objv[2];
varName = TclGetString(varNamePtr);
varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
/*
* Special array trace used to keep the env array in sync for
* array names, array get, etc.
*/
if (varPtr != NULL && varPtr->tracePtr != NULL
&& (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, varName, NULL,
(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) {
return TCL_ERROR;
}
}
/*
* Verify that it is indeed an array variable. This test comes after
* the traces - the variable may actually become an array as an effect
* of said traces.
*/
notArray = 0;
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
notArray = 1;
}
/*
* We have to wait to get the resultPtr until here because
* CallVarTraces can affect the result.
*/
resultPtr = Tcl_GetObjResult(interp);
switch (index) {
case ARRAY_ANYMORE: {
ArraySearch *searchPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv,
"arrayName searchId");
return TCL_ERROR;
}
if (notArray) {
goto error;
}
searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
if (searchPtr == NULL) {
return TCL_ERROR;
}
while (1) {
Var *varPtr2;
if (searchPtr->nextEntry != NULL) {
varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
if (!TclIsVarUndefined(varPtr2)) {
break;
}
}
searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
if (searchPtr->nextEntry == NULL) {
Tcl_SetIntObj(resultPtr, 0);
return TCL_OK;
}
}
Tcl_SetIntObj(resultPtr, 1);
break;
}
case ARRAY_DONESEARCH: {
ArraySearch *searchPtr, *prevPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv,
"arrayName searchId");
return TCL_ERROR;
}
if (notArray) {
goto error;
}
searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
if (searchPtr == NULL) {
return TCL_ERROR;
}
if (varPtr->searchPtr == searchPtr) {
varPtr->searchPtr = searchPtr->nextPtr;
} else {
for (prevPtr = varPtr->searchPtr; ;
prevPtr = prevPtr->nextPtr) {
if (prevPtr->nextPtr == searchPtr) {
prevPtr->nextPtr = searchPtr->nextPtr;
break;
}
}
}
ckfree((char *) searchPtr);
break;
}
case ARRAY_EXISTS: {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
return TCL_ERROR;
}
Tcl_SetIntObj(resultPtr, !notArray);
break;
}
case ARRAY_GET: {
Tcl_HashSearch search;
Var *varPtr2;
char *pattern = NULL;
char *name;
Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr;
int i, count;
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
return TCL_ERROR;
}
if (notArray) {
return TCL_OK;
}
if (objc == 4) {
pattern = TclGetString(objv[3]);
}
/*
* Store the array names in a new object.
*/
nameLstPtr = Tcl_NewObj();
Tcl_IncrRefCount(nameLstPtr);
for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
if (TclIsVarUndefined(varPtr2)) {
continue;
}
name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
continue; /* element name doesn't match pattern */
}
namePtr = Tcl_NewStringObj(name, -1);
result = Tcl_ListObjAppendElement(interp, nameLstPtr,
namePtr);
if (result != TCL_OK) {
Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
Tcl_DecrRefCount(nameLstPtr);
return result;
}
}
/*
* Make sure the Var structure of the array is not removed by
* a trace while we're working.
*/
varPtr->refCount++;
/*
* Get the array values corresponding to each element name
*/
tmpResPtr = Tcl_NewObj();
result = Tcl_ListObjGetElements(interp, nameLstPtr,
&count, &namePtrPtr);
if (result != TCL_OK) {
goto errorInArrayGet;
}
for (i = 0; i < count; i++) {
namePtr = *namePtrPtr++;
valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr,
TCL_LEAVE_ERR_MSG);
if (valuePtr == NULL) {
/*
* Some trace played a trick on us; we need to diagnose to
* adapt our behaviour: was the array element unset, or did
* the modification modify the complete array?
*/
if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
/*
* The array itself looks OK, the variable was
* undefined: forget it.
*/
continue;
} else {
result = TCL_ERROR;
goto errorInArrayGet;
}
}
result = Tcl_ListObjAppendElement(interp, tmpResPtr, namePtr);
if (result != TCL_OK) {
goto errorInArrayGet;
}
result = Tcl_ListObjAppendElement(interp, tmpResPtr, valuePtr);
if (result != TCL_OK) {
goto errorInArrayGet;
}
}
varPtr->refCount--;
Tcl_SetObjResult(interp, tmpResPtr);
Tcl_DecrRefCount(nameLstPtr);
break;
errorInArrayGet:
varPtr->refCount--;
Tcl_DecrRefCount(nameLstPtr);
Tcl_DecrRefCount(tmpResPtr); /* free unneeded temp result obj */
return result;
}
case ARRAY_NAMES: {
Tcl_HashSearch search;
Var *varPtr2;
char *pattern = NULL;
char *name;
Tcl_Obj *namePtr;
int mode, matched = 0;
static CONST char *options[] = {
"-exact", "-glob", "-regexp", (char *) NULL
};
enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
mode = OPT_GLOB;
if ((objc < 3) || (objc > 5)) {
Tcl_WrongNumArgs(interp, 2, objv,
"arrayName ?mode? ?pattern?");
return TCL_ERROR;
}
if (notArray) {
return TCL_OK;
}
if (objc == 4) {
pattern = Tcl_GetString(objv[3]);
} else if (objc == 5) {
pattern = Tcl_GetString(objv[4]);
if (Tcl_GetIndexFromObj(interp, objv[3], options, "option",
0, &mode) != TCL_OK) {
return TCL_ERROR;
}
}
for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
if (TclIsVarUndefined(varPtr2)) {
continue;
}
name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
if (objc > 3) {
switch ((enum options) mode) {
case OPT_EXACT:
matched = (strcmp(name, pattern) == 0);
break;
case OPT_GLOB:
matched = Tcl_StringMatch(name, pattern);
break;
case OPT_REGEXP:
matched = Tcl_RegExpMatch(interp, name,
pattern);
if (matched < 0) {
return TCL_ERROR;
}
break;
}
if (matched == 0) {
continue;
}
}
namePtr = Tcl_NewStringObj(name, -1);
result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
if (result != TCL_OK) {
Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
return result;
}
}
break;
}
case ARRAY_NEXTELEMENT: {
ArraySearch *searchPtr;
Tcl_HashEntry *hPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv,
"arrayName searchId");
return TCL_ERROR;
}
if (notArray) {
goto error;
}
searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
if (searchPtr == NULL) {
return TCL_ERROR;
}
while (1) {
Var *varPtr2;
hPtr = searchPtr->nextEntry;
if (hPtr == NULL) {
hPtr = Tcl_NextHashEntry(&searchPtr->search);
if (hPtr == NULL) {
return TCL_OK;
}
} else {
searchPtr->nextEntry = NULL;
}
varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
if (!TclIsVarUndefined(varPtr2)) {
break;
}
}
Tcl_SetStringObj(resultPtr,
Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1);
break;
}
case ARRAY_SET: {
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
return TCL_ERROR;
}
return(TclArraySet(interp, objv[2], objv[3]));
}
case ARRAY_SIZE: {
Tcl_HashSearch search;
Var *varPtr2;
int size;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
return TCL_ERROR;
}
size = 0;
if (!notArray) {
for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,
&search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
if (TclIsVarUndefined(varPtr2)) {
continue;
}
size++;
}
}
Tcl_SetIntObj(resultPtr, size);
break;
}
case ARRAY_STARTSEARCH: {
ArraySearch *searchPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
return TCL_ERROR;
}
if (notArray) {
goto error;
}
searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
if (varPtr->searchPtr == NULL) {
searchPtr->id = 1;
Tcl_AppendStringsToObj(resultPtr, "s-1-", varName,
(char *) NULL);
} else {
char string[TCL_INTEGER_SPACE];
searchPtr->id = varPtr->searchPtr->id + 1;
TclFormatInt(string, searchPtr->id);
Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName,
(char *) NULL);
}
searchPtr->varPtr = varPtr;
searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
&searchPtr->search);
searchPtr->nextPtr = varPtr->searchPtr;
varPtr->searchPtr = searchPtr;
break;
}
case ARRAY_STATISTICS: {
char *stats;
if (notArray) {
goto error;
}
stats = Tcl_HashStats(varPtr->value.tablePtr);
if (stats != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), stats, -1);
ckfree((void *)stats);
} else {
Tcl_SetResult(interp, "error reading array statistics",
TCL_STATIC);
return TCL_ERROR;
}
break;
}
case ARRAY_UNSET: {
Tcl_HashSearch search;
Var *varPtr2;
char *pattern = NULL;
char *name;
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
return TCL_ERROR;
}
if (notArray) {
return TCL_OK;
}
if (objc == 3) {
/*
* When no pattern is given, just unset the whole array
*/
if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0)
!= TCL_OK) {
return TCL_ERROR;
}
} else {
pattern = Tcl_GetString(objv[3]);
for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,
&search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
if (TclIsVarUndefined(varPtr2)) {
continue;
}
name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
if (Tcl_StringMatch(name, pattern) &&
(TclObjUnsetVar2(interp, varNamePtr, name, 0)
!= TCL_OK)) {
return TCL_ERROR;
}
}
}
break;
}
}
return TCL_OK;
error:
Tcl_AppendStringsToObj(resultPtr, "\"", varName, "\" isn't an array",
(char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclArraySet --
*
* Set the elements of an array. If there are no elements to
* set, create an empty array. This routine is used by the
* Tcl_ArrayObjCmd and by the TclSetupEnv routine.
*
* Results:
* A standard Tcl result object.
*
* Side effects:
* A variable will be created if one does not already exist.
*
*----------------------------------------------------------------------
*/
int
TclArraySet(interp, arrayNameObj, arrayElemObj)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Obj *arrayNameObj; /* The array name. */
Tcl_Obj *arrayElemObj; /* The array elements list. If this is
* NULL, create an empty array. */
{
Var *varPtr, *arrayPtr;
Tcl_Obj **elemPtrs;
int result, elemLen, i, nameLen;
char *varName, *p;
varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen);
p = varName + nameLen - 1;
if (*p == ')') {
while (--p >= varName) {
if (*p == '(') {
VarErrMsg(interp, varName, NULL, "set", needArray);
return TCL_ERROR;
}
}
}
varPtr = TclObjLookupVar(interp, arrayNameObj, NULL,
/*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
/*createPart2*/ 0, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
if (arrayElemObj != NULL) {
result = Tcl_ListObjGetElements(interp, arrayElemObj,
&elemLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (elemLen & 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"list must have an even number of elements", -1);
return TCL_ERROR;
}
if (elemLen > 0) {
/*
* We needn't worry about traces invalidating arrayPtr:
* should that be the case, TclPtrSetVar will return NULL
* so that we break out of the loop and return an error.
*/
for (i = 0; i < elemLen; i += 2) {
char *part2 = TclGetString(elemPtrs[i]);
Var *elemVarPtr = TclLookupArrayElement(interp, varName,
part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);
if ((elemVarPtr == NULL) ||
(TclPtrSetVar(interp, elemVarPtr, varPtr, varName,
part2, elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) {
result = TCL_ERROR;
break;
}
/*
* The TclPtrSetVar call might have shimmered
* arrayElemObj to another type, so re-fetch
* the pointers for safety.
*/
Tcl_ListObjGetElements(NULL, arrayElemObj,
&elemLen, &elemPtrs);
}
return result;
}
}
/*
* The list is empty make sure we have an array, or create
* one if necessary.
*/
if (varPtr != NULL) {
if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) {
/*
* Already an array, done.
*/
return TCL_OK;
}
if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
/*
* Either an array element, or a scalar: lose!
*/
VarErrMsg(interp, varName, (char *)NULL, "array set", needArray);
return TCL_ERROR;
}
}
TclSetVarArray(varPtr);
TclClearVarUndefined(varPtr);
varPtr->value.tablePtr =
(Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ObjMakeUpvar --
*
* This procedure does all of the work of the "global" and "upvar"
* commands.
*
* Results:
* A standard Tcl completion code. If an error occurs then an
* error message is left in iPtr->result.
*
* Side effects:
* The variable given by myName is linked to the variable in framePtr
* given by otherP1 and otherP2, so that references to myName are
* redirected to the other variable like a symbolic link.
*
*----------------------------------------------------------------------
*/
static int
ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags, index)
Tcl_Interp *interp; /* Interpreter containing variables. Used
* for error messages, too. */
CallFrame *framePtr; /* Call frame containing "other" variable.
* NULL means use global :: context. */
Tcl_Obj *otherP1Ptr;
CONST char *otherP2; /* Two-part name of variable in framePtr. */
CONST int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of "other" variable. */
CONST char *myName; /* Name of variable which will refer to
* otherP1/otherP2. Must be a scalar. */
int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of myName. */
int index; /* If the variable to be linked is an indexed
* scalar, this is its index. Otherwise, -1. */
{
Interp *iPtr = (Interp *) interp;
Var *otherPtr, *varPtr, *arrayPtr;
CallFrame *varFramePtr;
CONST char *errMsg;
/*
* Find "other" in "framePtr". If not looking up other in just the
* current namespace, temporarily replace the current var frame
* pointer in the interpreter in order to use TclObjLookupVar.
*/
varFramePtr = iPtr->varFramePtr;
if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
iPtr->varFramePtr = framePtr;
}
otherPtr = TclObjLookupVar(interp, otherP1Ptr, otherP2,
(otherFlags | TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
iPtr->varFramePtr = varFramePtr;
}
if (otherPtr == NULL) {
return TCL_ERROR;
}
if (index >= 0) {
if (!varFramePtr->isProcCallFrame) {
panic("ObjMakeUpvar called with an index outside from a proc.\n");
}
varPtr = &(varFramePtr->compiledLocals[index]);
} else {
/*
* Check that we are not trying to create a namespace var linked to
* a local variable in a procedure. If we allowed this, the local
* variable in the shorter-lived procedure frame could go away
* leaving the namespace var's reference invalid.
*/
if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL)
&& ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
|| (varFramePtr == NULL)
|| !varFramePtr->isProcCallFrame
|| (strstr(myName, "::") != NULL))) {
Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
myName, "\": upvar won't create namespace variable that ",
"refers to procedure variable", (char *) NULL);
return TCL_ERROR;
}
/*
* Lookup and eventually create the new variable. Set the flag bit
* LOOKUP_FOR_UPVAR to indicate the special resolution rules for
* upvar purposes:
* - Bug #696893 - variable is either proc-local or in the current
* namespace; never follow the second (global) resolution path
* - Bug #631741 - do not use special namespace or interp resolvers
*/
varPtr = TclLookupSimpleVar(interp, myName, (myFlags | LOOKUP_FOR_UPVAR),
/* create */ 1, &errMsg, &index);
if (varPtr == NULL) {
VarErrMsg(interp, myName, NULL, "create", errMsg);
return TCL_ERROR;
}
}
if (varPtr == otherPtr) {
Tcl_SetResult((Tcl_Interp *) iPtr,
"can't upvar from variable to itself", TCL_STATIC);
return TCL_ERROR;
}
if (varPtr->tracePtr != NULL) {
Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
"\" has traces: can't use for upvar", (char *) NULL);
return TCL_ERROR;
} else if (!TclIsVarUndefined(varPtr)) {
/*
* The variable already existed. Make sure this variable "varPtr"
* isn't the same as "otherPtr" (avoid circular links). Also, if
* it's not an upvar then it's an error. If it is an upvar, then
* just disconnect it from the thing it currently refers to.
*/
if (TclIsVarLink(varPtr)) {
Var *linkPtr = varPtr->value.linkPtr;
if (linkPtr == otherPtr) {
return TCL_OK;
}
linkPtr->refCount--;
if (TclIsVarUndefined(linkPtr)) {
CleanupVar(linkPtr, (Var *) NULL);
}
} else {
Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
"\" already exists", (char *) NULL);
return TCL_ERROR;
}
}
TclSetVarLink(varPtr);
TclClearVarUndefined(varPtr);
varPtr->value.linkPtr = otherPtr;
otherPtr->refCount++;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpVar --
*
* This procedure links one variable to another, just like
* the "upvar" command.
*
* Results:
* A standard Tcl completion code. If an error occurs then
* an error message is left in the interp's result.
*
* Side effects:
* The variable in frameName whose name is given by varName becomes
* accessible under the name localName, so that references to
* localName are redirected to the other variable like a symbolic
* link.
*
*----------------------------------------------------------------------
*/
#undef Tcl_UpVar
int
Tcl_UpVar(interp, frameName, varName, localName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
CONST char *frameName; /* Name of the frame containing the source
* variable, such as "1" or "#0". */
CONST char *varName; /* Name of a variable in interp to link to.
* May be either a scalar name or an
* element in an array. */
CONST char *localName; /* Name of link variable. */
int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of localName. */
{
return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpVar2 --
*
* This procedure links one variable to another, just like
* the "upvar" command.
*
* Results:
* A standard Tcl completion code. If an error occurs then
* an error message is left in the interp's result.
*
* Side effects:
* The variable in frameName whose name is given by part1 and
* part2 becomes accessible under the name localName, so that
* references to localName are redirected to the other variable
* like a symbolic link.
*
*----------------------------------------------------------------------
*/
int
Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
Tcl_Interp *interp; /* Interpreter containing variables. Used
* for error messages too. */
CONST char *frameName; /* Name of the frame containing the source
* variable, such as "1" or "#0". */
CONST char *part1;
CONST char *part2; /* Two parts of source variable name to
* link to. */
CONST char *localName; /* Name of link variable. */
int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of localName. */
{
int result;
CallFrame *framePtr;
Tcl_Obj *part1Ptr;
if (TclGetFrame(interp, frameName, &framePtr) == -1) {
return TCL_ERROR;
}
part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0,
localName, flags, -1);
TclDecrRefCount(part1Ptr);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetVariableFullName --
*
* Given a Tcl_Var token returned by Tcl_FindNamespaceVar, this
* procedure appends to an object the namespace variable's full
* name, qualified by a sequence of parent namespace names.
*
* Results:
* None.
*
* Side effects:
* The variable's fully-qualified name is appended to the string
* representation of objPtr.
*
*----------------------------------------------------------------------
*/
void
Tcl_GetVariableFullName(interp, variable, objPtr)
Tcl_Interp *interp; /* Interpreter containing the variable. */
Tcl_Var variable; /* Token for the variable returned by a
* previous call to Tcl_FindNamespaceVar. */
Tcl_Obj *objPtr; /* Points to the object onto which the
* variable's full name is appended. */
{
Interp *iPtr = (Interp *) interp;
register Var *varPtr = (Var *) variable;
char *name;
/*
* Add the full name of the containing namespace (if any), followed by
* the "::" separator, then the variable name.
*/
if (varPtr != NULL) {
if (!TclIsVarArrayElement(varPtr)) {
if (varPtr->nsPtr != NULL) {
Tcl_AppendToObj(objPtr, varPtr->nsPtr->fullName, -1);
if (varPtr->nsPtr != iPtr->globalNsPtr) {
Tcl_AppendToObj(objPtr, "::", 2);
}
}
if (varPtr->name != NULL) {
Tcl_AppendToObj(objPtr, varPtr->name, -1);
} else if (varPtr->hPtr != NULL) {
name = Tcl_GetHashKey(varPtr->hPtr->tablePtr, varPtr->hPtr);
Tcl_AppendToObj(objPtr, name, -1);
}
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_GlobalObjCmd --
*
* This object-based procedure is invoked to process the "global" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GlobalObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
register Tcl_Obj *objPtr;
char *varName;
register char *tail;
int result, i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?");
return TCL_ERROR;
}
/*
* If we are not executing inside a Tcl procedure, just return.
*/
if ((iPtr->varFramePtr == NULL)
|| !iPtr->varFramePtr->isProcCallFrame) {
return TCL_OK;
}
for (i = 1; i < objc; i++) {
/*
* Make a local variable linked to its counterpart in the global ::
* namespace.
*/
objPtr = objv[i];
varName = TclGetString(objPtr);
/*
* The variable name might have a scope qualifier, but the name for
* the local "link" variable must be the simple name at the tail.
*/
for (tail = varName; *tail != '\0'; tail++) {
/* empty body */
}
while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
tail--;
}
if ((*tail == ':') && (tail > varName)) {
tail++;
}
/*
* Link to the variable "varName" in the global :: namespace.
*/
result = ObjMakeUpvar(interp, (CallFrame *) NULL,
objPtr, NULL, /*otherFlags*/ TCL_GLOBAL_ONLY,
/*myName*/ tail, /*myFlags*/ 0, -1);
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_VariableObjCmd --
*
* Invoked to implement the "variable" command that creates one or more
* global variables. Handles the following syntax:
*
* variable ?name value...? name ?value?
*
* One or more variables can be created. The variables are initialized
* with the specified values. The value for the last variable is
* optional.
*
* If the variable does not exist, it is created and given the optional
* value. If it already exists, it is simply set to the optional
* value. Normally, "name" is an unqualified name, so it is created in
* the current namespace. If it includes namespace qualifiers, it can
* be created in another namespace.
*
* If the variable command is executed inside a Tcl procedure, it
* creates a local variable linked to the newly-created namespace
* variable.
*
* Results:
* Returns TCL_OK if the variable is found or created. Returns
* TCL_ERROR if anything goes wrong.
*
* Side effects:
* If anything goes wrong, this procedure returns an error message
* as the result in the interpreter's result object.
*
*----------------------------------------------------------------------
*/
int
Tcl_VariableObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
char *varName, *tail, *cp;
Var *varPtr, *arrayPtr;
Tcl_Obj *varValuePtr;
int i, result;
Tcl_Obj *varNamePtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?");
return TCL_ERROR;
}
for (i = 1; i < objc; i = i+2) {
/*
* Look up each variable in the current namespace context, creating
* it if necessary.
*/
varNamePtr = objv[i];
varName = TclGetString(varNamePtr);
varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define",
/*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
if (arrayPtr != NULL) {
/*
* Variable cannot be an element in an array. If arrayPtr is
* non-null, it is, so throw up an error and return.
*/
VarErrMsg(interp, varName, NULL, "define", isArrayElement);
return TCL_ERROR;
}
if (varPtr == NULL) {
return TCL_ERROR;
}
/*
* Mark the variable as a namespace variable and increment its
* reference count so that it will persist until its namespace is
* destroyed or until the variable is unset.
*/
if (!(varPtr->flags & VAR_NAMESPACE_VAR)) {
varPtr->flags |= VAR_NAMESPACE_VAR;
varPtr->refCount++;
}
/*
* If a value was specified, set the variable to that value.
* Otherwise, if the variable is new, leave it undefined.
* (If the variable already exists and no value was specified,
* leave its value unchanged; just create the local link if
* we're in a Tcl procedure).
*/
if (i+1 < objc) { /* a value was specified */
varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL,
objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG));
if (varValuePtr == NULL) {
return TCL_ERROR;
}
}
/*
* If we are executing inside a Tcl procedure, create a local
* variable linked to the new namespace variable "varName".
*/
if ((iPtr->varFramePtr != NULL)
&& iPtr->varFramePtr->isProcCallFrame) {
/*
* varName might have a scope qualifier, but the name for the
* local "link" variable must be the simple name at the tail.
*
* Locate tail in one pass: drop any prefix after two *or more*
* consecutive ":" characters).
*/
for (tail = cp = varName; *cp != '\0'; ) {
if (*cp++ == ':') {
while (*cp == ':') {
tail = ++cp;
}
}
}
/*
* Create a local link "tail" to the variable "varName" in the
* current namespace.
*/
result = ObjMakeUpvar(interp, (CallFrame *) NULL,
/*otherP1*/ varNamePtr, /*otherP2*/ NULL,
/*otherFlags*/ TCL_NAMESPACE_ONLY,
/*myName*/ tail, /*myFlags*/ 0, -1);
if (result != TCL_OK) {
return result;
}
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpvarObjCmd --
*
* This object-based procedure is invoked to process the "upvar"
* Tcl command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_UpvarObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
CallFrame *framePtr;
char *frameSpec, *localName;
int result;
if (objc < 3) {
upvarSyntax:
Tcl_WrongNumArgs(interp, 1, objv,
"?level? otherVar localVar ?otherVar localVar ...?");
return TCL_ERROR;
}
/*
* Find the call frame containing each of the "other variables" to be
* linked to.
*/
frameSpec = TclGetString(objv[1]);
result = TclGetFrame(interp, frameSpec, &framePtr);
if (result == -1) {
return TCL_ERROR;
}
objc -= result+1;
if ((objc & 1) != 0) {
goto upvarSyntax;
}
objv += result+1;
/*
* Iterate over each (other variable, local variable) pair.
* Divide the other variable name into two parts, then call
* MakeUpvar to do all the work of linking it to the local variable.
*/
for ( ; objc > 0; objc -= 2, objv += 2) {
localName = TclGetString(objv[1]);
result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0],
NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1);
if (result != TCL_OK) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DisposeTraceResult--
*
* This procedure is called to dispose of the result returned from
* a trace procedure. The disposal method appropriate to the type
* of result is determined by flags.
*
* Results:
* None.
*
* Side effects:
* The memory allocated for the trace result may be freed.
*
*----------------------------------------------------------------------
*/
static void
DisposeTraceResult(flags, result)
int flags; /* Indicates type of result to determine
* proper disposal method */
char *result; /* The result returned from a trace
* procedure to be disposed */
{
if (flags & TCL_TRACE_RESULT_DYNAMIC) {
ckfree(result);
} else if (flags & TCL_TRACE_RESULT_OBJECT) {
Tcl_DecrRefCount((Tcl_Obj *) result);
}
}
/*
*----------------------------------------------------------------------
*
* CallVarTraces --
*
* This procedure is invoked to find and invoke relevant
* trace procedures associated with a particular operation on
* a variable. This procedure invokes traces both on the
* variable and on its containing array (where relevant).
*
* Results:
* Returns TCL_OK to indicate normal operation. Returns TCL_ERROR
* if invocation of a trace procedure indicated an error. When
* TCL_ERROR is returned and leaveErrMsg is true, then the
* ::errorInfo variable of iPtr has information about the error
* appended to it.
*
* Side effects:
* Almost anything can happen, depending on trace; this procedure
* itself doesn't have any side effects.
*
*----------------------------------------------------------------------
*/
static int
CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
Interp *iPtr; /* Interpreter containing variable. */
register Var *arrayPtr; /* Pointer to array variable that contains
* the variable, or NULL if the variable
* isn't an element of an array. */
Var *varPtr; /* Variable whose traces are to be
* invoked. */
CONST char *part1;
CONST char *part2; /* Variable's two-part name. */
int flags; /* Flags passed to trace procedures:
* indicates what's happening to variable,
* plus other stuff like TCL_GLOBAL_ONLY,
* or TCL_NAMESPACE_ONLY. */
CONST int leaveErrMsg; /* If true, and one of the traces indicates an
* error, then leave an error message and stack
* trace information in *iPTr. */
{
register VarTrace *tracePtr;
ActiveVarTrace active;
char *result;
CONST char *openParen, *p;
Tcl_DString nameCopy;
int copiedName;
int code = TCL_OK;
int disposeFlags = 0;
int saveErrFlags = iPtr->flags
& (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
/*
* If there are already similar trace procedures active for the
* variable, don't call them again.
*/
if (varPtr->flags & VAR_TRACE_ACTIVE) {
return code;
}
varPtr->flags |= VAR_TRACE_ACTIVE;
varPtr->refCount++;
if (arrayPtr != NULL) {
arrayPtr->refCount++;
}
/*
* If the variable name hasn't been parsed into array name and
* element, do it here. If there really is an array element,
* make a copy of the original name so that NULLs can be
* inserted into it to separate the names (can't modify the name
* string in place, because the string might get used by the
* callbacks we invoke).
*/
copiedName = 0;
if (part2 == NULL) {
for (p = part1; *p ; p++) {
if (*p == '(') {
openParen = p;
do {
p++;
} while (*p != '\0');
p--;
if (*p == ')') {
int offset = (openParen - part1);
char *newPart1;
Tcl_DStringInit(&nameCopy);
Tcl_DStringAppend(&nameCopy, part1, (p-part1));
newPart1 = Tcl_DStringValue(&nameCopy);
newPart1[offset] = 0;
part1 = newPart1;
part2 = newPart1 + offset + 1;
copiedName = 1;
}
break;
}
}
}
/*
* Invoke traces on the array containing the variable, if relevant.
*/
result = NULL;
active.nextPtr = iPtr->activeVarTracePtr;
iPtr->activeVarTracePtr = &active;
Tcl_Preserve((ClientData) iPtr);
if (arrayPtr != NULL && !(arrayPtr->flags & VAR_TRACE_ACTIVE)) {
active.varPtr = arrayPtr;
for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
Tcl_Preserve((ClientData) tracePtr);
if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
flags |= TCL_INTERP_DESTROYED;
}
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
if (flags & TCL_TRACE_UNSETS) {
/* Ignore errors in unset traces */
DisposeTraceResult(tracePtr->flags, result);
} else {
disposeFlags = tracePtr->flags;
code = TCL_ERROR;
}
}
Tcl_Release((ClientData) tracePtr);
if (code == TCL_ERROR) {
goto done;
}
}
}
/*
* Invoke traces on the variable itself.
*/
if (flags & TCL_TRACE_UNSETS) {
flags |= TCL_TRACE_DESTROYED;
}
active.varPtr = varPtr;
for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
Tcl_Preserve((ClientData) tracePtr);
if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
flags |= TCL_INTERP_DESTROYED;
}
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
if (flags & TCL_TRACE_UNSETS) {
/* Ignore errors in unset traces */
DisposeTraceResult(tracePtr->flags, result);
} else {
disposeFlags = tracePtr->flags;
code = TCL_ERROR;
}
}
Tcl_Release((ClientData) tracePtr);
if (code == TCL_ERROR) {
goto done;
}
}
/*
* Restore the variable's flags, remove the record of our active
* traces, and then return.
*/
done:
if (code == TCL_OK) {
iPtr->flags |= saveErrFlags;
}
if (code == TCL_ERROR) {
if (leaveErrMsg) {
CONST char *type = "";
switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
case TCL_TRACE_READS: {
type = "read";
break;
}
case TCL_TRACE_WRITES: {
type = "set";
break;
}
case TCL_TRACE_ARRAY: {
type = "trace array";
break;
}
}
if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type,
Tcl_GetString((Tcl_Obj *) result));
} else {
VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result);
}
}
DisposeTraceResult(disposeFlags,result);
}
if (arrayPtr != NULL) {
arrayPtr->refCount--;
}
if (copiedName) {
Tcl_DStringFree(&nameCopy);
}
varPtr->flags &= ~VAR_TRACE_ACTIVE;
varPtr->refCount--;
iPtr->activeVarTracePtr = active.nextPtr;
Tcl_Release((ClientData) iPtr);
return code;
}
/*
*----------------------------------------------------------------------
*
* NewVar --
*
* Create a new heap-allocated variable that will eventually be
* entered into a hashtable.
*
* Results:
* The return value is a pointer to the new variable structure. It is
* marked as a scalar variable (and not a link or array variable). Its
* value initially is NULL. The variable is not part of any hash table
* yet. Since it will be in a hashtable and not in a call frame, its
* name field is set NULL. It is initially marked as undefined.
*
* Side effects:
* Storage gets allocated.
*
*----------------------------------------------------------------------
*/
static Var *
NewVar()
{
register Var *varPtr;
varPtr = (Var *) ckalloc(sizeof(Var));
varPtr->value.objPtr = NULL;
varPtr->name = NULL;
varPtr->nsPtr = NULL;
varPtr->hPtr = NULL;
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE);
return varPtr;
}
/*
*----------------------------------------------------------------------
*
* SetArraySearchObj --
*
* This function converts the given tcl object into one that
* has the "array search" internal type.
*
* Results:
* TCL_OK if the conversion succeeded, and TCL_ERROR if it failed
* (when an error message will be placed in the interpreter's
* result.)
*
* Side effects:
* Updates the internal type and representation of the object to
* make this an array-search object. See the tclArraySearchType
* declaration above for details of the internal representation.
*
*----------------------------------------------------------------------
*/
static int
SetArraySearchObj(interp, objPtr)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
{
char *string;
char *end;
int id;
size_t offset;
/*
* Get the string representation. Make it up-to-date if necessary.
*/
string = Tcl_GetString(objPtr);
/*
* Parse the id into the three parts separated by dashes.
*/
if ((string[0] != 's') || (string[1] != '-')) {
syntax:
Tcl_AppendResult(interp, "illegal search identifier \"", string,
"\"", (char *) NULL);
return TCL_ERROR;
}
id = strtoul(string+2, &end, 10);
if ((end == (string+2)) || (*end != '-')) {
goto syntax;
}
/*
* Can't perform value check in this context, so place reference
* to place in string to use for the check in the object instead.
*/
end++;
offset = end - string;
if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
objPtr->typePtr->freeIntRepProc(objPtr);
}
objPtr->typePtr = &tclArraySearchType;
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL)+id);
objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL)+offset);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ParseSearchId --
*
* This procedure translates from a tcl object to a pointer to an
* active array search (if there is one that matches the string).
*
* Results:
* The return value is a pointer to the array search indicated
* by string, or NULL if there isn't one. If NULL is returned,
* the interp's result contains an error message.
*
* Side effects:
* The tcl object might have its internal type and representation
* modified.
*
*----------------------------------------------------------------------
*/
static ArraySearch *
ParseSearchId(interp, varPtr, varName, handleObj)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST Var *varPtr; /* Array variable search is for. */
CONST char *varName; /* Name of array variable that search is
* supposed to be for. */
Tcl_Obj *handleObj; /* Object containing id of search. Must have
* form "search-num-var" where "num" is a
* decimal number and "var" is a variable
* name. */
{
register char *string;
register size_t offset;
int id;
ArraySearch *searchPtr;
/*
* Parse the id.
*/
if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) {
return NULL;
}
/*
* Cast is safe, since always came from an int in the first place.
*/
id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) -
((char*)NULL));
string = Tcl_GetString(handleObj);
offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) -
((char*)NULL));
/*
* This test cannot be placed inside the Tcl_Obj machinery, since
* it is dependent on the variable context.
*/
if (strcmp(string+offset, varName) != 0) {
Tcl_AppendResult(interp, "search identifier \"", string,
"\" isn't for variable \"", varName, "\"", (char *) NULL);
return NULL;
}
/*
* Search through the list of active searches on the interpreter
* to see if the desired one exists.
*
* Note that we cannot store the searchPtr directly in the Tcl_Obj
* as that would run into trouble when DeleteSearches() was called
* so we must scan this list every time.
*/
for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
searchPtr = searchPtr->nextPtr) {
if (searchPtr->id == id) {
return searchPtr;
}
}
Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
(char *) NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* DeleteSearches --
*
* This procedure is called to free up all of the searches
* associated with an array variable.
*
* Results:
* None.
*
* Side effects:
* Memory is released to the storage allocator.
*
*----------------------------------------------------------------------
*/
static void
DeleteSearches(arrayVarPtr)
register Var *arrayVarPtr; /* Variable whose searches are
* to be deleted. */
{
ArraySearch *searchPtr;
while (arrayVarPtr->searchPtr != NULL) {
searchPtr = arrayVarPtr->searchPtr;
arrayVarPtr->searchPtr = searchPtr->nextPtr;
ckfree((char *) searchPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclDeleteNamespaceVars --
*
* This procedure is called to recycle all the storage space
* associated with a namespace's table of variables.
*
* Results:
* None.
*
* Side effects:
* Variables are deleted and trace procedures are invoked, if
* any are declared.
*
*----------------------------------------------------------------------
*/
void
TclDeleteNamespaceVars(nsPtr)
Namespace *nsPtr;
{
Tcl_HashTable *tablePtr = &nsPtr->varTable;
Tcl_Interp *interp = nsPtr->interp;
Interp *iPtr = (Interp *)interp;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
int flags = 0;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
/*
* Determine what flags to pass to the trace callback procedures.
*/
if (nsPtr == iPtr->globalNsPtr) {
flags = TCL_GLOBAL_ONLY;
} else if (nsPtr == currNsPtr) {
flags = TCL_NAMESPACE_ONLY;
}
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_FirstHashEntry(tablePtr, &search)) {
register Var *varPtr = (Var *) Tcl_GetHashValue(hPtr);
Tcl_Obj *objPtr = Tcl_NewObj();
varPtr->refCount++; /* Make sure we get to remove from hash */
Tcl_IncrRefCount(objPtr);
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
UnsetVarStruct(varPtr, NULL, iPtr, Tcl_GetString(objPtr), NULL, flags);
Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
varPtr->refCount--;
/* Remove the variable from the table and force it undefined
* in case an unset trace brought it back from the dead */
Tcl_DeleteHashEntry(hPtr);
varPtr->hPtr = NULL;
TclSetVarUndefined(varPtr);
TclSetVarScalar(varPtr);
while (varPtr->tracePtr != NULL) {
VarTrace *tracePtr = varPtr->tracePtr;
varPtr->tracePtr = tracePtr->nextPtr;
Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
}
CleanupVar(varPtr, NULL);
}
Tcl_DeleteHashTable(tablePtr);
}
/*
*----------------------------------------------------------------------
*
* TclDeleteVars --
*
* This procedure is called to recycle all the storage space
* associated with a table of variables. For this procedure
* to work correctly, it must not be possible for any of the
* variables in the table to be accessed from Tcl commands
* (e.g. from trace procedures).
*
* Results:
* None.
*
* Side effects:
* Variables are deleted and trace procedures are invoked, if
* any are declared.
*
*----------------------------------------------------------------------
*/
void
TclDeleteVars(iPtr, tablePtr)
Interp *iPtr; /* Interpreter to which variables belong. */
Tcl_HashTable *tablePtr; /* Hash table containing variables to
* delete. */
{
Tcl_Interp *interp = (Tcl_Interp *) iPtr;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
register Var *varPtr;
Var *linkPtr;
int flags;
ActiveVarTrace *activePtr;
Tcl_Obj *objPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
/*
* Determine what flags to pass to the trace callback procedures.
*/
flags = TCL_TRACE_UNSETS;
if (tablePtr == &iPtr->globalNsPtr->varTable) {
flags |= TCL_GLOBAL_ONLY;
} else if (tablePtr == &currNsPtr->varTable) {
flags |= TCL_NAMESPACE_ONLY;
}
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
varPtr = (Var *) Tcl_GetHashValue(hPtr);
/*
* For global/upvar variables referenced in procedures, decrement
* the reference count on the variable referred to, and free
* the referenced variable if it's no longer needed. Don't delete
* the hash entry for the other variable if it's in the same table
* as us: this will happen automatically later on.
*/
if (TclIsVarLink(varPtr)) {
linkPtr = varPtr->value.linkPtr;
linkPtr->refCount--;
if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
&& (linkPtr->tracePtr == NULL)
&& (linkPtr->flags & VAR_IN_HASHTABLE)) {
if (linkPtr->hPtr == NULL) {
ckfree((char *) linkPtr);
} else if (linkPtr->hPtr->tablePtr != tablePtr) {
Tcl_DeleteHashEntry(linkPtr->hPtr);
ckfree((char *) linkPtr);
}
}
}
/*
* Invoke traces on the variable that is being deleted, then
* free up the variable's space (no need to free the hash entry
* here, unless we're dealing with a global variable: the
* hash entries will be deleted automatically when the whole
* table is deleted). Note that we give CallVarTraces the variable's
* fully-qualified name so that any called trace procedures can
* refer to these variables being deleted.
*/
if (varPtr->tracePtr != NULL) {
objPtr = Tcl_NewObj();
Tcl_IncrRefCount(objPtr); /* until done with traces */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
CallVarTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr),
NULL, flags, /* leaveErrMsg */ 0);
Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
while (varPtr->tracePtr != NULL) {
VarTrace *tracePtr = varPtr->tracePtr;
varPtr->tracePtr = tracePtr->nextPtr;
Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
}
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == varPtr) {
activePtr->nextTracePtr = NULL;
}
}
}
if (TclIsVarArray(varPtr)) {
DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr,
flags);
varPtr->value.tablePtr = NULL;
}
if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) {
objPtr = varPtr->value.objPtr;
TclDecrRefCount(objPtr);
varPtr->value.objPtr = NULL;
}
varPtr->hPtr = NULL;
varPtr->tracePtr = NULL;
TclSetVarUndefined(varPtr);
TclSetVarScalar(varPtr);
/*
* If the variable was a namespace variable, decrement its
* reference count. We are in the process of destroying its
* namespace so that namespace will no longer "refer" to the
* variable.
*/
if (varPtr->flags & VAR_NAMESPACE_VAR) {
varPtr->flags &= ~VAR_NAMESPACE_VAR;
varPtr->refCount--;
}
/*
* Recycle the variable's memory space if there aren't any upvar's
* pointing to it. If there are upvars to this variable, then the
* variable will get freed when the last upvar goes away.
*/
if (varPtr->refCount == 0) {
ckfree((char *) varPtr); /* this Var must be VAR_IN_HASHTABLE */
}
}
Tcl_DeleteHashTable(tablePtr);
}
/*
*----------------------------------------------------------------------
*
* TclDeleteCompiledLocalVars --
*
* This procedure is called to recycle storage space associated with
* the compiler-allocated array of local variables in a procedure call
* frame. This procedure resembles TclDeleteVars above except that each
* variable is stored in a call frame and not a hash table. For this
* procedure to work correctly, it must not be possible for any of the
* variable in the table to be accessed from Tcl commands (e.g. from
* trace procedures).
*
* Results:
* None.
*
* Side effects:
* Variables are deleted and trace procedures are invoked, if
* any are declared.
*
*----------------------------------------------------------------------
*/
void
TclDeleteCompiledLocalVars(iPtr, framePtr)
Interp *iPtr; /* Interpreter to which variables belong. */
CallFrame *framePtr; /* Procedure call frame containing
* compiler-assigned local variables to
* delete. */
{
register Var *varPtr;
int flags; /* Flags passed to trace procedures. */
Var *linkPtr;
ActiveVarTrace *activePtr;
int numLocals, i;
flags = TCL_TRACE_UNSETS;
numLocals = framePtr->numCompiledLocals;
varPtr = framePtr->compiledLocals;
for (i = 0; i < numLocals; i++) {
/*
* For global/upvar variables referenced in procedures, decrement
* the reference count on the variable referred to, and free
* the referenced variable if it's no longer needed. Don't delete
* the hash entry for the other variable if it's in the same table
* as us: this will happen automatically later on.
*/
if (TclIsVarLink(varPtr)) {
linkPtr = varPtr->value.linkPtr;
linkPtr->refCount--;
if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
&& (linkPtr->tracePtr == NULL)
&& (linkPtr->flags & VAR_IN_HASHTABLE)) {
if (linkPtr->hPtr == NULL) {
ckfree((char *) linkPtr);
} else {
Tcl_DeleteHashEntry(linkPtr->hPtr);
ckfree((char *) linkPtr);
}
}
}
/*
* Invoke traces on the variable that is being deleted. Then delete
* the variable's trace records.
*/
if (varPtr->tracePtr != NULL) {
CallVarTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, NULL,
flags, /* leaveErrMsg */ 0);
while (varPtr->tracePtr != NULL) {
VarTrace *tracePtr = varPtr->tracePtr;
varPtr->tracePtr = tracePtr->nextPtr;
Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
}
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == varPtr) {
activePtr->nextTracePtr = NULL;
}
}
}
/*
* Now if the variable is an array, delete its element hash table.
* Otherwise, if it's a scalar variable, decrement the ref count
* of its value.
*/
if (TclIsVarArray(varPtr) && (varPtr->value.tablePtr != NULL)) {
DeleteArray(iPtr, varPtr->name, varPtr, flags);
}
if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) {
TclDecrRefCount(varPtr->value.objPtr);
varPtr->value.objPtr = NULL;
}
varPtr->hPtr = NULL;
varPtr->tracePtr = NULL;
TclSetVarUndefined(varPtr);
TclSetVarScalar(varPtr);
varPtr++;
}
}
/*
*----------------------------------------------------------------------
*
* DeleteArray --
*
* This procedure is called to free up everything in an array
* variable. It's the caller's responsibility to make sure
* that the array is no longer accessible before this procedure
* is called.
*
* Results:
* None.
*
* Side effects:
* All storage associated with varPtr's array elements is deleted
* (including the array's hash table). Deletion trace procedures for
* array elements are invoked, then deleted. Any pending traces for
* array elements are also deleted.
*
*----------------------------------------------------------------------
*/
static void
DeleteArray(iPtr, arrayName, varPtr, flags)
Interp *iPtr; /* Interpreter containing array. */
CONST char *arrayName; /* Name of array (used for trace
* callbacks). */
Var *varPtr; /* Pointer to variable structure. */
int flags; /* Flags to pass to CallVarTraces:
* TCL_TRACE_UNSETS and sometimes
* TCL_NAMESPACE_ONLY, or
* TCL_GLOBAL_ONLY. */
{
Tcl_HashSearch search;
register Tcl_HashEntry *hPtr;
register Var *elPtr;
ActiveVarTrace *activePtr;
Tcl_Obj *objPtr;
DeleteSearches(varPtr);
for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
elPtr = (Var *) Tcl_GetHashValue(hPtr);
if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) {
objPtr = elPtr->value.objPtr;
TclDecrRefCount(objPtr);
elPtr->value.objPtr = NULL;
}
elPtr->hPtr = NULL;
if (elPtr->tracePtr != NULL) {
elPtr->flags &= ~VAR_TRACE_ACTIVE;
CallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName,
Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags,
/* leaveErrMsg */ 0);
while (elPtr->tracePtr != NULL) {
VarTrace *tracePtr = elPtr->tracePtr;
elPtr->tracePtr = tracePtr->nextPtr;
Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC);
}
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == elPtr) {
activePtr->nextTracePtr = NULL;
}
}
}
TclSetVarUndefined(elPtr);
TclSetVarScalar(elPtr);
/*
* Even though array elements are not supposed to be namespace
* variables, some combinations of [upvar] and [variable] may
* create such beasts - see [Bug 604239]. This is necessary to
* avoid leaking the corresponding Var struct, and is otherwise
* harmless.
*/
if (elPtr->flags & VAR_NAMESPACE_VAR) {
elPtr->flags &= ~VAR_NAMESPACE_VAR;
elPtr->refCount--;
}
if (elPtr->refCount == 0) {
ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */
}
}
Tcl_DeleteHashTable(varPtr->value.tablePtr);
ckfree((char *) varPtr->value.tablePtr);
}
/*
*----------------------------------------------------------------------
*
* CleanupVar --
*
* This procedure is called when it looks like it may be OK to free up
* a variable's storage. If the variable is in a hashtable, its Var
* structure and hash table entry will be freed along with those of its
* containing array, if any. This procedure is called, for example,
* when a trace on a variable deletes a variable.
*
* Results:
* None.
*
* Side effects:
* If the variable (or its containing array) really is dead and in a
* hashtable, then its Var structure, and possibly its hash table
* entry, is freed up.
*
*----------------------------------------------------------------------
*/
static void
CleanupVar(varPtr, arrayPtr)
Var *varPtr; /* Pointer to variable that may be a
* candidate for being expunged. */
Var *arrayPtr; /* Array that contains the variable, or
* NULL if this variable isn't an array
* element. */
{
if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)
&& (varPtr->tracePtr == NULL)
&& (varPtr->flags & VAR_IN_HASHTABLE)) {
if (varPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(varPtr->hPtr);
}
ckfree((char *) varPtr);
}
if (arrayPtr != NULL) {
if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0)
&& (arrayPtr->tracePtr == NULL)
&& (arrayPtr->flags & VAR_IN_HASHTABLE)) {
if (arrayPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(arrayPtr->hPtr);
}
ckfree((char *) arrayPtr);
}
}
}
/*
*----------------------------------------------------------------------
*
* VarErrMsg --
*
* Generate a reasonable error message describing why a variable
* operation failed.
*
* Results:
* None.
*
* Side effects:
* The interp's result is set to hold a message identifying the
* variable given by part1 and part2 and describing why the
* variable operation failed.
*
*----------------------------------------------------------------------
*/
static void
VarErrMsg(interp, part1, part2, operation, reason)
Tcl_Interp *interp; /* Interpreter in which to record message. */
CONST char *part1;
CONST char *part2; /* Variable's two-part name. */
CONST char *operation; /* String describing operation that failed,
* e.g. "read", "set", or "unset". */
CONST char *reason; /* String describing why operation failed. */
{
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't ", operation, " \"", part1,
(char *) NULL);
if (part2 != NULL) {
Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
}
Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
}
/*
*----------------------------------------------------------------------
*
* TclTraceVarExists --
*
* This is called from info exists. We need to trigger read
* and/or array traces because they may end up creating a
* variable that doesn't currently exist.
*
* Results:
* A pointer to the Var structure, or NULL.
*
* Side effects:
* May fill in error messages in the interp.
*
*----------------------------------------------------------------------
*/
Var *
TclVarTraceExists(interp, varName)
Tcl_Interp *interp; /* The interpreter */
CONST char *varName; /* The variable name */
{
Var *varPtr;
Var *arrayPtr;
/*
* The choice of "create" flag values is delicate here, and
* matches the semantics of GetVar. Things are still not perfect,
* however, because if you do "info exists x" you get a varPtr
* and therefore trigger traces. However, if you do
* "info exists x(i)", then you only get a varPtr if x is already
* known to be an array. Otherwise you get NULL, and no trace
* is triggered. This matches Tcl 7.6 semantics.
*/
varPtr = TclLookupVar(interp, varName, (char *) NULL,
0, "access", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
CallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
TCL_TRACE_READS, /* leaveErrMsg */ 0);
}
/*
* If the variable doesn't exist anymore and no-one's using
* it, then free up the relevant structures and hash table entries.
*/
if (TclIsVarUndefined(varPtr)) {
CleanupVar(varPtr, arrayPtr);
return NULL;
}
return varPtr;
}
/*
*----------------------------------------------------------------------
*
* Internal functions for variable name object types --
*
*----------------------------------------------------------------------
*/
/*
* localVarName -
*
* INTERNALREP DEFINITION:
* twoPtrValue.ptr1 = pointer to the corresponding Proc
* twoPtrValue.ptr2 = index into locals table
*/
static void
FreeLocalVarName(objPtr)
Tcl_Obj *objPtr;
{
register Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
procPtr->refCount--;
if (procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
}
static void
DupLocalVarName(srcPtr, dupPtr)
Tcl_Obj *srcPtr;
Tcl_Obj *dupPtr;
{
register Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1;
dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
dupPtr->internalRep.twoPtrValue.ptr2 = srcPtr->internalRep.twoPtrValue.ptr2;
procPtr->refCount++;
dupPtr->typePtr = &tclLocalVarNameType;
}
static void
UpdateLocalVarName(objPtr)
Tcl_Obj *objPtr;
{
Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
unsigned int index = (unsigned int) objPtr->internalRep.twoPtrValue.ptr2;
CompiledLocal *localPtr = procPtr->firstLocalPtr;
unsigned int nameLen;
if (localPtr == NULL) {
goto emptyName;
}
while (index--) {
localPtr = localPtr->nextPtr;
if (localPtr == NULL) {
goto emptyName;
}
}
nameLen = (unsigned int) localPtr->nameLength;
objPtr->bytes = ckalloc(nameLen + 1);
memcpy(objPtr->bytes, localPtr->name, nameLen + 1);
objPtr->length = nameLen;
return;
emptyName:
objPtr->bytes = ckalloc(1);
*(objPtr->bytes) = '\0';
objPtr->length = 0;
}
/*
* nsVarName -
*
* INTERNALREP DEFINITION:
* twoPtrValue.ptr1: pointer to the namespace containing the
* reference.
* twoPtrValue.ptr2: pointer to the corresponding Var
*/
static void
FreeNsVarName(objPtr)
Tcl_Obj *objPtr;
{
register Var *varPtr = (Var *) objPtr->internalRep.twoPtrValue.ptr2;
varPtr->refCount--;
if (TclIsVarUndefined(varPtr) && (varPtr->refCount <= 0)) {
if (TclIsVarLink(varPtr)) {
Var *linkPtr = varPtr->value.linkPtr;
linkPtr->refCount--;
if (TclIsVarUndefined(linkPtr) && (linkPtr->refCount <= 0)) {
CleanupVar(linkPtr, (Var *) NULL);
}
}
CleanupVar(varPtr, NULL);
}
}
static void
DupNsVarName(srcPtr, dupPtr)
Tcl_Obj *srcPtr;
Tcl_Obj *dupPtr;
{
Namespace *nsPtr = (Namespace *) srcPtr->internalRep.twoPtrValue.ptr1;
register Var *varPtr = (Var *) srcPtr->internalRep.twoPtrValue.ptr2;
dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
varPtr->refCount++;
dupPtr->typePtr = &tclNsVarNameType;
}
/*
* parsedVarName -
*
* INTERNALREP DEFINITION:
* twoPtrValue.ptr1 = pointer to the array name Tcl_Obj
* (NULL if scalar)
* twoPtrValue.ptr2 = pointer to the element name string
* (owned by this Tcl_Obj), or NULL if
* it is a scalar variable
*/
static void
FreeParsedVarName(objPtr)
Tcl_Obj *objPtr;
{
register Tcl_Obj *arrayPtr =
(Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
register char *elem = (char *) objPtr->internalRep.twoPtrValue.ptr2;
if (arrayPtr != NULL) {
TclDecrRefCount(arrayPtr);
ckfree(elem);
}
}
static void
DupParsedVarName(srcPtr, dupPtr)
Tcl_Obj *srcPtr;
Tcl_Obj *dupPtr;
{
register Tcl_Obj *arrayPtr =
(Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr1;
register char *elem = (char *) srcPtr->internalRep.twoPtrValue.ptr2;
char *elemCopy;
unsigned int elemLen;
if (arrayPtr != NULL) {
Tcl_IncrRefCount(arrayPtr);
elemLen = strlen(elem);
elemCopy = ckalloc(elemLen+1);
memcpy(elemCopy, elem, elemLen);
*(elemCopy + elemLen) = '\0';
elem = elemCopy;
}
dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) arrayPtr;
dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) elem;
dupPtr->typePtr = &tclParsedVarNameType;
}
static void
UpdateParsedVarName(objPtr)
Tcl_Obj *objPtr;
{
Tcl_Obj *arrayPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
char *part2 = (char *) objPtr->internalRep.twoPtrValue.ptr2;
char *part1, *p;
int len1, len2, totalLen;
if (arrayPtr == NULL) {
/*
* This is a parsed scalar name: what is it
* doing here?
*/
panic("ERROR: scalar parsedVarName without a string rep.\n");
}
part1 = Tcl_GetStringFromObj(arrayPtr, &len1);
len2 = strlen(part2);
totalLen = len1 + len2 + 2;
p = ckalloc((unsigned int) totalLen + 1);
objPtr->bytes = p;
objPtr->length = totalLen;
memcpy(p, part1, (unsigned int) len1);
p += len1;
*p++ = '(';
memcpy(p, part2, (unsigned int) len2);
p += len2;
*p++ = ')';
*p = '\0';
}
tcl8.4.20/generic/tcl.h 0000644 0036047 0045461 00000244311 12151137515 013262 0 ustar dgp 771div /*
* tcl.h --
*
* This header file describes the externally-visible facilities
* of the Tcl interpreter.
*
* Copyright (c) 1987-1994 The Regents of the University of California.
* Copyright (c) 1993-1996 Lucent Technologies.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
* Copyright (c) 2002 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _TCL
#define _TCL
/*
* For C++ compilers, use extern "C"
*/
#ifdef __cplusplus
extern "C" {
#endif
/*
* The following defines are used to indicate the various release levels.
*/
#define TCL_ALPHA_RELEASE 0
#define TCL_BETA_RELEASE 1
#define TCL_FINAL_RELEASE 2
/*
* When version numbers change here, must also go into the following files
* and update the version numbers:
*
* library/init.tcl (only if Major.minor changes, not patchlevel) 1 LOC
* unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch)
* win/configure.in (as above)
* win/tcl.m4 (not patchlevel)
* win/makefile.vc (not patchlevel) 2 LOC
* README (sections 0 and 2)
* mac/README (2 LOC, not patchlevel)
* macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 1 LOC
* macosx/Tcl.pbproj/default.pbxuser (not patchlevel) 1 LOC
* win/README.binary (sections 0-4)
* win/README (not patchlevel) (sections 0 and 2)
* unix/tcl.spec (2 LOC Major/Minor, 1 LOC patch)
* tests/basic.test (1 LOC M/M, not patchlevel)
* tools/tcl.hpj.in (not patchlevel, for windows installer)
* tools/tcl.wse.in (for windows installer)
* tools/tclSplash.bmp (not patchlevel)
*/
#define TCL_MAJOR_VERSION 8
#define TCL_MINOR_VERSION 4
#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
#define TCL_RELEASE_SERIAL 20
#define TCL_VERSION "8.4"
#define TCL_PATCH_LEVEL "8.4.20"
/*
* The following definitions set up the proper options for Windows
* compilers. We use this method because there is no autoconf equivalent.
*/
#ifndef __WIN32__
# if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__))
# define __WIN32__
# ifndef WIN32
# define WIN32
# endif
# ifndef _WIN32
# define _WIN32
# endif
# endif
#endif
/*
* STRICT: See MSDN Article Q83456
*/
#ifdef __WIN32__
# ifndef STRICT
# define STRICT
# endif
#endif /* __WIN32__ */
/*
* Utility macros: STRINGIFY takes an argument and wraps it in "" (double
* quotation marks), JOIN joins two arguments.
*/
#ifndef STRINGIFY
# define STRINGIFY(x) STRINGIFY1(x)
# define STRINGIFY1(x) #x
#endif
#ifndef JOIN
# define JOIN(a,b) JOIN1(a,b)
# define JOIN1(a,b) a##b
#endif
/*
* A special definition used to allow this header file to be included
* from windows resource files so that they can obtain version
* information. RC_INVOKED is defined by default by the windows RC tool.
*
* Resource compilers don't like all the C stuff, like typedefs and
* procedure declarations, that occur below, so block them out.
*/
#ifndef RC_INVOKED
/*
* Special macro to define mutexes, that doesn't do anything
* if we are not using threads.
*/
#ifdef TCL_THREADS
#define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name;
#else
#define TCL_DECLARE_MUTEX(name)
#endif
/*
* Macros that eliminate the overhead of the thread synchronization
* functions when compiling without thread support.
*/
#ifndef TCL_THREADS
#define Tcl_MutexLock(mutexPtr)
#define Tcl_MutexUnlock(mutexPtr)
#define Tcl_MutexFinalize(mutexPtr)
#define Tcl_ConditionNotify(condPtr)
#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
#define Tcl_ConditionFinalize(condPtr)
#endif /* TCL_THREADS */
#ifndef BUFSIZ
# include
#endif
/*
* Definitions that allow Tcl functions with variable numbers of
* arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS
* is used in procedure prototypes. TCL_VARARGS_DEF is used to declare
* the arguments in a function definiton: it takes the type and name of
* the first argument and supplies the appropriate argument declaration
* string for use in the function definition. TCL_VARARGS_START
* initializes the va_list data structure and returns the first argument.
*/
#if !defined(NO_STDARG)
# include
# define TCL_VARARGS(type, name) (type name, ...)
# define TCL_VARARGS_DEF(type, name) (type name, ...)
# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
#else
# include
# define TCL_VARARGS(type, name) ()
# define TCL_VARARGS_DEF(type, name) (va_alist)
# define TCL_VARARGS_START(type, name, list) \
(va_start(list), va_arg(list, type))
#endif
/*
* Macros used to declare a function to be exported by a DLL.
* Used by Windows, maps to no-op declarations on non-Windows systems.
* The default build on windows is for a DLL, which causes the DLLIMPORT
* and DLLEXPORT macros to be nonempty. To build a static library, the
* macro STATIC_BUILD should be defined.
*/
#if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec))))
# ifdef STATIC_BUILD
# define DLLIMPORT
# define DLLEXPORT
# else
# define DLLIMPORT __declspec(dllimport)
# define DLLEXPORT __declspec(dllexport)
# endif
#else
# define DLLIMPORT
# if defined(__GNUC__) && __GNUC__ > 3
# define DLLEXPORT __attribute__ ((visibility("default")))
# else
# define DLLEXPORT
# endif
#endif
/*
* These macros are used to control whether functions are being declared for
* import or export. If a function is being declared while it is being built
* to be included in a shared library, then it should have the DLLEXPORT
* storage class. If is being declared for use by a module that is going to
* link against the shared library, then it should have the DLLIMPORT storage
* class. If the symbol is beind declared for a static build or for use from a
* stub library, then the storage class should be empty.
*
* The convention is that a macro called BUILD_xxxx, where xxxx is the
* name of a library we are building, is set on the compile line for sources
* that are to be placed in the library. When this macro is set, the
* storage class will be set to DLLEXPORT. At the end of the header file, the
* storage class will be reset to DLLIMPORT.
*/
#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
# define TCL_STORAGE_CLASS DLLEXPORT
#else
# ifdef USE_TCL_STUBS
# define TCL_STORAGE_CLASS
# else
# define TCL_STORAGE_CLASS DLLIMPORT
# endif
#endif
/*
* Definitions that allow this header file to be used either with or
* without ANSI C features like function prototypes.
*/
#undef _ANSI_ARGS_
#undef CONST
#ifndef INLINE
# define INLINE
#endif
#ifndef NO_CONST
# define CONST const
#else
# define CONST
#endif
#ifndef NO_PROTOTYPES
# define _ANSI_ARGS_(x) x
#else
# define _ANSI_ARGS_(x) ()
#endif
#ifdef USE_NON_CONST
# ifdef USE_COMPAT_CONST
# error define at most one of USE_NON_CONST and USE_COMPAT_CONST
# endif
# define CONST84
# define CONST84_RETURN
#else
# ifdef USE_COMPAT_CONST
# define CONST84
# define CONST84_RETURN CONST
# else
# define CONST84 CONST
# define CONST84_RETURN CONST
# endif
#endif
/*
* Make sure EXTERN isn't defined elsewhere
*/
#ifdef EXTERN
# undef EXTERN
#endif /* EXTERN */
#ifdef __cplusplus
# define EXTERN extern "C" TCL_STORAGE_CLASS
#else
# define EXTERN extern TCL_STORAGE_CLASS
#endif
/*
* The following code is copied from winnt.h.
* If we don't replicate it here, then can't be included
* after tcl.h, since tcl.h also defines VOID.
* This block is skipped under Cygwin and Mingw.
*
*
*/
#if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID)
#ifndef VOID
#define VOID void
typedef char CHAR;
typedef short SHORT;
typedef long LONG;
#endif
#endif /* __WIN32__ && !HAVE_WINNT_IGNORE_VOID */
/*
* Macro to use instead of "void" for arguments that must have
* type "void *" in ANSI C; maps them to type "char *" in
* non-ANSI systems.
*/
#ifndef __VXWORKS__
# ifndef NO_VOID
# define VOID void
# else
# define VOID char
# endif
#endif
/*
* Miscellaneous declarations.
*/
#ifndef _CLIENTDATA
# ifndef NO_VOID
typedef void *ClientData;
# else
typedef int *ClientData;
# endif
# define _CLIENTDATA
#endif
/*
* Darwin specific configure overrides (to support fat compiles, where
* configure runs only once for multiple architectures):
*/
#ifdef __APPLE__
# ifdef __LP64__
# undef TCL_WIDE_INT_TYPE
# define TCL_WIDE_INT_IS_LONG 1
# else /* !__LP64__ */
# define TCL_WIDE_INT_TYPE long long
# undef TCL_WIDE_INT_IS_LONG
# endif /* __LP64__ */
# undef HAVE_STRUCT_STAT64
# include
#endif /* __APPLE__ */
/*
* Define Tcl_WideInt to be a type that is (at least) 64-bits wide,
* and define Tcl_WideUInt to be the unsigned variant of that type
* (assuming that where we have one, we can have the other.)
*
* Also defines the following macros:
* TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on
* a real 64-bit system.)
* Tcl_WideAsLong - forgetful converter from wideInt to long.
* Tcl_LongAsWide - sign-extending converter from long to wideInt.
* Tcl_WideAsDouble - converter from wideInt to double.
* Tcl_DoubleAsWide - converter from double to wideInt.
*
* The following invariant should hold for any long value 'longVal':
* longVal == Tcl_WideAsLong(Tcl_LongAsWide(longVal))
*
* Note on converting between Tcl_WideInt and strings. This
* implementation (in tclObj.c) depends on the functions strtoull()
* and sprintf(...,"%" TCL_LL_MODIFIER "d",...). TCL_LL_MODIFIER_SIZE
* is the length of the modifier string, which is "ll" on most 32-bit
* Unix systems. It has to be split up like this to allow for the more
* complex formats sometimes needed (e.g. in the format(n) command.)
*/
#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
# if defined(__WIN32__)
# define TCL_WIDE_INT_TYPE __int64
# ifdef __BORLANDC__
# define TCL_LL_MODIFIER "L"
# define TCL_LL_MODIFIER_SIZE 1
# else /* __BORLANDC__ */
# define TCL_LL_MODIFIER "I64"
# define TCL_LL_MODIFIER_SIZE 3
# endif /* __BORLANDC__ */
# elif defined(__GNUC__)
# define TCL_WIDE_INT_TYPE long long
# define TCL_LL_MODIFIER "ll"
# define TCL_LL_MODIFIER_SIZE 2
# else /* ! __WIN32__ && ! __GNUC__ */
/*
* Don't know what platform it is and configure hasn't discovered what
* is going on for us. Try to guess...
*/
# ifdef NO_LIMITS_H
# error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG
# else /* !NO_LIMITS_H */
# include
# if (INT_MAX < LONG_MAX)
# define TCL_WIDE_INT_IS_LONG 1
# else
# define TCL_WIDE_INT_TYPE long long
# endif
# endif /* NO_LIMITS_H */
# endif /* __WIN32__ */
#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */
#ifdef TCL_WIDE_INT_IS_LONG
# undef TCL_WIDE_INT_TYPE
# define TCL_WIDE_INT_TYPE long
#endif /* TCL_WIDE_INT_IS_LONG */
typedef TCL_WIDE_INT_TYPE Tcl_WideInt;
typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
#ifdef TCL_WIDE_INT_IS_LONG
# define Tcl_WideAsLong(val) ((long)(val))
# define Tcl_LongAsWide(val) ((long)(val))
# define Tcl_WideAsDouble(val) ((double)((long)(val)))
# define Tcl_DoubleAsWide(val) ((long)((double)(val)))
# ifndef TCL_LL_MODIFIER
# define TCL_LL_MODIFIER "l"
# define TCL_LL_MODIFIER_SIZE 1
# endif /* !TCL_LL_MODIFIER */
#else /* TCL_WIDE_INT_IS_LONG */
/*
* The next short section of defines are only done when not running on
* Windows or some other strange platform.
*/
# ifndef TCL_LL_MODIFIER
# define TCL_LL_MODIFIER "ll"
# define TCL_LL_MODIFIER_SIZE 2
# endif /* !TCL_LL_MODIFIER */
# define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
# define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
#endif /* TCL_WIDE_INT_IS_LONG */
#if defined(__WIN32__)
# ifdef __BORLANDC__
typedef struct stati64 Tcl_StatBuf;
# elif defined(_WIN64)
typedef struct __stat64 Tcl_StatBuf;
# elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T)
typedef struct _stati64 Tcl_StatBuf;
# else
typedef struct _stat32i64 Tcl_StatBuf;
# endif /* _MSC_VER < 1400 */
#elif defined(__CYGWIN__)
typedef struct _stat32i64 {
dev_t st_dev;
unsigned short st_ino;
unsigned short st_mode;
short st_nlink;
short st_uid;
short st_gid;
/* Here is a 2-byte gap */
dev_t st_rdev;
/* Here is a 4-byte gap */
long long st_size;
struct {long tv_sec;} st_atim;
struct {long tv_sec;} st_mtim;
struct {long tv_sec;} st_ctim;
/* Here is a 4-byte gap */
} Tcl_StatBuf;
#elif defined(HAVE_STRUCT_STAT64)
typedef struct stat64 Tcl_StatBuf;
#else
typedef struct stat Tcl_StatBuf;
#endif
/*
* This flag controls whether binary compatability is maintained with
* extensions built against a previous version of Tcl. This is true
* by default.
*/
#ifndef TCL_PRESERVE_BINARY_COMPATABILITY
# define TCL_PRESERVE_BINARY_COMPATABILITY 1
#endif
/*
* Data structures defined opaquely in this module. The definitions below
* just provide dummy types. A few fields are made visible in Tcl_Interp
* structures, namely those used for returning a string result from
* commands. Direct access to the result field is discouraged in Tcl 8.0.
* The interpreter result is either an object or a string, and the two
* values are kept consistent unless some C code sets interp->result
* directly. Programmers should use either the procedure Tcl_GetObjResult()
* or Tcl_GetStringResult() to read the interpreter's result. See the
* SetResult man page for details.
*
* Note: any change to the Tcl_Interp definition below must be mirrored
* in the "real" definition in tclInt.h.
*
* Note: Tcl_ObjCmdProc procedures do not directly set result and freeProc.
* Instead, they set a Tcl_Obj member in the "real" structure that can be
* accessed with Tcl_GetObjResult() and Tcl_SetObjResult().
*/
typedef struct Tcl_Interp {
char *result; /* If the last command returned a string
* result, this points to it. */
void (*freeProc) _ANSI_ARGS_((char *blockPtr));
/* Zero means the string result is
* statically allocated. TCL_DYNAMIC means
* it was allocated with ckalloc and should
* be freed with ckfree. Other values give
* the address of procedure to invoke to
* free the result. Tcl_Eval must free it
* before executing next command. */
int errorLine; /* When TCL_ERROR is returned, this gives
* the line number within the command where
* the error occurred (1 if first line). */
} Tcl_Interp;
typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_Command_ *Tcl_Command;
typedef struct Tcl_Condition_ *Tcl_Condition;
typedef struct Tcl_EncodingState_ *Tcl_EncodingState;
typedef struct Tcl_Encoding_ *Tcl_Encoding;
typedef struct Tcl_Event Tcl_Event;
typedef struct Tcl_Mutex_ *Tcl_Mutex;
typedef struct Tcl_Pid_ *Tcl_Pid;
typedef struct Tcl_RegExp_ *Tcl_RegExp;
typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey;
typedef struct Tcl_ThreadId_ *Tcl_ThreadId;
typedef struct Tcl_TimerToken_ *Tcl_TimerToken;
typedef struct Tcl_Trace_ *Tcl_Trace;
typedef struct Tcl_Var_ *Tcl_Var;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle;
/*
* Definition of the interface to procedures implementing threads.
* A procedure following this definition is given to each call of
* 'Tcl_CreateThread' and will be called as the main fuction of
* the new thread created by that call.
*/
#if defined __WIN32__
typedef unsigned (__stdcall Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
#else
typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
#endif
/*
* Threading function return types used for abstracting away platform
* differences when writing a Tcl_ThreadCreateProc. See the NewThread
* function in generic/tclThreadTest.c for it's usage.
*/
#ifdef __WIN32__
# define Tcl_ThreadCreateType unsigned __stdcall
# define TCL_THREAD_CREATE_RETURN return 0
#else
# define Tcl_ThreadCreateType void
# define TCL_THREAD_CREATE_RETURN
#endif
/*
* Definition of values for default stacksize and the possible flags to be
* given to Tcl_CreateThread.
*/
#define TCL_THREAD_STACK_DEFAULT (0) /* Use default size for stack */
#define TCL_THREAD_NOFLAGS (0000) /* Standard flags, default behaviour */
#define TCL_THREAD_JOINABLE (0001) /* Mark the thread as joinable */
/*
* Flag values passed to Tcl_GetRegExpFromObj.
*/
#define TCL_REG_BASIC 000000 /* BREs (convenience) */
#define TCL_REG_EXTENDED 000001 /* EREs */
#define TCL_REG_ADVF 000002 /* advanced features in EREs */
#define TCL_REG_ADVANCED 000003 /* AREs (which are also EREs) */
#define TCL_REG_QUOTE 000004 /* no special characters, none */
#define TCL_REG_NOCASE 000010 /* ignore case */
#define TCL_REG_NOSUB 000020 /* don't care about subexpressions */
#define TCL_REG_EXPANDED 000040 /* expanded format, white space &
* comments */
#define TCL_REG_NLSTOP 000100 /* \n doesn't match . or [^ ] */
#define TCL_REG_NLANCH 000200 /* ^ matches after \n, $ before */
#define TCL_REG_NEWLINE 000300 /* newlines are line terminators */
#define TCL_REG_CANMATCH 001000 /* report details on partial/limited
* matches */
/*
* The following flag is experimental and only intended for use by Expect. It
* will probably go away in a later release.
*/
#define TCL_REG_BOSONLY 002000 /* prepend \A to pattern so it only
* matches at the beginning of the
* string. */
/*
* Flags values passed to Tcl_RegExpExecObj.
*/
#define TCL_REG_NOTBOL 0001 /* Beginning of string does not match ^. */
#define TCL_REG_NOTEOL 0002 /* End of string does not match $. */
/*
* Structures filled in by Tcl_RegExpInfo. Note that all offset values are
* relative to the start of the match string, not the beginning of the
* entire string.
*/
typedef struct Tcl_RegExpIndices {
long start; /* character offset of first character in match */
long end; /* character offset of first character after the
* match. */
} Tcl_RegExpIndices;
typedef struct Tcl_RegExpInfo {
int nsubs; /* number of subexpressions in the
* compiled expression */
Tcl_RegExpIndices *matches; /* array of nsubs match offset
* pairs */
long extendStart; /* The offset at which a subsequent
* match might begin. */
long reserved; /* Reserved for later use. */
} Tcl_RegExpInfo;
/*
* Picky compilers complain if this typdef doesn't appear before the
* struct's reference in tclDecls.h.
*/
typedef Tcl_StatBuf *Tcl_Stat_;
typedef struct stat *Tcl_OldStat_;
/*
* When a TCL command returns, the interpreter contains a result from the
* command. Programmers are strongly encouraged to use one of the
* procedures Tcl_GetObjResult() or Tcl_GetStringResult() to read the
* interpreter's result. See the SetResult man page for details. Besides
* this result, the command procedure returns an integer code, which is
* one of the following:
*
* TCL_OK Command completed normally; the interpreter's
* result contains the command's result.
* TCL_ERROR The command couldn't be completed successfully;
* the interpreter's result describes what went wrong.
* TCL_RETURN The command requests that the current procedure
* return; the interpreter's result contains the
* procedure's return value.
* TCL_BREAK The command requests that the innermost loop
* be exited; the interpreter's result is meaningless.
* TCL_CONTINUE Go on to the next iteration of the current loop;
* the interpreter's result is meaningless.
*/
#define TCL_OK 0
#define TCL_ERROR 1
#define TCL_RETURN 2
#define TCL_BREAK 3
#define TCL_CONTINUE 4
#define TCL_RESULT_SIZE 200
/*
* Flags to control what substitutions are performed by Tcl_SubstObj():
*/
#define TCL_SUBST_COMMANDS 001
#define TCL_SUBST_VARIABLES 002
#define TCL_SUBST_BACKSLASHES 004
#define TCL_SUBST_ALL 007
/*
* Argument descriptors for math function callbacks in expressions:
*/
typedef enum {
TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
} Tcl_ValueType;
typedef struct Tcl_Value {
Tcl_ValueType type; /* Indicates intValue or doubleValue is
* valid, or both. */
long intValue; /* Integer value. */
double doubleValue; /* Double-precision floating value. */
Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */
} Tcl_Value;
/*
* Forward declaration of Tcl_Obj to prevent an error when the forward
* reference to Tcl_Obj is encountered in the procedure types declared
* below.
*/
struct Tcl_Obj;
/*
* Procedure types defined by Tcl:
*/
typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int code));
typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask));
typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data));
typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST84 char *argv[]));
typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
ClientData cmdClientData, int argc, CONST84 char *argv[]));
typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, CONST char *command,
Tcl_Command commandInfo, int objc, struct Tcl_Obj * CONST * objv));
typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr,
struct Tcl_Obj *dupPtr));
typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr,
char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
typedef void (Tcl_EncodingFreeProc)_ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags));
typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData,
int flags));
typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr,
ClientData clientData));
typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData,
int flags));
typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask));
typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_FreeInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr));
typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp));
typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(CONST char *, format));
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
struct Tcl_Obj *objPtr));
typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2,
int flags));
typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *oldName, CONST char *newName,
int flags));
typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask,
Tcl_FileProc *proc, ClientData clientData));
typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd));
typedef void (Tcl_AlertNotifierProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_ServiceModeHookProc) _ANSI_ARGS_((int mode));
typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_((VOID));
typedef void (Tcl_FinalizeNotifierProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void));
/*
* The following structure represents a type of object, which is a
* particular internal representation for an object plus a set of
* procedures that provide standard operations on objects of that type.
*/
typedef struct Tcl_ObjType {
char *name; /* Name of the type, e.g. "int". */
Tcl_FreeInternalRepProc *freeIntRepProc;
/* Called to free any storage for the type's
* internal rep. NULL if the internal rep
* does not need freeing. */
Tcl_DupInternalRepProc *dupIntRepProc;
/* Called to create a new object as a copy
* of an existing object. */
Tcl_UpdateStringProc *updateStringProc;
/* Called to update the string rep from the
* type's internal representation. */
Tcl_SetFromAnyProc *setFromAnyProc;
/* Called to convert the object's internal
* rep to this type. Frees the internal rep
* of the old type. Returns TCL_ERROR on
* failure. */
} Tcl_ObjType;
/*
* One of the following structures exists for each object in the Tcl
* system. An object stores a value as either a string, some internal
* representation, or both.
*/
typedef struct Tcl_Obj {
int refCount; /* When 0 the object will be freed. */
char *bytes; /* This points to the first byte of the
* object's string representation. The array
* must be followed by a null byte (i.e., at
* offset length) but may also contain
* embedded null characters. The array's
* storage is allocated by ckalloc. NULL
* means the string rep is invalid and must
* be regenerated from the internal rep.
* Clients should use Tcl_GetStringFromObj
* or Tcl_GetString to get a pointer to the
* byte array as a readonly value. */
int length; /* The number of bytes at *bytes, not
* including the terminating null. */
Tcl_ObjType *typePtr; /* Denotes the object's type. Always
* corresponds to the type of the object's
* internal rep. NULL indicates the object
* has no internal rep (has no type). */
union { /* The internal representation: */
long longValue; /* - an long integer value */
double doubleValue; /* - a double-precision floating value */
VOID *otherValuePtr; /* - another, type-specific value */
Tcl_WideInt wideValue; /* - a long long value */
struct { /* - internal rep as two pointers */
VOID *ptr1;
VOID *ptr2;
} twoPtrValue;
} internalRep;
} Tcl_Obj;
/*
* Macros to increment and decrement a Tcl_Obj's reference count, and to
* test whether an object is shared (i.e. has reference count > 1).
* Note: clients should use Tcl_DecrRefCount() when they are finished using
* an object, and should never call TclFreeObj() directly. TclFreeObj() is
* only defined and made public in tcl.h to support Tcl_DecrRefCount's macro
* definition.
*/
void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));
#ifdef TCL_MEM_DEBUG
# define Tcl_IncrRefCount(objPtr) \
Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)
# define Tcl_DecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
# define Tcl_IsShared(objPtr) \
Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
#else
# define Tcl_IncrRefCount(objPtr) \
++(objPtr)->refCount
/*
* Use do/while0 idiom for optimum correctness without compiler warnings
* http://c2.com/cgi/wiki?TrivialDoWhileLoop
*/
# define Tcl_DecrRefCount(objPtr) \
do { \
Tcl_Obj *_objPtr = (objPtr); \
if (--(_objPtr)->refCount <= 0) { \
TclFreeObj(_objPtr); \
} \
} while(0)
# define Tcl_IsShared(objPtr) \
((objPtr)->refCount > 1)
#endif
/*
* Macros and definitions that help to debug the use of Tcl objects.
* When TCL_MEM_DEBUG is defined, the Tcl_New declarations are
* overridden to call debugging versions of the object creation procedures.
*/
#ifdef TCL_MEM_DEBUG
# define Tcl_NewBooleanObj(val) \
Tcl_DbNewBooleanObj(val, __FILE__, __LINE__)
# define Tcl_NewByteArrayObj(bytes, len) \
Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__)
# define Tcl_NewDoubleObj(val) \
Tcl_DbNewDoubleObj(val, __FILE__, __LINE__)
# define Tcl_NewIntObj(val) \
Tcl_DbNewLongObj(val, __FILE__, __LINE__)
# define Tcl_NewListObj(objc, objv) \
Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__)
# define Tcl_NewLongObj(val) \
Tcl_DbNewLongObj(val, __FILE__, __LINE__)
# define Tcl_NewObj() \
Tcl_DbNewObj(__FILE__, __LINE__)
# define Tcl_NewStringObj(bytes, len) \
Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__)
# define Tcl_NewWideIntObj(val) \
Tcl_DbNewWideIntObj(val, __FILE__, __LINE__)
#endif /* TCL_MEM_DEBUG */
/*
* The following structure contains the state needed by
* Tcl_SaveResult. No-one outside of Tcl should access any of these
* fields. This structure is typically allocated on the stack.
*/
typedef struct Tcl_SavedResult {
char *result;
Tcl_FreeProc *freeProc;
Tcl_Obj *objResultPtr;
char *appendResult;
int appendAvl;
int appendUsed;
char resultSpace[TCL_RESULT_SIZE+1];
} Tcl_SavedResult;
/*
* The following definitions support Tcl's namespace facility.
* Note: the first five fields must match exactly the fields in a
* Namespace structure (see tclInt.h).
*/
typedef struct Tcl_Namespace {
char *name; /* The namespace's name within its parent
* namespace. This contains no ::'s. The
* name of the global namespace is ""
* although "::" is an synonym. */
char *fullName; /* The namespace's fully qualified name.
* This starts with ::. */
ClientData clientData; /* Arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc* deleteProc;
/* Procedure invoked when deleting the
* namespace to, e.g., free clientData. */
struct Tcl_Namespace* parentPtr;
/* Points to the namespace that contains
* this one. NULL if this is the global
* namespace. */
} Tcl_Namespace;
/*
* The following structure represents a call frame, or activation record.
* A call frame defines a naming context for a procedure call: its local
* scope (for local variables) and its namespace scope (used for non-local
* variables; often the global :: namespace). A call frame can also define
* the naming context for a namespace eval or namespace inscope command:
* the namespace in which the command's code should execute. The
* Tcl_CallFrame structures exist only while procedures or namespace
* eval/inscope's are being executed, and provide a Tcl call stack.
*
* A call frame is initialized and pushed using Tcl_PushCallFrame and
* popped using Tcl_PopCallFrame. Storage for a Tcl_CallFrame must be
* provided by the Tcl_PushCallFrame caller, and callers typically allocate
* them on the C call stack for efficiency. For this reason, Tcl_CallFrame
* is defined as a structure and not as an opaque token. However, most
* Tcl_CallFrame fields are hidden since applications should not access
* them directly; others are declared as "dummyX".
*
* WARNING!! The structure definition must be kept consistent with the
* CallFrame structure in tclInt.h. If you change one, change the other.
*/
typedef struct Tcl_CallFrame {
Tcl_Namespace *nsPtr;
int dummy1;
int dummy2;
VOID *dummy3;
VOID *dummy4;
VOID *dummy5;
int dummy6;
VOID *dummy7;
VOID *dummy8;
int dummy9;
VOID *dummy10;
VOID *dummy11;
VOID *dummy12;
VOID *dummy13;
} Tcl_CallFrame;
/*
* Information about commands that is returned by Tcl_GetCommandInfo and
* passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based
* command procedure while proc is a traditional Tcl argc/argv
* string-based procedure. Tcl_CreateObjCommand and Tcl_CreateCommand
* ensure that both objProc and proc are non-NULL and can be called to
* execute the command. However, it may be faster to call one instead of
* the other. The member isNativeObjectProc is set to 1 if an
* object-based procedure was registered by Tcl_CreateObjCommand, and to
* 0 if a string-based procedure was registered by Tcl_CreateCommand.
* The other procedure is typically set to a compatibility wrapper that
* does string-to-object or object-to-string argument conversions then
* calls the other procedure.
*/
typedef struct Tcl_CmdInfo {
int isNativeObjectProc; /* 1 if objProc was registered by a call to
* Tcl_CreateObjCommand; 0 otherwise.
* Tcl_SetCmdInfo does not modify this
* field. */
Tcl_ObjCmdProc *objProc; /* Command's object-based procedure. */
ClientData objClientData; /* ClientData for object proc. */
Tcl_CmdProc *proc; /* Command's string-based procedure. */
ClientData clientData; /* ClientData for string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Procedure to call when command is
* deleted. */
ClientData deleteData; /* Value to pass to deleteProc (usually
* the same as clientData). */
Tcl_Namespace *namespacePtr; /* Points to the namespace that contains
* this command. Note that Tcl_SetCmdInfo
* will not change a command's namespace;
* use Tcl_RenameCommand to do that. */
} Tcl_CmdInfo;
/*
* The structure defined below is used to hold dynamic strings. The only
* field that clients should use is the string field, accessible via the
* macro Tcl_DStringValue.
*/
#define TCL_DSTRING_STATIC_SIZE 200
typedef struct Tcl_DString {
char *string; /* Points to beginning of string: either
* staticSpace below or a malloced array. */
int length; /* Number of non-NULL characters in the
* string. */
int spaceAvl; /* Total number of bytes available for the
* string and its terminating NULL char. */
char staticSpace[TCL_DSTRING_STATIC_SIZE];
/* Space to use in common case where string
* is small. */
} Tcl_DString;
#define Tcl_DStringLength(dsPtr) ((dsPtr)->length)
#define Tcl_DStringValue(dsPtr) ((dsPtr)->string)
#define Tcl_DStringTrunc Tcl_DStringSetLength
/*
* Definitions for the maximum number of digits of precision that may
* be specified in the "tcl_precision" variable, and the number of
* bytes of buffer space required by Tcl_PrintDouble.
*/
#define TCL_MAX_PREC 17
#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10)
/*
* Definition for a number of bytes of buffer space sufficient to hold the
* string representation of an integer in base 10 (assuming the existence
* of 64-bit integers).
*/
#define TCL_INTEGER_SPACE 24
/*
* Flag that may be passed to Tcl_ConvertElement to force it not to
* output braces (careful! if you change this flag be sure to change
* the definitions at the front of tclUtil.c).
*/
#define TCL_DONT_USE_BRACES 1
/*
* Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow
* abbreviated strings.
*/
#define TCL_EXACT 1
/*
* Flag values passed to Tcl_RecordAndEval and/or Tcl_EvalObj.
* WARNING: these bit choices must not conflict with the bit choices
* for evalFlag bits in tclInt.h!!
*/
#define TCL_NO_EVAL 0x10000
#define TCL_EVAL_GLOBAL 0x20000
#define TCL_EVAL_DIRECT 0x40000
#define TCL_EVAL_INVOKE 0x80000
/*
* Special freeProc values that may be passed to Tcl_SetResult (see
* the man page for details):
*/
#define TCL_VOLATILE ((Tcl_FreeProc *) 1)
#define TCL_STATIC ((Tcl_FreeProc *) 0)
#define TCL_DYNAMIC ((Tcl_FreeProc *) 3)
/*
* Flag values passed to variable-related procedures.
*/
#define TCL_GLOBAL_ONLY 1
#define TCL_NAMESPACE_ONLY 2
#define TCL_APPEND_VALUE 4
#define TCL_LIST_ELEMENT 8
#define TCL_TRACE_READS 0x10
#define TCL_TRACE_WRITES 0x20
#define TCL_TRACE_UNSETS 0x40
#define TCL_TRACE_DESTROYED 0x80
#define TCL_INTERP_DESTROYED 0x100
#define TCL_LEAVE_ERR_MSG 0x200
#define TCL_TRACE_ARRAY 0x800
#ifndef TCL_REMOVE_OBSOLETE_TRACES
/* Required to support old variable/vdelete/vinfo traces */
#define TCL_TRACE_OLD_STYLE 0x1000
#endif
/* Indicate the semantics of the result of a trace */
#define TCL_TRACE_RESULT_DYNAMIC 0x8000
#define TCL_TRACE_RESULT_OBJECT 0x10000
/*
* Flag values passed to command-related procedures.
*/
#define TCL_TRACE_RENAME 0x2000
#define TCL_TRACE_DELETE 0x4000
#define TCL_ALLOW_INLINE_COMPILATION 0x20000
/*
* Flag values passed to Tcl_CreateObjTrace, and used internally
* by command execution traces. Slots 4,8,16 and 32 are
* used internally by execution traces (see tclCmdMZ.c)
*/
#define TCL_TRACE_ENTER_EXEC 1
#define TCL_TRACE_LEAVE_EXEC 2
/*
* The TCL_PARSE_PART1 flag is deprecated and has no effect.
* The part1 is now always parsed whenever the part2 is NULL.
* (This is to avoid a common error when converting code to
* use the new object based APIs and forgetting to give the
* flag)
*/
#ifndef TCL_NO_DEPRECATED
# define TCL_PARSE_PART1 0x400
#endif
/*
* Types for linked variables:
*/
#define TCL_LINK_INT 1
#define TCL_LINK_DOUBLE 2
#define TCL_LINK_BOOLEAN 3
#define TCL_LINK_STRING 4
#define TCL_LINK_WIDE_INT 5
#define TCL_LINK_READ_ONLY 0x80
/*
* Forward declarations of Tcl_HashTable and related types.
*/
typedef struct Tcl_HashKeyType Tcl_HashKeyType;
typedef struct Tcl_HashTable Tcl_HashTable;
typedef struct Tcl_HashEntry Tcl_HashEntry;
typedef unsigned int (Tcl_HashKeyProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
VOID *keyPtr));
typedef int (Tcl_CompareHashKeysProc) _ANSI_ARGS_((VOID *keyPtr,
Tcl_HashEntry *hPtr));
typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) _ANSI_ARGS_((
Tcl_HashTable *tablePtr, VOID *keyPtr));
typedef void (Tcl_FreeHashEntryProc) _ANSI_ARGS_((Tcl_HashEntry *hPtr));
/*
* This flag controls whether the hash table stores the hash of a key, or
* recalculates it. There should be no reason for turning this flag off
* as it is completely binary and source compatible unless you directly
* access the bucketPtr member of the Tcl_HashTableEntry structure. This
* member has been removed and the space used to store the hash value.
*/
#ifndef TCL_HASH_KEY_STORE_HASH
# define TCL_HASH_KEY_STORE_HASH 1
#endif
/*
* Structure definition for an entry in a hash table. No-one outside
* Tcl should access any of these fields directly; use the macros
* defined below.
*/
struct Tcl_HashEntry {
Tcl_HashEntry *nextPtr; /* Pointer to next entry in this
* hash bucket, or NULL for end of
* chain. */
Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
#if TCL_HASH_KEY_STORE_HASH
# if TCL_PRESERVE_BINARY_COMPATABILITY
VOID *hash; /* Hash value, stored as pointer to
* ensure that the offsets of the
* fields in this structure are not
* changed. */
# else
unsigned int hash; /* Hash value. */
# endif
#else
Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to
* first entry in this entry's chain:
* used for deleting the entry. */
#endif
ClientData clientData; /* Application stores something here
* with Tcl_SetHashValue. */
union { /* Key has one of these forms: */
char *oneWordValue; /* One-word value for key. */
Tcl_Obj *objPtr; /* Tcl_Obj * key value. */
int words[1]; /* Multiple integer words for key.
* The actual size will be as large
* as necessary for this table's
* keys. */
char string[4]; /* String for key. The actual size
* will be as large as needed to hold
* the key. */
} key; /* MUST BE LAST FIELD IN RECORD!! */
};
/*
* Flags used in Tcl_HashKeyType.
*
* TCL_HASH_KEY_RANDOMIZE_HASH:
* There are some things, pointers for example
* which don't hash well because they do not use
* the lower bits. If this flag is set then the
* hash table will attempt to rectify this by
* randomising the bits and then using the upper
* N bits as the index into the table.
*/
#define TCL_HASH_KEY_RANDOMIZE_HASH 0x1
/*
* Structure definition for the methods associated with a hash table
* key type.
*/
#define TCL_HASH_KEY_TYPE_VERSION 1
struct Tcl_HashKeyType {
int version; /* Version of the table. If this structure is
* extended in future then the version can be
* used to distinguish between different
* structures.
*/
int flags; /* Flags, see above for details. */
/* Calculates a hash value for the key. If this is NULL then the pointer
* itself is used as a hash value.
*/
Tcl_HashKeyProc *hashKeyProc;
/* Compares two keys and returns zero if they do not match, and non-zero
* if they do. If this is NULL then the pointers are compared.
*/
Tcl_CompareHashKeysProc *compareKeysProc;
/* Called to allocate memory for a new entry, i.e. if the key is a
* string then this could allocate a single block which contains enough
* space for both the entry and the string. Only the key field of the
* allocated Tcl_HashEntry structure needs to be filled in. If something
* else needs to be done to the key, i.e. incrementing a reference count
* then that should be done by this function. If this is NULL then Tcl_Alloc
* is used to allocate enough space for a Tcl_HashEntry and the key pointer
* is assigned to key.oneWordValue.
*/
Tcl_AllocHashEntryProc *allocEntryProc;
/* Called to free memory associated with an entry. If something else needs
* to be done to the key, i.e. decrementing a reference count then that
* should be done by this function. If this is NULL then Tcl_Free is used
* to free the Tcl_HashEntry.
*/
Tcl_FreeHashEntryProc *freeEntryProc;
};
/*
* Structure definition for a hash table. Must be in tcl.h so clients
* can allocate space for these structures, but clients should never
* access any fields in this structure.
*/
#define TCL_SMALL_HASH_TABLE 4
struct Tcl_HashTable {
Tcl_HashEntry **buckets; /* Pointer to bucket array. Each
* element points to first entry in
* bucket's hash chain, or NULL. */
Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables
* (to avoid mallocs and frees). */
int numBuckets; /* Total number of buckets allocated
* at **bucketPtr. */
int numEntries; /* Total number of entries present
* in table. */
int rebuildSize; /* Enlarge table when numEntries gets
* to be this large. */
int downShift; /* Shift count used in hashing
* function. Designed to use high-
* order bits of randomized keys. */
int mask; /* Mask value used in hashing
* function. */
int keyType; /* Type of keys used in this table.
* It's either TCL_CUSTOM_KEYS,
* TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
* or an integer giving the number of
* ints that is the size of the key.
*/
#if TCL_PRESERVE_BINARY_COMPATABILITY
Tcl_HashEntry *(*findProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
CONST char *key));
Tcl_HashEntry *(*createProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
CONST char *key, int *newPtr));
#endif
Tcl_HashKeyType *typePtr; /* Type of the keys used in the
* Tcl_HashTable. */
};
/*
* Structure definition for information used to keep track of searches
* through hash tables:
*/
typedef struct Tcl_HashSearch {
Tcl_HashTable *tablePtr; /* Table being searched. */
int nextIndex; /* Index of next bucket to be
* enumerated after present one. */
Tcl_HashEntry *nextEntryPtr; /* Next entry to be enumerated in the
* the current bucket. */
} Tcl_HashSearch;
/*
* Acceptable key types for hash tables:
*
* TCL_STRING_KEYS: The keys are strings, they are copied into
* the entry.
* TCL_ONE_WORD_KEYS: The keys are pointers, the pointer is stored
* in the entry.
* TCL_CUSTOM_TYPE_KEYS: The keys are arbitrary types which are copied
* into the entry.
* TCL_CUSTOM_PTR_KEYS: The keys are pointers to arbitrary types, the
* pointer is stored in the entry.
*
* While maintaining binary compatability the above have to be distinct
* values as they are used to differentiate between old versions of the
* hash table which don't have a typePtr and new ones which do. Once binary
* compatability is discarded in favour of making more wide spread changes
* TCL_STRING_KEYS can be the same as TCL_CUSTOM_TYPE_KEYS, and
* TCL_ONE_WORD_KEYS can be the same as TCL_CUSTOM_PTR_KEYS because they
* simply determine how the key is accessed from the entry and not the
* behaviour.
*/
#define TCL_STRING_KEYS 0
#define TCL_ONE_WORD_KEYS 1
#if TCL_PRESERVE_BINARY_COMPATABILITY
# define TCL_CUSTOM_TYPE_KEYS -2
# define TCL_CUSTOM_PTR_KEYS -1
#else
# define TCL_CUSTOM_TYPE_KEYS TCL_STRING_KEYS
# define TCL_CUSTOM_PTR_KEYS TCL_ONE_WORD_KEYS
#endif
/*
* Macros for clients to use to access fields of hash entries:
*/
#define Tcl_GetHashValue(h) ((h)->clientData)
#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value))
#if TCL_PRESERVE_BINARY_COMPATABILITY
# define Tcl_GetHashKey(tablePtr, h) \
((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \
(tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \
? (h)->key.oneWordValue \
: (h)->key.string))
#else
# define Tcl_GetHashKey(tablePtr, h) \
((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) \
? (h)->key.oneWordValue \
: (h)->key.string))
#endif
/*
* Macros to use for clients to use to invoke find and create procedures
* for hash tables:
*/
#if TCL_PRESERVE_BINARY_COMPATABILITY
# define Tcl_FindHashEntry(tablePtr, key) \
(*((tablePtr)->findProc))(tablePtr, key)
# define Tcl_CreateHashEntry(tablePtr, key, newPtr) \
(*((tablePtr)->createProc))(tablePtr, key, newPtr)
#else /* !TCL_PRESERVE_BINARY_COMPATABILITY */
/*
* Macro to use new extended version of Tcl_InitHashTable.
*/
# define Tcl_InitHashTable(tablePtr, keyType) \
Tcl_InitHashTableEx(tablePtr, keyType, NULL)
#endif /* TCL_PRESERVE_BINARY_COMPATABILITY */
/*
* Flag values to pass to Tcl_DoOneEvent to disable searches
* for some kinds of events:
*/
#define TCL_DONT_WAIT (1<<1)
#define TCL_WINDOW_EVENTS (1<<2)
#define TCL_FILE_EVENTS (1<<3)
#define TCL_TIMER_EVENTS (1<<4)
#define TCL_IDLE_EVENTS (1<<5) /* WAS 0x10 ???? */
#define TCL_ALL_EVENTS (~TCL_DONT_WAIT)
/*
* The following structure defines a generic event for the Tcl event
* system. These are the things that are queued in calls to Tcl_QueueEvent
* and serviced later by Tcl_DoOneEvent. There can be many different
* kinds of events with different fields, corresponding to window events,
* timer events, etc. The structure for a particular event consists of
* a Tcl_Event header followed by additional information specific to that
* event.
*/
struct Tcl_Event {
Tcl_EventProc *proc; /* Procedure to call to service this event. */
struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */
};
/*
* Positions to pass to Tcl_QueueEvent:
*/
typedef enum {
TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK
} Tcl_QueuePosition;
/*
* Values to pass to Tcl_SetServiceMode to specify the behavior of notifier
* event routines.
*/
#define TCL_SERVICE_NONE 0
#define TCL_SERVICE_ALL 1
/*
* The following structure keeps is used to hold a time value, either as
* an absolute time (the number of seconds from the epoch) or as an
* elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT.
*/
typedef struct Tcl_Time {
long sec; /* Seconds. */
long usec; /* Microseconds. */
} Tcl_Time;
typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr));
typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr));
/*
* Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler
* to indicate what sorts of events are of interest:
*/
#define TCL_READABLE (1<<1)
#define TCL_WRITABLE (1<<2)
#define TCL_EXCEPTION (1<<3)
/*
* Flag values to pass to Tcl_OpenCommandChannel to indicate the
* disposition of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR,
* are also used in Tcl_GetStdChannel.
*/
#define TCL_STDIN (1<<1)
#define TCL_STDOUT (1<<2)
#define TCL_STDERR (1<<3)
#define TCL_ENFORCE_MODE (1<<4)
/*
* Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel
* should be closed.
*/
#define TCL_CLOSE_READ (1<<1)
#define TCL_CLOSE_WRITE (1<<2)
/*
* Value to use as the closeProc for a channel that supports the
* close2Proc interface.
*/
#define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)1)
/*
* Channel version tag. This was introduced in 8.3.2/8.4.
*/
#define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1)
#define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2)
#define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3)
#define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4)
/*
* TIP #218: Channel Actions, Ids for Tcl_DriverThreadActionProc
*/
#define TCL_CHANNEL_THREAD_INSERT (0)
#define TCL_CHANNEL_THREAD_REMOVE (1)
/*
* Typedefs for the various operations in a channel type:
*/
typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_((
ClientData instanceData, int mode));
typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp));
typedef int (Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp, int flags));
typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCodePtr));
typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData,
CONST84 char *buf, int toWrite, int *errorCodePtr));
typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData,
long offset, int mode, int *errorCodePtr));
typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_((
ClientData instanceData, Tcl_Interp *interp,
CONST char *optionName, CONST char *value));
typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_((
ClientData instanceData, Tcl_Interp *interp,
CONST84 char *optionName, Tcl_DString *dsPtr));
typedef void (Tcl_DriverWatchProc) _ANSI_ARGS_((
ClientData instanceData, int mask));
typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_((
ClientData instanceData, int direction,
ClientData *handlePtr));
typedef int (Tcl_DriverFlushProc) _ANSI_ARGS_((
ClientData instanceData));
typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_((
ClientData instanceData, int interestMask));
typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_((
ClientData instanceData, Tcl_WideInt offset,
int mode, int *errorCodePtr));
/* TIP #218, Channel Thread Actions */
typedef void (Tcl_DriverThreadActionProc) _ANSI_ARGS_ ((
ClientData instanceData, int action));
/*
* The following declarations either map ckalloc and ckfree to
* malloc and free, or they map them to procedures with all sorts
* of debugging hooks defined in tclCkalloc.c.
*/
#ifdef TCL_MEM_DEBUG
# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__)
# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
# define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__)
# define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__)
#else /* !TCL_MEM_DEBUG */
/*
* If we are not using the debugging allocator, we should call the
* Tcl_Alloc, et al. routines in order to guarantee that every module
* is using the same memory allocator both inside and outside of the
* Tcl library.
*/
# define ckalloc(x) Tcl_Alloc(x)
# define ckfree(x) Tcl_Free(x)
# define ckrealloc(x,y) Tcl_Realloc(x,y)
# define attemptckalloc(x) Tcl_AttemptAlloc(x)
# define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y)
# define Tcl_InitMemory(x)
# define Tcl_DumpActiveMemory(x)
# define Tcl_ValidateAllMemory(x,y)
#endif /* !TCL_MEM_DEBUG */
/*
* struct Tcl_ChannelType:
*
* One such structure exists for each type (kind) of channel.
* It collects together in one place all the functions that are
* part of the specific channel type.
*
* It is recommend that the Tcl_Channel* functions are used to access
* elements of this structure, instead of direct accessing.
*/
typedef struct Tcl_ChannelType {
char *typeName; /* The name of the channel type in Tcl
* commands. This storage is owned by
* channel type. */
Tcl_ChannelTypeVersion version; /* Version of the channel type. */
Tcl_DriverCloseProc *closeProc; /* Procedure to call to close the
* channel, or TCL_CLOSE2PROC if the
* close2Proc should be used
* instead. */
Tcl_DriverInputProc *inputProc; /* Procedure to call for input
* on channel. */
Tcl_DriverOutputProc *outputProc; /* Procedure to call for output
* on channel. */
Tcl_DriverSeekProc *seekProc; /* Procedure to call to seek
* on the channel. May be NULL. */
Tcl_DriverSetOptionProc *setOptionProc;
/* Set an option on a channel. */
Tcl_DriverGetOptionProc *getOptionProc;
/* Get an option from a channel. */
Tcl_DriverWatchProc *watchProc; /* Set up the notifier to watch
* for events on this channel. */
Tcl_DriverGetHandleProc *getHandleProc;
/* Get an OS handle from the channel
* or NULL if not supported. */
Tcl_DriverClose2Proc *close2Proc; /* Procedure to call to close the
* channel if the device supports
* closing the read & write sides
* independently. */
Tcl_DriverBlockModeProc *blockModeProc;
/* Set blocking mode for the
* raw channel. May be NULL. */
/*
* Only valid in TCL_CHANNEL_VERSION_2 channels or later
*/
Tcl_DriverFlushProc *flushProc; /* Procedure to call to flush a
* channel. May be NULL. */
Tcl_DriverHandlerProc *handlerProc; /* Procedure to call to handle a
* channel event. This will be passed
* up the stacked channel chain. */
/*
* Only valid in TCL_CHANNEL_VERSION_3 channels or later
*/
Tcl_DriverWideSeekProc *wideSeekProc;
/* Procedure to call to seek
* on the channel which can
* handle 64-bit offsets. May be
* NULL, and must be NULL if
* seekProc is NULL. */
/*
* Only valid in TCL_CHANNEL_VERSION_4 channels or later
* TIP #218, Channel Thread Actions
*/
Tcl_DriverThreadActionProc *threadActionProc;
/* Procedure to call to notify
* the driver of thread specific
* activity for a channel.
* May be NULL. */
} Tcl_ChannelType;
/*
* The following flags determine whether the blockModeProc above should
* set the channel into blocking or nonblocking mode. They are passed
* as arguments to the blockModeProc procedure in the above structure.
*/
#define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */
#define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking
* mode. */
/*
* Enum for different types of file paths.
*/
typedef enum Tcl_PathType {
TCL_PATH_ABSOLUTE,
TCL_PATH_RELATIVE,
TCL_PATH_VOLUME_RELATIVE
} Tcl_PathType;
/*
* The following structure is used to pass glob type data amongst
* the various glob routines and Tcl_FSMatchInDirectory.
*/
typedef struct Tcl_GlobTypeData {
/* Corresponds to bcdpfls as in 'find -t' */
int type;
/* Corresponds to file permissions */
int perm;
/* Acceptable mac type */
Tcl_Obj* macType;
/* Acceptable mac creator */
Tcl_Obj* macCreator;
} Tcl_GlobTypeData;
/*
* type and permission definitions for glob command
*/
#define TCL_GLOB_TYPE_BLOCK (1<<0)
#define TCL_GLOB_TYPE_CHAR (1<<1)
#define TCL_GLOB_TYPE_DIR (1<<2)
#define TCL_GLOB_TYPE_PIPE (1<<3)
#define TCL_GLOB_TYPE_FILE (1<<4)
#define TCL_GLOB_TYPE_LINK (1<<5)
#define TCL_GLOB_TYPE_SOCK (1<<6)
#define TCL_GLOB_TYPE_MOUNT (1<<7)
#define TCL_GLOB_PERM_RONLY (1<<0)
#define TCL_GLOB_PERM_HIDDEN (1<<1)
#define TCL_GLOB_PERM_R (1<<2)
#define TCL_GLOB_PERM_W (1<<3)
#define TCL_GLOB_PERM_X (1<<4)
/*
* Typedefs for the various filesystem operations:
*/
typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode));
typedef Tcl_Channel (Tcl_FSOpenFileChannelProc)
_ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr,
int mode, int permissions));
typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern,
Tcl_GlobTypeData * types));
typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_StatBuf *buf));
typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr));
typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
int recursive, Tcl_Obj **errorPtr));
typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr));
typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((Tcl_LoadHandle loadHandle));
typedef Tcl_Obj* (Tcl_FSListVolumesProc) _ANSI_ARGS_((void));
/* We have to declare the utime structure here. */
struct utimbuf;
typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
struct utimbuf *tval));
typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, int nextCheckpoint));
typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp,
int index, Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef));
typedef CONST char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_Obj** objPtrRef));
typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp,
int index, Tcl_Obj *pathPtr,
Tcl_Obj *objPtr));
typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_Obj *toPtr, int linkType));
typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj *pathPtr,
Tcl_LoadHandle *handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr));
typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
ClientData *clientDataPtr));
typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc)
_ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc)
_ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData));
typedef ClientData (Tcl_FSDupInternalRepProc)
_ANSI_ARGS_((ClientData clientData));
typedef Tcl_Obj* (Tcl_FSInternalToNormalizedProc)
_ANSI_ARGS_((ClientData clientData));
typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
/*
*----------------------------------------------------------------
* Data structures related to hooking into the filesystem
*----------------------------------------------------------------
*/
/*
* Filesystem version tag. This was introduced in 8.4.
*/
#define TCL_FILESYSTEM_VERSION_1 ((Tcl_FSVersion) 0x1)
/*
* struct Tcl_Filesystem:
*
* One such structure exists for each type (kind) of filesystem.
* It collects together in one place all the functions that are
* part of the specific filesystem. Tcl always accesses the
* filesystem through one of these structures.
*
* Not all entries need be non-NULL; any which are NULL are simply
* ignored. However, a complete filesystem should provide all of
* these functions. The explanations in the structure show
* the importance of each function.
*/
typedef struct Tcl_Filesystem {
CONST char *typeName; /* The name of the filesystem. */
int structureLength; /* Length of this structure, so future
* binary compatibility can be assured. */
Tcl_FSVersion version;
/* Version of the filesystem type. */
Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
/* Function to check whether a path is in
* this filesystem. This is the most
* important filesystem procedure. */
Tcl_FSDupInternalRepProc *dupInternalRepProc;
/* Function to duplicate internal fs rep. May
* be NULL (but then fs is less efficient). */
Tcl_FSFreeInternalRepProc *freeInternalRepProc;
/* Function to free internal fs rep. Must
* be implemented, if internal representations
* need freeing, otherwise it can be NULL. */
Tcl_FSInternalToNormalizedProc *internalToNormalizedProc;
/* Function to convert internal representation
* to a normalized path. Only required if
* the fs creates pure path objects with no
* string/path representation. */
Tcl_FSCreateInternalRepProc *createInternalRepProc;
/* Function to create a filesystem-specific
* internal representation. May be NULL
* if paths have no internal representation,
* or if the Tcl_FSPathInFilesystemProc
* for this filesystem always immediately
* creates an internal representation for
* paths it accepts. */
Tcl_FSNormalizePathProc *normalizePathProc;
/* Function to normalize a path. Should
* be implemented for all filesystems
* which can have multiple string
* representations for the same path
* object. */
Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc;
/* Function to determine the type of a
* path in this filesystem. May be NULL. */
Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc;
/* Function to return the separator
* character(s) for this filesystem. Must
* be implemented. */
Tcl_FSStatProc *statProc;
/*
* Function to process a 'Tcl_FSStat()'
* call. Must be implemented for any
* reasonable filesystem.
*/
Tcl_FSAccessProc *accessProc;
/*
* Function to process a 'Tcl_FSAccess()'
* call. Must be implemented for any
* reasonable filesystem.
*/
Tcl_FSOpenFileChannelProc *openFileChannelProc;
/*
* Function to process a
* 'Tcl_FSOpenFileChannel()' call. Must be
* implemented for any reasonable
* filesystem.
*/
Tcl_FSMatchInDirectoryProc *matchInDirectoryProc;
/* Function to process a
* 'Tcl_FSMatchInDirectory()'. If not
* implemented, then glob and recursive
* copy functionality will be lacking in
* the filesystem. */
Tcl_FSUtimeProc *utimeProc;
/* Function to process a
* 'Tcl_FSUtime()' call. Required to
* allow setting (not reading) of times
* with 'file mtime', 'file atime' and
* the open-r/open-w/fcopy implementation
* of 'file copy'. */
Tcl_FSLinkProc *linkProc;
/* Function to process a
* 'Tcl_FSLink()' call. Should be
* implemented only if the filesystem supports
* links (reading or creating). */
Tcl_FSListVolumesProc *listVolumesProc;
/* Function to list any filesystem volumes
* added by this filesystem. Should be
* implemented only if the filesystem adds
* volumes at the head of the filesystem. */
Tcl_FSFileAttrStringsProc *fileAttrStringsProc;
/* Function to list all attributes strings
* which are valid for this filesystem.
* If not implemented the filesystem will
* not support the 'file attributes' command.
* This allows arbitrary additional information
* to be attached to files in the filesystem. */
Tcl_FSFileAttrsGetProc *fileAttrsGetProc;
/* Function to process a
* 'Tcl_FSFileAttrsGet()' call, used by
* 'file attributes'. */
Tcl_FSFileAttrsSetProc *fileAttrsSetProc;
/* Function to process a
* 'Tcl_FSFileAttrsSet()' call, used by
* 'file attributes'. */
Tcl_FSCreateDirectoryProc *createDirectoryProc;
/* Function to process a
* 'Tcl_FSCreateDirectory()' call. Should
* be implemented unless the FS is
* read-only. */
Tcl_FSRemoveDirectoryProc *removeDirectoryProc;
/* Function to process a
* 'Tcl_FSRemoveDirectory()' call. Should
* be implemented unless the FS is
* read-only. */
Tcl_FSDeleteFileProc *deleteFileProc;
/* Function to process a
* 'Tcl_FSDeleteFile()' call. Should
* be implemented unless the FS is
* read-only. */
Tcl_FSCopyFileProc *copyFileProc;
/* Function to process a
* 'Tcl_FSCopyFile()' call. If not
* implemented Tcl will fall back
* on open-r, open-w and fcopy as
* a copying mechanism, for copying
* actions initiated in Tcl (not C). */
Tcl_FSRenameFileProc *renameFileProc;
/* Function to process a
* 'Tcl_FSRenameFile()' call. If not
* implemented, Tcl will fall back on
* a copy and delete mechanism, for
* rename actions initiated in Tcl (not C). */
Tcl_FSCopyDirectoryProc *copyDirectoryProc;
/* Function to process a
* 'Tcl_FSCopyDirectory()' call. If
* not implemented, Tcl will fall back
* on a recursive create-dir, file copy
* mechanism, for copying actions
* initiated in Tcl (not C). */
Tcl_FSLstatProc *lstatProc;
/* Function to process a
* 'Tcl_FSLstat()' call. If not implemented,
* Tcl will attempt to use the 'statProc'
* defined above instead. */
Tcl_FSLoadFileProc *loadFileProc;
/* Function to process a
* 'Tcl_FSLoadFile()' call. If not
* implemented, Tcl will fall back on
* a copy to native-temp followed by a
* Tcl_FSLoadFile on that temporary copy. */
Tcl_FSGetCwdProc *getCwdProc;
/*
* Function to process a 'Tcl_FSGetCwd()'
* call. Most filesystems need not
* implement this. It will usually only be
* called once, if 'getcwd' is called
* before 'chdir'. May be NULL.
*/
Tcl_FSChdirProc *chdirProc;
/*
* Function to process a 'Tcl_FSChdir()'
* call. If filesystems do not implement
* this, it will be emulated by a series of
* directory access checks. Otherwise,
* virtual filesystems which do implement
* it need only respond with a positive
* return result if the dirName is a valid
* directory in their filesystem. They
* need not remember the result, since that
* will be automatically remembered for use
* by GetCwd. Real filesystems should
* carry out the correct action (i.e. call
* the correct system 'chdir' api). If not
* implemented, then 'cd' and 'pwd' will
* fail inside the filesystem.
*/
} Tcl_Filesystem;
/*
* The following definitions are used as values for the 'linkAction' flag
* to Tcl_FSLink, or the linkProc of any filesystem. Any combination
* of flags can be given. For link creation, the linkProc should create
* a link which matches any of the types given.
*
* TCL_CREATE_SYMBOLIC_LINK: Create a symbolic or soft link.
* TCL_CREATE_HARD_LINK: Create a hard link.
*/
#define TCL_CREATE_SYMBOLIC_LINK 0x01
#define TCL_CREATE_HARD_LINK 0x02
/*
* The following structure represents the Notifier functions that
* you can override with the Tcl_SetNotifier call.
*/
typedef struct Tcl_NotifierProcs {
Tcl_SetTimerProc *setTimerProc;
Tcl_WaitForEventProc *waitForEventProc;
Tcl_CreateFileHandlerProc *createFileHandlerProc;
Tcl_DeleteFileHandlerProc *deleteFileHandlerProc;
Tcl_InitNotifierProc *initNotifierProc;
Tcl_FinalizeNotifierProc *finalizeNotifierProc;
Tcl_AlertNotifierProc *alertNotifierProc;
Tcl_ServiceModeHookProc *serviceModeHookProc;
} Tcl_NotifierProcs;
/*
* The following structure represents a user-defined encoding. It collects
* together all the functions that are used by the specific encoding.
*/
typedef struct Tcl_EncodingType {
CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp".
* This name is the unique key for this
* encoding type. */
Tcl_EncodingConvertProc *toUtfProc;
/* Procedure to convert from external
* encoding into UTF-8. */
Tcl_EncodingConvertProc *fromUtfProc;
/* Procedure to convert from UTF-8 into
* external encoding. */
Tcl_EncodingFreeProc *freeProc;
/* If non-NULL, procedure to call when this
* encoding is deleted. */
ClientData clientData; /* Arbitrary value associated with encoding
* type. Passed to conversion procedures. */
int nullSize; /* Number of zero bytes that signify
* end-of-string in this encoding. This
* number is used to determine the source
* string length when the srcLen argument is
* negative. Must be 1 or 2. */
} Tcl_EncodingType;
/*
* The following definitions are used as values for the conversion control
* flags argument when converting text from one character set to another:
*
* TCL_ENCODING_START: Signifies that the source buffer is the first
* block in a (potentially multi-block) input
* stream. Tells the conversion procedure to
* reset to an initial state and perform any
* initialization that needs to occur before the
* first byte is converted. If the source
* buffer contains the entire input stream to be
* converted, this flag should be set.
*
* TCL_ENCODING_END: Signifies that the source buffer is the last
* block in a (potentially multi-block) input
* stream. Tells the conversion routine to
* perform any finalization that needs to occur
* after the last byte is converted and then to
* reset to an initial state. If the source
* buffer contains the entire input stream to be
* converted, this flag should be set.
*
* TCL_ENCODING_STOPONERROR: If set, then the converter will return
* immediately upon encountering an invalid
* byte sequence or a source character that has
* no mapping in the target encoding. If clear,
* then the converter will skip the problem,
* substituting one or more "close" characters
* in the destination buffer and then continue
* to sonvert the source.
*/
#define TCL_ENCODING_START 0x01
#define TCL_ENCODING_END 0x02
#define TCL_ENCODING_STOPONERROR 0x04
/*
* The following data structures and declarations are for the new Tcl
* parser.
*/
/*
* For each word of a command, and for each piece of a word such as a
* variable reference, one of the following structures is created to
* describe the token.
*/
typedef struct Tcl_Token {
int type; /* Type of token, such as TCL_TOKEN_WORD;
* see below for valid types. */
CONST char *start; /* First character in token. */
int size; /* Number of bytes in token. */
int numComponents; /* If this token is composed of other
* tokens, this field tells how many of
* them there are (including components of
* components, etc.). The component tokens
* immediately follow this one. */
} Tcl_Token;
/*
* Type values defined for Tcl_Token structures. These values are
* defined as mask bits so that it's easy to check for collections of
* types.
*
* TCL_TOKEN_WORD - The token describes one word of a command,
* from the first non-blank character of
* the word (which may be " or {) up to but
* not including the space, semicolon, or
* bracket that terminates the word.
* NumComponents counts the total number of
* sub-tokens that make up the word. This
* includes, for example, sub-tokens of
* TCL_TOKEN_VARIABLE tokens.
* TCL_TOKEN_SIMPLE_WORD - This token is just like TCL_TOKEN_WORD
* except that the word is guaranteed to
* consist of a single TCL_TOKEN_TEXT
* sub-token.
* TCL_TOKEN_TEXT - The token describes a range of literal
* text that is part of a word.
* NumComponents is always 0.
* TCL_TOKEN_BS - The token describes a backslash sequence
* that must be collapsed. NumComponents
* is always 0.
* TCL_TOKEN_COMMAND - The token describes a command whose result
* must be substituted into the word. The
* token includes the enclosing brackets.
* NumComponents is always 0.
* TCL_TOKEN_VARIABLE - The token describes a variable
* substitution, including the dollar sign,
* variable name, and array index (if there
* is one) up through the right
* parentheses. NumComponents tells how
* many additional tokens follow to
* represent the variable name. The first
* token will be a TCL_TOKEN_TEXT token
* that describes the variable name. If
* the variable is an array reference then
* there will be one or more additional
* tokens, of type TCL_TOKEN_TEXT,
* TCL_TOKEN_BS, TCL_TOKEN_COMMAND, and
* TCL_TOKEN_VARIABLE, that describe the
* array index; numComponents counts the
* total number of nested tokens that make
* up the variable reference, including
* sub-tokens of TCL_TOKEN_VARIABLE tokens.
* TCL_TOKEN_SUB_EXPR - The token describes one subexpression of a
* expression, from the first non-blank
* character of the subexpression up to but not
* including the space, brace, or bracket
* that terminates the subexpression.
* NumComponents counts the total number of
* following subtokens that make up the
* subexpression; this includes all subtokens
* for any nested TCL_TOKEN_SUB_EXPR tokens.
* For example, a numeric value used as a
* primitive operand is described by a
* TCL_TOKEN_SUB_EXPR token followed by a
* TCL_TOKEN_TEXT token. A binary subexpression
* is described by a TCL_TOKEN_SUB_EXPR token
* followed by the TCL_TOKEN_OPERATOR token
* for the operator, then TCL_TOKEN_SUB_EXPR
* tokens for the left then the right operands.
* TCL_TOKEN_OPERATOR - The token describes one expression operator.
* An operator might be the name of a math
* function such as "abs". A TCL_TOKEN_OPERATOR
* token is always preceeded by one
* TCL_TOKEN_SUB_EXPR token for the operator's
* subexpression, and is followed by zero or
* more TCL_TOKEN_SUB_EXPR tokens for the
* operator's operands. NumComponents is
* always 0.
*/
#define TCL_TOKEN_WORD 1
#define TCL_TOKEN_SIMPLE_WORD 2
#define TCL_TOKEN_TEXT 4
#define TCL_TOKEN_BS 8
#define TCL_TOKEN_COMMAND 16
#define TCL_TOKEN_VARIABLE 32
#define TCL_TOKEN_SUB_EXPR 64
#define TCL_TOKEN_OPERATOR 128
/*
* Parsing error types. On any parsing error, one of these values
* will be stored in the error field of the Tcl_Parse structure
* defined below.
*/
#define TCL_PARSE_SUCCESS 0
#define TCL_PARSE_QUOTE_EXTRA 1
#define TCL_PARSE_BRACE_EXTRA 2
#define TCL_PARSE_MISSING_BRACE 3
#define TCL_PARSE_MISSING_BRACKET 4
#define TCL_PARSE_MISSING_PAREN 5
#define TCL_PARSE_MISSING_QUOTE 6
#define TCL_PARSE_MISSING_VAR_BRACE 7
#define TCL_PARSE_SYNTAX 8
#define TCL_PARSE_BAD_NUMBER 9
/*
* A structure of the following type is filled in by Tcl_ParseCommand.
* It describes a single command parsed from an input string.
*/
#define NUM_STATIC_TOKENS 20
typedef struct Tcl_Parse {
CONST char *commentStart; /* Pointer to # that begins the first of
* one or more comments preceding the
* command. */
int commentSize; /* Number of bytes in comments (up through
* newline character that terminates the
* last comment). If there were no
* comments, this field is 0. */
CONST char *commandStart; /* First character in first word of command. */
int commandSize; /* Number of bytes in command, including
* first character of first word, up
* through the terminating newline,
* close bracket, or semicolon. */
int numWords; /* Total number of words in command. May
* be 0. */
Tcl_Token *tokenPtr; /* Pointer to first token representing
* the words of the command. Initially
* points to staticTokens, but may change
* to point to malloc-ed space if command
* exceeds space in staticTokens. */
int numTokens; /* Total number of tokens in command. */
int tokensAvailable; /* Total number of tokens available at
* *tokenPtr. */
int errorType; /* One of the parsing error types defined
* above. */
/*
* The fields below are intended only for the private use of the
* parser. They should not be used by procedures that invoke
* Tcl_ParseCommand.
*/
CONST char *string; /* The original command string passed to
* Tcl_ParseCommand. */
CONST char *end; /* Points to the character just after the
* last one in the command string. */
Tcl_Interp *interp; /* Interpreter to use for error reporting,
* or NULL. */
CONST char *term; /* Points to character in string that
* terminated most recent token. Filled in
* by ParseTokens. If an error occurs,
* points to beginning of region where the
* error occurred (e.g. the open brace if
* the close brace is missing). */
int incomplete; /* This field is set to 1 by Tcl_ParseCommand
* if the command appears to be incomplete.
* This information is used by
* Tcl_CommandComplete. */
Tcl_Token staticTokens[NUM_STATIC_TOKENS];
/* Initial space for tokens for command.
* This space should be large enough to
* accommodate most commands; dynamic
* space is allocated for very large
* commands that don't fit here. */
} Tcl_Parse;
/*
* The following definitions are the error codes returned by the conversion
* routines:
*
* TCL_OK: All characters were converted.
*
* TCL_CONVERT_NOSPACE: The output buffer would not have been large
* enough for all of the converted data; as many
* characters as could fit were converted though.
*
* TCL_CONVERT_MULTIBYTE: The last few bytes in the source string were
* the beginning of a multibyte sequence, but
* more bytes were needed to complete this
* sequence. A subsequent call to the conversion
* routine should pass the beginning of this
* unconverted sequence plus additional bytes
* from the source stream to properly convert
* the formerly split-up multibyte sequence.
*
* TCL_CONVERT_SYNTAX: The source stream contained an invalid
* character sequence. This may occur if the
* input stream has been damaged or if the input
* encoding method was misidentified. This error
* is reported only if TCL_ENCODING_STOPONERROR
* was specified.
*
* TCL_CONVERT_UNKNOWN: The source string contained a character
* that could not be represented in the target
* encoding. This error is reported only if
* TCL_ENCODING_STOPONERROR was specified.
*/
#define TCL_CONVERT_MULTIBYTE -1
#define TCL_CONVERT_SYNTAX -2
#define TCL_CONVERT_UNKNOWN -3
#define TCL_CONVERT_NOSPACE -4
/*
* The maximum number of bytes that are necessary to represent a single
* Unicode character in UTF-8. The valid values should be 3 or 6 (or
* perhaps 1 if we want to support a non-unicode enabled core).
* If 3, then Tcl_UniChar must be 2-bytes in size (UCS-2). (default)
* If 6, then Tcl_UniChar must be 4-bytes in size (UCS-4).
* At this time UCS-2 mode is the default and recommended mode.
* UCS-4 is experimental and not recommended. It works for the core,
* but most extensions expect UCS-2.
*/
#ifndef TCL_UTF_MAX
#define TCL_UTF_MAX 3
#endif
/*
* This represents a Unicode character. Any changes to this should
* also be reflected in regcustom.h.
*/
#if TCL_UTF_MAX > 4
/*
* unsigned int isn't 100% accurate as it should be a strict 4-byte
* value (perhaps wchar_t). 64-bit systems may have troubles. The
* size of this value must be reflected correctly in regcustom.h and
* in tclEncoding.c.
* XXX: Tcl is currently UCS-2 and planning UTF-16 for the Unicode
* XXX: string rep that Tcl_UniChar represents. Changing the size
* XXX: of Tcl_UniChar is /not/ supported.
*/
typedef unsigned int Tcl_UniChar;
#else
typedef unsigned short Tcl_UniChar;
#endif
/*
* These function have been renamed. The old names are deprecated, but we
* define these macros for backwards compatibilty.
*/
#define Tcl_Ckalloc Tcl_Alloc
#define Tcl_Ckfree Tcl_Free
#define Tcl_Ckrealloc Tcl_Realloc
#define Tcl_Return Tcl_SetResult
#define Tcl_TildeSubst Tcl_TranslateFileName
#define panic Tcl_Panic
#define panicVA Tcl_PanicVA
/*
* The following constant is used to test for older versions of Tcl
* in the stubs tables.
*
* Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different
* value since the stubs tables don't match.
*/
#define TCL_STUB_MAGIC ((int)0xFCA3BACF)
/*
* The following function is required to be defined in all stubs aware
* extensions. The function is actually implemented in the stub
* library, not the main Tcl library, although there is a trivial
* implementation in the main library in case an extension is statically
* linked into an application.
*/
EXTERN CONST char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *version, int exact));
#ifndef USE_TCL_STUBS
/*
* When not using stubs, make it a macro.
*/
#define Tcl_InitStubs(interp, version, exact) \
Tcl_PkgRequire(interp, "Tcl", version, exact)
#endif
/*
* Include the public function declarations that are accessible via
* the stubs table.
*/
#include "tclDecls.h"
/*
* Include platform specific public function declarations that are
* accessible via the stubs table.
*/
#include "tclPlatDecls.h"
/*
* Public functions that are not accessible via the stubs table.
*/
EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv,
Tcl_AppInitProc *appInitProc));
/*
* Convenience declaration of Tcl_AppInit for backwards compatibility.
* This function is not *implemented* by the tcl library, so the storage
* class is neither DLLEXPORT nor DLLIMPORT
*/
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS
EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp));
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#endif /* RC_INVOKED */
/*
* end block for C++
*/
#ifdef __cplusplus
}
#endif
#endif /* _TCL */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
tcl8.4.20/generic/tclIOCmd.c 0000644 0036047 0045461 00000125032 12052456744 014137 0 ustar dgp 771div /*
* tclIOCmd.c --
*
* Contains the definitions of most of the Tcl commands relating to IO.
*
* Copyright (c) 1995-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.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* Callback structure for accept callback in a TCP server.
*/
typedef struct AcceptCallback {
char *script; /* Script to invoke. */
Tcl_Interp *interp; /* Interpreter in which to run it. */
} AcceptCallback;
/*
* Static functions for this file:
*/
static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData,
Tcl_Channel chan, char *address, int port));
static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp,
AcceptCallback *acceptCallbackPtr));
static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData));
static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_((
Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr));
/*
*----------------------------------------------------------------------
*
* Tcl_PutsObjCmd --
*
* This procedure is invoked to process the "puts" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Produces output on a channel.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_PutsObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to puts on. */
Tcl_Obj *string; /* String to write. */
int newline; /* Add a newline at end? */
char *channelId; /* Name of channel for puts. */
int result; /* Result of puts operation. */
int mode; /* Mode in which channel is opened. */
switch (objc) {
case 2: /* puts $x */
string = objv[1];
newline = 1;
channelId = "stdout";
break;
case 3: /* puts -nonewline $x or puts $chan $x */
if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
newline = 0;
channelId = "stdout";
} else {
newline = 1;
channelId = Tcl_GetString(objv[1]);
}
string = objv[2];
break;
case 4: /* puts -nonewline $chan $x or puts $chan $x nonewline */
if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
channelId = Tcl_GetString(objv[2]);
string = objv[3];
} else {
/*
* The code below provides backwards compatibility with an
* old form of the command that is no longer recommended
* or documented.
*/
char *arg;
int length;
arg = Tcl_GetStringFromObj(objv[3], &length);
if ((length != 9) || (strncmp(arg, "nonewline", (size_t) length) != 0)) {
Tcl_AppendResult(interp, "bad argument \"", arg,
"\": should be \"nonewline\"",
(char *) NULL);
return TCL_ERROR;
}
channelId = Tcl_GetString(objv[1]);
string = objv[2];
}
newline = 0;
break;
default: /* puts or puts some bad number of arguments... */
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
return TCL_ERROR;
}
chan = Tcl_GetChannel(interp, channelId, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", channelId,
"\" wasn't opened for writing", (char *) NULL);
return TCL_ERROR;
}
result = Tcl_WriteObj(chan, string);
if (result < 0) {
goto error;
}
if (newline != 0) {
result = Tcl_WriteChars(chan, "\n", 1);
if (result < 0) {
goto error;
}
}
return TCL_OK;
error:
Tcl_AppendResult(interp, "error writing \"", channelId, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FlushObjCmd --
*
* This procedure is called to process the Tcl "flush" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May cause output to appear on the specified channel.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_FlushObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to flush on. */
char *channelId;
int mode;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
channelId = Tcl_GetString(objv[1]);
chan = Tcl_GetChannel(interp, channelId, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", channelId,
"\" wasn't opened for writing", (char *) NULL);
return TCL_ERROR;
}
if (Tcl_Flush(chan) != TCL_OK) {
Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetsObjCmd --
*
* This procedure is called to process the Tcl "gets" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May consume input from channel.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_GetsObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
char *name;
Tcl_Obj *linePtr;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
return TCL_ERROR;
}
name = Tcl_GetString(objv[1]);
chan = Tcl_GetChannel(interp, name, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", name,
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
linePtr = Tcl_NewObj();
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen < 0) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
Tcl_DecrRefCount(linePtr);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading \"", name, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
lineLen = -1;
}
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(linePtr);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
return TCL_OK;
} else {
Tcl_SetObjResult(interp, linePtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ReadObjCmd --
*
* This procedure is invoked to process the Tcl "read" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May consume input from channel.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ReadObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int newline, i; /* Discard newline at end? */
int toRead; /* How many bytes to read? */
int charactersRead; /* How many characters were read? */
int mode; /* Mode in which channel is opened. */
char *name;
Tcl_Obj *resultPtr;
if ((objc != 2) && (objc != 3)) {
argerror:
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");
Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]),
" ?-nonewline? channelId\"", (char *) NULL);
return TCL_ERROR;
}
i = 1;
newline = 0;
if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
newline = 1;
i++;
}
if (i == objc) {
goto argerror;
}
name = Tcl_GetString(objv[i]);
chan = Tcl_GetChannel(interp, name, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", name,
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
i++; /* Consumed channel name. */
/*
* Compute how many bytes to read, and see whether the final
* newline should be dropped.
*/
toRead = -1;
if (i < objc) {
char *arg;
arg = Tcl_GetString(objv[i]);
if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */
if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
return TCL_ERROR;
}
} else if (strcmp(arg, "nonewline") == 0) {
newline = 1;
} else {
Tcl_AppendResult(interp, "bad argument \"", arg,
"\": should be \"nonewline\"", (char *) NULL);
return TCL_ERROR;
}
}
resultPtr = Tcl_NewObj();
Tcl_IncrRefCount(resultPtr);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead < 0) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading \"", name, "\": ",
Tcl_PosixError(interp), (char *) NULL);
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
/*
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline != 0)) {
char *result;
int length;
result = Tcl_GetStringFromObj(resultPtr, &length);
if (result[length - 1] == '\n') {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SeekObjCmd --
*
* This procedure is invoked to process the Tcl "seek" command. See
* the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Moves the position of the access point on the specified channel.
* May flush queued output.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SeekObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt offset; /* Where to seek? */
int mode; /* How to seek? */
Tcl_WideInt result; /* Of calling Tcl_Seek. */
char *chanName;
int optionIndex;
static CONST char *originOptions[] = {
"start", "current", "end", (char *) NULL
};
static CONST int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?");
return TCL_ERROR;
}
chanName = Tcl_GetString(objv[1]);
chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) {
return TCL_ERROR;
}
mode = SEEK_SET;
if (objc == 4) {
if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
mode = modeArray[optionIndex];
}
result = Tcl_Seek(chan, offset, mode);
if (result == Tcl_LongAsWide(-1)) {
Tcl_AppendResult(interp, "error during seek on \"",
chanName, "\": ", Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TellObjCmd --
*
* This procedure is invoked to process the Tcl "tell" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_TellObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
char *chanName;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
/*
* Try to find a channel with the right name and permissions in
* the IO channel table of this interpreter.
*/
chanName = Tcl_GetString(objv[1]);
chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CloseObjCmd --
*
* This procedure is invoked to process the Tcl "close" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May discard queued input; may flush queued output.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_CloseObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to close. */
char *arg;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
arg = Tcl_GetString(objv[1]);
chan = Tcl_GetChannel(interp, arg, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
/*
* If there is an error message and it ends with a newline, remove
* the newline. This is done for command pipeline channels where the
* error output from the subprocesses is stored in interp's result.
*
* NOTE: This is likely to not have any effect on regular error
* messages produced by drivers during the closing of a channel,
* because the Tcl convention is that such error messages do not
* have a terminating newline.
*/
Tcl_Obj *resultPtr;
char *string;
int len;
resultPtr = Tcl_GetObjResult(interp);
string = Tcl_GetStringFromObj(resultPtr, &len);
if ((len > 0) && (string[len - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, len - 1);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FconfigureObjCmd --
*
* This procedure is invoked to process the Tcl "fconfigure" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May modify the behavior of an IO channel.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_FconfigureObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *chanName, *optionName, *valueName;
Tcl_Channel chan; /* The channel to set a mode on. */
int i; /* Iterate over arg-value pairs. */
Tcl_DString ds; /* DString to hold result of
* calling Tcl_GetChannelOption. */
if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
Tcl_WrongNumArgs(interp, 1, objv,
"channelId ?optionName? ?value? ?optionName value?...");
return TCL_ERROR;
}
chanName = Tcl_GetString(objv[1]);
chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if (objc == 2) {
Tcl_DStringInit(&ds);
if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
if (objc == 3) {
Tcl_DStringInit(&ds);
optionName = Tcl_GetString(objv[2]);
if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
for (i = 3; i < objc; i += 2) {
optionName = Tcl_GetString(objv[i-1]);
valueName = Tcl_GetString(objv[i]);
if (Tcl_SetChannelOption(interp, chan, optionName, valueName)
!= TCL_OK) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_EofObjCmd --
*
* This procedure is invoked to process the Tcl "eof" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets interp's result to boolean true or false depending on whether
* the specified channel has an EOF condition.
*
*---------------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_EofObjCmd(unused, interp, objc, objv)
ClientData unused; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan;
int dummy;
char *arg;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
arg = Tcl_GetString(objv[1]);
chan = Tcl_GetChannel(interp, arg, &dummy);
if (chan == NULL) {
return TCL_ERROR;
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_Eof(chan));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ExecObjCmd --
*
* This procedure is invoked to process the "exec" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ExecObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
/*
* This procedure generates an argv array for the string arguments. It
* starts out with stack-allocated space but uses dynamically-allocated
* storage if needed.
*/
#define NUM_ARGS 20
Tcl_Obj *resultPtr;
CONST char **argv;
char *string;
Tcl_Channel chan;
CONST char *argStorage[NUM_ARGS];
int argc, background, i, index, keepNewline, result, skip, length;
static CONST char *options[] = {
"-keepnewline", "--", NULL
};
enum options {
EXEC_KEEPNEWLINE, EXEC_LAST
};
/*
* Check for a leading "-keepnewline" argument.
*/
keepNewline = 0;
for (skip = 1; skip < objc; skip++) {
string = Tcl_GetString(objv[skip]);
if (string[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index == EXEC_KEEPNEWLINE) {
keepNewline = 1;
} else {
skip++;
break;
}
}
if (objc <= skip) {
Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?");
return TCL_ERROR;
}
/*
* See if the command is to be run in background.
*/
background = 0;
string = Tcl_GetString(objv[objc - 1]);
if ((string[0] == '&') && (string[1] == '\0')) {
objc--;
background = 1;
}
/*
* Create the string argument array "argv". Make sure argv is large
* enough to hold the argc arguments plus 1 extra for the zero
* end-of-argv word.
*/
argv = argStorage;
argc = objc - skip;
if ((argc + 1) > (int)(sizeof(argv) / sizeof(argv[0]))) {
argv = (CONST char **) ckalloc((unsigned)(argc + 1) * sizeof(char *));
}
/*
* Copy the string conversions of each (post option) object into the
* argument vector.
*/
for (i = 0; i < argc; i++) {
argv[i] = Tcl_GetString(objv[i + skip]);
}
argv[argc] = NULL;
chan = Tcl_OpenCommandChannel(interp, argc, argv,
(background ? 0 : TCL_STDOUT | TCL_STDERR));
/*
* Free the argv array if malloc'ed storage was used.
*/
if (argv != argStorage) {
ckfree((char *)argv);
}
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if (background) {
/*
* Store the list of PIDs from the pipeline in interp's result and
* detach the PIDs (instead of waiting for them).
*/
TclGetAndDetachPids(interp, chan);
if (Tcl_Close(interp, chan) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
resultPtr = Tcl_NewObj();
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading output from command: ",
Tcl_PosixError(interp), (char *) NULL);
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
}
/*
* If the process produced anything on stderr, it will have been
* returned in the interpreter result. It needs to be appended to
* the result string.
*/
result = Tcl_Close(interp, chan);
string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
Tcl_AppendToObj(resultPtr, string, length);
/*
* If the last character of the result is a newline, then remove
* the newline character.
*/
if (keepNewline == 0) {
string = Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && (string[length - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
return result;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FblockedObjCmd --
*
* This procedure is invoked to process the Tcl "fblocked" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets interp's result to boolean true or false depending on whether
* the preceeding input operation on the channel would have blocked.
*
*---------------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_FblockedObjCmd(unused, interp, objc, objv)
ClientData unused; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan;
int mode;
char *arg;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
arg = Tcl_GetString(objv[1]);
chan = Tcl_GetChannel(interp, arg, &mode);
if (chan == NULL) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
arg, "\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_InputBlocked(chan));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_OpenObjCmd --
*
* This procedure is invoked to process the "open" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_OpenObjCmd(notUsed, interp, objc, objv)
ClientData notUsed; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int pipeline, prot;
char *modeString, *what;
Tcl_Channel chan;
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?");
return TCL_ERROR;
}
prot = 0666;
if (objc == 2) {
modeString = "r";
} else {
modeString = Tcl_GetString(objv[2]);
if (objc == 4) {
if (Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
return TCL_ERROR;
}
}
}
pipeline = 0;
what = Tcl_GetString(objv[1]);
if (what[0] == '|') {
pipeline = 1;
}
/*
* Open the file or create a process pipeline.
*/
if (!pipeline) {
chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
int mode, seekFlag, cmdObjc;
CONST char **cmdArgv;
if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
return TCL_ERROR;
}
mode = TclGetOpenMode(interp, modeString, &seekFlag);
if (mode == -1) {
chan = NULL;
} else {
int flags = TCL_STDERR | TCL_ENFORCE_MODE;
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
flags |= TCL_STDOUT;
break;
case O_WRONLY:
flags |= TCL_STDIN;
break;
case O_RDWR:
flags |= (TCL_STDIN | TCL_STDOUT);
break;
default:
panic("Tcl_OpenCmd: invalid mode value");
break;
}
chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
}
ckfree((char *) cmdArgv);
}
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TcpAcceptCallbacksDeleteProc --
*
* Assocdata cleanup routine called when an interpreter is being
* deleted to set the interp field of all the accept callback records
* registered with the interpreter to NULL. This will prevent the
* interpreter from being used in the future to eval accept scripts.
*
* Results:
* None.
*
* Side effects:
* Deallocates memory and sets the interp field of all the accept
* callback records to NULL to prevent this interpreter from being
* used subsequently to eval accept scripts.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static void
TcpAcceptCallbacksDeleteProc(clientData, interp)
ClientData clientData; /* Data which was passed when the assocdata
* was registered. */
Tcl_Interp *interp; /* Interpreter being deleted - not used. */
{
Tcl_HashTable *hTblPtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
AcceptCallback *acceptCallbackPtr;
hTblPtr = (Tcl_HashTable *) clientData;
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != (Tcl_HashEntry *) NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr);
acceptCallbackPtr->interp = (Tcl_Interp *) NULL;
}
Tcl_DeleteHashTable(hTblPtr);
ckfree((char *) hTblPtr);
}
/*
*----------------------------------------------------------------------
*
* RegisterTcpServerInterpCleanup --
*
* Registers an accept callback record to have its interp
* field set to NULL when the interpreter is deleted.
*
* Results:
* None.
*
* Side effects:
* When, in the future, the interpreter is deleted, the interp
* field of the accept callback data structure will be set to
* NULL. This will prevent attempts to eval the accept script
* in a deleted interpreter.
*
*----------------------------------------------------------------------
*/
static void
RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr)
Tcl_Interp *interp; /* Interpreter for which we want to be
* informed of deletion. */
AcceptCallback *acceptCallbackPtr;
/* The accept callback record whose
* interp field we want set to NULL when
* the interpreter is deleted. */
{
Tcl_HashTable *hTblPtr; /* Hash table for accept callback
* records to smash when the interpreter
* will be deleted. */
Tcl_HashEntry *hPtr; /* Entry for this record. */
int new; /* Is the entry new? */
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
"tclTCPAcceptCallbacks",
NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
(void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr);
}
hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new);
if (!new) {
panic("RegisterTcpServerCleanup: damaged accept record table");
}
Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr);
}
/*
*----------------------------------------------------------------------
*
* UnregisterTcpServerInterpCleanupProc --
*
* Unregister a previously registered accept callback record. The
* interp field of this record will no longer be set to NULL in
* the future when the interpreter is deleted.
*
* Results:
* None.
*
* Side effects:
* Prevents the interp field of the accept callback record from
* being set to NULL in the future when the interpreter is deleted.
*
*----------------------------------------------------------------------
*/
static void
UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr)
Tcl_Interp *interp; /* Interpreter in which the accept callback
* record was registered. */
AcceptCallback *acceptCallbackPtr;
/* The record for which to delete the
* registration. */
{
Tcl_HashTable *hTblPtr;
Tcl_HashEntry *hPtr;
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
"tclTCPAcceptCallbacks", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
return;
}
hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
if (hPtr == (Tcl_HashEntry *) NULL) {
return;
}
Tcl_DeleteHashEntry(hPtr);
}
/*
*----------------------------------------------------------------------
*
* AcceptCallbackProc --
*
* This callback is invoked by the TCP channel driver when it
* accepts a new connection from a client on a server socket.
*
* Results:
* None.
*
* Side effects:
* Whatever the script does.
*
*----------------------------------------------------------------------
*/
static void
AcceptCallbackProc(callbackData, chan, address, port)
ClientData callbackData; /* The data stored when the callback
* was created in the call to
* Tcl_OpenTcpServer. */
Tcl_Channel chan; /* Channel for the newly accepted
* connection. */
char *address; /* Address of client that was
* accepted. */
int port; /* Port of client that was accepted. */
{
AcceptCallback *acceptCallbackPtr;
Tcl_Interp *interp;
char *script;
char portBuf[TCL_INTEGER_SPACE];
int result;
acceptCallbackPtr = (AcceptCallback *) callbackData;
/*
* Check if the callback is still valid; the interpreter may have gone
* away, this is signalled by setting the interp field of the callback
* data to NULL.
*/
if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
script = acceptCallbackPtr->script;
interp = acceptCallbackPtr->interp;
Tcl_Preserve((ClientData) script);
Tcl_Preserve((ClientData) interp);
TclFormatInt(portBuf, port);
Tcl_RegisterChannel(interp, chan);
/*
* Artificially bump the refcount to protect the channel from
* being deleted while the script is being evaluated.
*/
Tcl_RegisterChannel((Tcl_Interp *) NULL, chan);
result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
" ", address, " ", portBuf, (char *) NULL);
if (result != TCL_OK) {
Tcl_BackgroundError(interp);
Tcl_UnregisterChannel(interp, chan);
}
/*
* Decrement the artificially bumped refcount. After this it is
* not safe anymore to use "chan", because it may now be deleted.
*/
Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
Tcl_Release((ClientData) interp);
Tcl_Release((ClientData) script);
} else {
/*
* The interpreter has been deleted, so there is no useful
* way to utilize the client socket - just close it.
*/
Tcl_Close((Tcl_Interp *) NULL, chan);
}
}
/*
*----------------------------------------------------------------------
*
* TcpServerCloseProc --
*
* This callback is called when the TCP server channel for which it
* was registered is being closed. It informs the interpreter in
* which the accept script is evaluated (if that interpreter still
* exists) that this channel no longer needs to be informed if the
* interpreter is deleted.
*
* Results:
* None.
*
* Side effects:
* In the future, if the interpreter is deleted this channel will
* no longer be informed.
*
*----------------------------------------------------------------------
*/
static void
TcpServerCloseProc(callbackData)
ClientData callbackData; /* The data passed in the call to
* Tcl_CreateCloseHandler. */
{
AcceptCallback *acceptCallbackPtr;
/* The actual data. */
acceptCallbackPtr = (AcceptCallback *) callbackData;
if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
acceptCallbackPtr);
}
Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC);
ckfree((char *) acceptCallbackPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SocketObjCmd --
*
* This procedure is invoked to process the "socket" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates a socket based channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_SocketObjCmd(notUsed, interp, objc, objv)
ClientData notUsed; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *socketOptions[] = {
"-async", "-myaddr", "-myport","-server", (char *) NULL
};
enum socketOptions {
SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
};
int optionIndex, a, server, port;
char *arg, *copyScript, *host, *script;
char *myaddr = NULL;
int myport = 0;
int async = 0;
Tcl_Channel chan;
AcceptCallback *acceptCallbackPtr;
server = 0;
script = NULL;
if (TclpHasSockets(interp) != TCL_OK) {
return TCL_ERROR;
}
for (a = 1; a < objc; a++) {
arg = Tcl_GetString(objv[a]);
if (arg[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions,
"option", TCL_EXACT, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum socketOptions) optionIndex) {
case SKT_ASYNC: {
if (server == 1) {
Tcl_AppendResult(interp,
"cannot set -async option for server sockets",
(char *) NULL);
return TCL_ERROR;
}
async = 1;
break;
}
case SKT_MYADDR: {
a++;
if (a >= objc) {
Tcl_AppendResult(interp,
"no argument given for -myaddr option",
(char *) NULL);
return TCL_ERROR;
}
myaddr = Tcl_GetString(objv[a]);
break;
}
case SKT_MYPORT: {
char *myPortName;
a++;
if (a >= objc) {
Tcl_AppendResult(interp,
"no argument given for -myport option",
(char *) NULL);
return TCL_ERROR;
}
myPortName = Tcl_GetString(objv[a]);
if (TclSockGetPort(interp, myPortName, "tcp", &myport)
!= TCL_OK) {
return TCL_ERROR;
}
break;
}
case SKT_SERVER: {
if (async == 1) {
Tcl_AppendResult(interp,
"cannot set -async option for server sockets",
(char *) NULL);
return TCL_ERROR;
}
server = 1;
a++;
if (a >= objc) {
Tcl_AppendResult(interp,
"no argument given for -server option",
(char *) NULL);
return TCL_ERROR;
}
script = Tcl_GetString(objv[a]);
break;
}
default: {
panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
}
}
}
if (server) {
host = myaddr; /* NULL implies INADDR_ANY */
if (myport != 0) {
Tcl_AppendResult(interp, "Option -myport is not valid for servers",
NULL);
return TCL_ERROR;
}
} else if (a < objc) {
host = Tcl_GetString(objv[a]);
a++;
} else {
wrongNumArgs:
Tcl_AppendResult(interp, "wrong # args: should be either:\n",
Tcl_GetString(objv[0]),
" ?-myaddr addr? ?-myport myport? ?-async? host port\n",
Tcl_GetString(objv[0]),
" -server command ?-myaddr addr? port",
(char *) NULL);
return TCL_ERROR;
}
if (a == objc-1) {
if (TclSockGetPort(interp, Tcl_GetString(objv[a]),
"tcp", &port) != TCL_OK) {
return TCL_ERROR;
}
} else {
goto wrongNumArgs;
}
if (server) {
acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned)
sizeof(AcceptCallback));
copyScript = ckalloc((unsigned) strlen(script) + 1);
strcpy(copyScript, script);
acceptCallbackPtr->script = copyScript;
acceptCallbackPtr->interp = interp;
chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
(ClientData) acceptCallbackPtr);
if (chan == (Tcl_Channel) NULL) {
ckfree(copyScript);
ckfree((char *) acceptCallbackPtr);
return TCL_ERROR;
}
/*
* Register with the interpreter to let us know when the
* interpreter is deleted (by having the callback set the
* acceptCallbackPtr->interp field to NULL). This is to
* avoid trying to eval the script in a deleted interpreter.
*/
RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr);
/*
* Register a close callback. This callback will inform the
* interpreter (if it still exists) that this channel does not
* need to be informed when the interpreter is deleted.
*/
Tcl_CreateCloseHandler(chan, TcpServerCloseProc,
(ClientData) acceptCallbackPtr);
} else {
chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
}
Tcl_RegisterChannel(interp, chan);
Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FcopyObjCmd --
*
* This procedure is invoked to process the "fcopy" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Moves data between two channels and possibly sets up a
* background copy handler.
*
*----------------------------------------------------------------------
*/
int
Tcl_FcopyObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel inChan, outChan;
char *arg;
int mode, i;
int toRead, index;
Tcl_Obj *cmdPtr;
static CONST char* switches[] = { "-size", "-command", NULL };
enum { FcopySize, FcopyCommand };
if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
Tcl_WrongNumArgs(interp, 1, objv,
"input output ?-size size? ?-command callback?");
return TCL_ERROR;
}
/*
* Parse the channel arguments and verify that they are readable
* or writable, as appropriate.
*/
arg = Tcl_GetString(objv[1]);
inChan = Tcl_GetChannel(interp, arg, &mode);
if (inChan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
arg,
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
arg = Tcl_GetString(objv[2]);
outChan = Tcl_GetChannel(interp, arg, &mode);
if (outChan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
arg,
"\" wasn't opened for writing", (char *) NULL);
return TCL_ERROR;
}
toRead = -1;
cmdPtr = NULL;
for (i = 3; i < objc; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0,
(int *) &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case FcopySize:
if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
return TCL_ERROR;
}
if (toRead<0) {
/*
* Handle all negative sizes like -1, meaning 'copy all'.
* By resetting toRead we avoid changes in the
* core copying functions (which explicitly check
* for -1 and crash on any other negative value).
*/
toRead = -1;
}
break;
case FcopyCommand:
cmdPtr = objv[i+1];
break;
}
}
return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
}
tcl8.4.20/generic/tclThreadTest.c 0000644 0036047 0045461 00000066052 12133546540 015253 0 ustar dgp 771div /*
* tclThreadTest.c --
*
* This file implements the testthread command. Eventually this
* should be tclThreadCmd.c
* Some of this code is based on work done by Richard Hipp on behalf of
* Conservation Through Innovation, Limited, with their permission.
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#ifdef TCL_THREADS
/*
* Each thread has an single instance of the following structure. There
* is one instance of this structure per thread even if that thread contains
* multiple interpreters. The interpreter identified by this structure is
* the main interpreter for the thread.
*
* The main interpreter is the one that will process any messages
* received by a thread. Any thread can send messages but only the
* main interpreter can receive them.
*/
typedef struct ThreadSpecificData {
Tcl_ThreadId threadId; /* Tcl ID for this thread */
Tcl_Interp *interp; /* Main interpreter for this thread */
int flags; /* See the TP_ defines below... */
struct ThreadSpecificData *nextPtr; /* List for "thread names" */
struct ThreadSpecificData *prevPtr; /* List for "thread names" */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* This list is used to list all threads that have interpreters.
* This is protected by threadMutex.
*/
static struct ThreadSpecificData *threadList;
/*
* The following bit-values are legal for the "flags" field of the
* ThreadSpecificData structure.
*/
#define TP_Dying 0x001 /* This thread is being cancelled */
/*
* An instance of the following structure contains all information that is
* passed into a new thread when the thread is created using either the
* "thread create" Tcl command or the TclCreateThread() C function.
*/
typedef struct ThreadCtrl {
char *script; /* The TCL command this thread should execute */
int flags; /* Initial value of the "flags" field in the
* ThreadSpecificData structure for the new thread.
* Might contain TP_Detached or TP_TclThread. */
Tcl_Condition condWait;
/* This condition variable is used to synchronize
* the parent and child threads. The child won't run
* until it acquires threadMutex, and the parent function
* won't complete until signaled on this condition
* variable. */
} ThreadCtrl;
/*
* This is the event used to send scripts to other threads.
*/
typedef struct ThreadEvent {
Tcl_Event event; /* Must be first */
char *script; /* The script to execute. */
struct ThreadEventResult *resultPtr;
/* To communicate the result. This is
* NULL if we don't care about it. */
} ThreadEvent;
typedef struct ThreadEventResult {
Tcl_Condition done; /* Signaled when the script completes */
int code; /* Return value of Tcl_Eval */
char *result; /* Result from the script */
char *errorInfo; /* Copy of errorInfo variable */
char *errorCode; /* Copy of errorCode variable */
Tcl_ThreadId srcThreadId; /* Id of sending thread, in case it dies */
Tcl_ThreadId dstThreadId; /* Id of target thread, in case it dies */
struct ThreadEvent *eventPtr; /* Back pointer */
struct ThreadEventResult *nextPtr; /* List for cleanup */
struct ThreadEventResult *prevPtr;
} ThreadEventResult;
static ThreadEventResult *resultList;
/*
* This is for simple error handling when a thread script exits badly.
*/
static Tcl_ThreadId errorThreadId;
static char *errorProcString;
/*
* Access to the list of threads and to the thread send results is
* guarded by this mutex.
*/
TCL_DECLARE_MUTEX(threadMutex)
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN int Tcl_ThreadObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int TclCreateThread _ANSI_ARGS_((Tcl_Interp *interp,
char *script, int joinable));
EXTERN int TclThreadList _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN int TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id,
char *script, int wait));
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
Tcl_ThreadCreateType NewTestThread _ANSI_ARGS_((ClientData clientData));
static void ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
static void ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask));
static void ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp));
static void ThreadFreeProc _ANSI_ARGS_((ClientData clientData));
static int ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr,
ClientData clientData));
static void ThreadExitProc _ANSI_ARGS_((ClientData clientData));
/*
*----------------------------------------------------------------------
*
* TclThread_Init --
*
* Initialize the test thread command.
*
* Results:
* TCL_OK if the package was properly initialized.
*
* Side effects:
* Add the "testthread" command to the interp.
*
*----------------------------------------------------------------------
*/
int
TclThread_Init(interp)
Tcl_Interp *interp; /* The current Tcl interpreter */
{
Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd,
(ClientData)NULL ,NULL);
if (Tcl_PkgProvide(interp, "Thread", "1.0" ) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ThreadObjCmd --
*
* This procedure is invoked to process the "testthread" Tcl command.
* See the user documentation for details on what it does.
*
* thread create ?-joinable? ?script?
* thread send id ?-async? script
* thread exit
* thread info id
* thread names
* thread wait
* thread errorproc proc
* thread join id
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ThreadObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int option;
static CONST char *threadOptions[] = {"create", "exit", "id", "join", "names",
"send", "wait", "errorproc",
(char *) NULL};
enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN,
THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions,
"option", 0, &option) != TCL_OK) {
return TCL_ERROR;
}
/*
* Make sure the initial thread is on the list before doing anything.
*/
if (tsdPtr->interp == NULL) {
Tcl_MutexLock(&threadMutex);
tsdPtr->interp = interp;
ListUpdateInner(tsdPtr);
Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
Tcl_MutexUnlock(&threadMutex);
}
switch ((enum options)option) {
case THREAD_CREATE: {
char *script;
int joinable, len;
if (objc == 2) {
/* Neither joinable nor special script
*/
joinable = 0;
script = "testthread wait"; /* Just enter the event loop */
} else if (objc == 3) {
/* Possibly -joinable, then no special script,
* no joinable, then its a script.
*/
script = Tcl_GetString(objv[2]);
len = strlen (script);
if ((len > 1) &&
(script [0] == '-') && (script [1] == 'j') &&
(0 == strncmp (script, "-joinable", (size_t) len))) {
joinable = 1;
script = "testthread wait"; /* Just enter the event loop
*/
} else {
/* Remember the script */
joinable = 0;
}
} else if (objc == 4) {
/* Definitely a script available, but is the flag
* -joinable ?
*/
script = Tcl_GetString(objv[2]);
len = strlen (script);
joinable = ((len > 1) &&
(script [0] == '-') && (script [1] == 'j') &&
(0 == strncmp (script, "-joinable", (size_t) len)));
script = Tcl_GetString(objv[3]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
return TCL_ERROR;
}
return TclCreateThread(interp, script, joinable);
}
case THREAD_EXIT: {
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
ListRemove(NULL);
Tcl_ExitThread(0);
return TCL_OK;
}
case THREAD_ID:
if (objc == 2) {
Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
case THREAD_JOIN: {
long id;
int result, status;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "join id");
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);
if (result == TCL_OK) {
Tcl_SetIntObj (Tcl_GetObjResult (interp), status);
} else {
char buf [20];
sprintf (buf, "%ld", id);
Tcl_AppendResult (interp, "cannot join thread ", buf, NULL);
}
return result;
}
case THREAD_NAMES: {
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return TclThreadList(interp);
}
case THREAD_SEND: {
long id;
char *script;
int wait, arg;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");
return TCL_ERROR;
}
if (objc == 5) {
if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");
return TCL_ERROR;
}
wait = 0;
arg = 3;
} else {
wait = 1;
arg = 2;
}
if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
return TCL_ERROR;
}
arg++;
script = Tcl_GetString(objv[arg]);
return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
}
case THREAD_WAIT: {
while (1) {
(void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
}
}
case THREAD_ERRORPROC: {
/*
* Arrange for this proc to handle thread death errors.
*/
char *proc;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "errorproc proc");
return TCL_ERROR;
}
Tcl_MutexLock(&threadMutex);
errorThreadId = Tcl_GetCurrentThread();
if (errorProcString) {
ckfree(errorProcString);
}
proc = Tcl_GetString(objv[2]);
errorProcString = ckalloc(strlen(proc)+1);
strcpy(errorProcString, proc);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCreateThread --
*
* This procedure is invoked to create a thread containing an interp to
* run a script. This returns after the thread has started executing.
*
* Results:
* A standard Tcl result, which is the thread ID.
*
* Side effects:
* Create a thread.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
TclCreateThread(interp, script, joinable)
Tcl_Interp *interp; /* Current interpreter. */
char *script; /* Script to execute */
int joinable; /* Flag, joinable thread or not */
{
ThreadCtrl ctrl;
Tcl_ThreadId id;
ctrl.script = script;
ctrl.condWait = NULL;
ctrl.flags = 0;
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp,"can't create a new thread",NULL);
return TCL_ERROR;
}
/*
* Wait for the thread to start because it is using something on our stack!
*/
Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&ctrl.condWait);
Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id));
return TCL_OK;
}
/*
*------------------------------------------------------------------------
*
* NewTestThread --
*
* This routine is the "main()" for a new thread whose task is to
* execute a single TCL script. The argument to this function is
* a pointer to a structure that contains the text of the TCL script
* to be executed.
*
* Space to hold the script field of the ThreadControl structure passed
* in as the only argument was obtained from malloc() and must be freed
* by this function before it exits. Space to hold the ThreadControl
* structure itself is released by the calling function, and the
* two condition variables in the ThreadControl structure are destroyed
* by the calling function. The calling function will destroy the
* ThreadControl structure and the condition variable as soon as
* ctrlPtr->condWait is signaled, so this routine must make copies of
* any data it might need after that point.
*
* Results:
* none
*
* Side effects:
* A TCL script is executed in a new thread.
*
*------------------------------------------------------------------------
*/
Tcl_ThreadCreateType
NewTestThread(clientData)
ClientData clientData;
{
ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int result;
char *threadEvalScript;
/*
* Initialize the interpreter. This should be more general.
*/
tsdPtr->interp = Tcl_CreateInterp();
result = Tcl_Init(tsdPtr->interp);
result = TclThread_Init(tsdPtr->interp);
/*
* Update the list of threads.
*/
Tcl_MutexLock(&threadMutex);
ListUpdateInner(tsdPtr);
/*
* We need to keep a pointer to the alloc'ed mem of the script
* we are eval'ing, for the case that we exit during evaluation
*/
threadEvalScript = (char *) ckalloc(strlen(ctrlPtr->script)+1);
strcpy(threadEvalScript, ctrlPtr->script);
Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript);
/*
* Notify the parent we are alive.
*/
Tcl_ConditionNotify(&ctrlPtr->condWait);
Tcl_MutexUnlock(&threadMutex);
/*
* Run the script.
*/
Tcl_Preserve((ClientData) tsdPtr->interp);
result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
if (result != TCL_OK) {
ThreadErrorProc(tsdPtr->interp);
}
/*
* Clean up.
*/
ListRemove(tsdPtr);
Tcl_Release((ClientData) tsdPtr->interp);
Tcl_DeleteInterp(tsdPtr->interp);
Tcl_ExitThread(result);
TCL_THREAD_CREATE_RETURN;
}
/*
*------------------------------------------------------------------------
*
* ThreadErrorProc --
*
* Send a message to the thread willing to hear about errors.
*
* Results:
* none
*
* Side effects:
* Send an event.
*
*------------------------------------------------------------------------
*/
static void
ThreadErrorProc(interp)
Tcl_Interp *interp; /* Interp that failed */
{
Tcl_Channel errChannel;
CONST char *errorInfo, *argv[3];
char *script;
char buf[TCL_DOUBLE_SPACE+1];
sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_WriteChars(errChannel, "Error from thread ", -1);
Tcl_WriteChars(errChannel, buf, -1);
Tcl_WriteChars(errChannel, "\n", 1);
Tcl_WriteChars(errChannel, errorInfo, -1);
Tcl_WriteChars(errChannel, "\n", 1);
} else {
argv[0] = errorProcString;
argv[1] = buf;
argv[2] = errorInfo;
script = Tcl_Merge(3, argv);
TclThreadSend(interp, errorThreadId, script, 0);
ckfree(script);
}
}
/*
*------------------------------------------------------------------------
*
* ListUpdateInner --
*
* Add the thread local storage to the list. This assumes
* the caller has obtained the mutex.
*
* Results:
* none
*
* Side effects:
* Add the thread local storage to its list.
*
*------------------------------------------------------------------------
*/
static void
ListUpdateInner(tsdPtr)
ThreadSpecificData *tsdPtr;
{
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
}
tsdPtr->threadId = Tcl_GetCurrentThread();
tsdPtr->nextPtr = threadList;
if (threadList) {
threadList->prevPtr = tsdPtr;
}
tsdPtr->prevPtr = NULL;
threadList = tsdPtr;
}
/*
*------------------------------------------------------------------------
*
* ListRemove --
*
* Remove the thread local storage from its list. This grabs the
* mutex to protect the list.
*
* Results:
* none
*
* Side effects:
* Remove the thread local storage from its list.
*
*------------------------------------------------------------------------
*/
static void
ListRemove(tsdPtr)
ThreadSpecificData *tsdPtr;
{
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
}
Tcl_MutexLock(&threadMutex);
if (tsdPtr->prevPtr) {
tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
} else {
threadList = tsdPtr->nextPtr;
}
if (tsdPtr->nextPtr) {
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
tsdPtr->nextPtr = tsdPtr->prevPtr = 0;
Tcl_MutexUnlock(&threadMutex);
}
/*
*------------------------------------------------------------------------
*
* TclThreadList --
*
* Return a list of threads running Tcl interpreters.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
int
TclThreadList(interp)
Tcl_Interp *interp;
{
ThreadSpecificData *tsdPtr;
Tcl_Obj *listPtr;
listPtr = Tcl_NewListObj(0, NULL);
Tcl_MutexLock(&threadMutex);
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewLongObj((long)tsdPtr->threadId));
}
Tcl_MutexUnlock(&threadMutex);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*------------------------------------------------------------------------
*
* TclThreadSend --
*
* Send a script to another thread.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
int
TclThreadSend(interp, id, script, wait)
Tcl_Interp *interp; /* The current interpreter. */
Tcl_ThreadId id; /* Thread Id of other interpreter. */
char *script; /* The script to evaluate. */
int wait; /* If 1, we block for the result. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadEvent *threadEventPtr;
ThreadEventResult *resultPtr;
int found, code;
Tcl_ThreadId threadId = (Tcl_ThreadId) id;
/*
* Verify the thread exists.
*/
Tcl_MutexLock(&threadMutex);
found = 0;
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
if (tsdPtr->threadId == threadId) {
found = 1;
break;
}
}
if (!found) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "invalid thread id", NULL);
return TCL_ERROR;
}
/*
* Short circut sends to ourself. Ought to do something with -async,
* like run in an idle handler.
*/
if (threadId == Tcl_GetCurrentThread()) {
Tcl_MutexUnlock(&threadMutex);
return Tcl_GlobalEval(interp, script);
}
/*
* Create the event for its event queue.
*/
threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent));
threadEventPtr->script = ckalloc(strlen(script) + 1);
strcpy(threadEventPtr->script, script);
if (!wait) {
resultPtr = threadEventPtr->resultPtr = NULL;
} else {
resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));
threadEventPtr->resultPtr = resultPtr;
/*
* Initialize the result fields.
*/
resultPtr->done = NULL;
resultPtr->code = 0;
resultPtr->result = NULL;
resultPtr->errorInfo = NULL;
resultPtr->errorCode = NULL;
/*
* Maintain the cleanup list.
*/
resultPtr->srcThreadId = Tcl_GetCurrentThread();
resultPtr->dstThreadId = threadId;
resultPtr->eventPtr = threadEventPtr;
resultPtr->nextPtr = resultList;
if (resultList) {
resultList->prevPtr = resultPtr;
}
resultPtr->prevPtr = NULL;
resultList = resultPtr;
}
/*
* Queue the event and poke the other thread's notifier.
*/
threadEventPtr->event.proc = ThreadEventProc;
Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr,
TCL_QUEUE_TAIL);
Tcl_ThreadAlert(threadId);
if (!wait) {
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
* Block on the results and then get them.
*/
Tcl_ResetResult(interp);
while (resultPtr->result == NULL) {
Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
/*
* Unlink result from the result list.
*/
if (resultPtr->prevPtr) {
resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
} else {
resultList = resultPtr->nextPtr;
}
if (resultPtr->nextPtr) {
resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
}
resultPtr->eventPtr = NULL;
resultPtr->nextPtr = NULL;
resultPtr->prevPtr = NULL;
Tcl_MutexUnlock(&threadMutex);
if (resultPtr->code != TCL_OK) {
if (resultPtr->errorCode) {
Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
ckfree(resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
ckfree(resultPtr->errorInfo);
}
}
Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC);
Tcl_ConditionFinalize(&resultPtr->done);
code = resultPtr->code;
ckfree((char *) resultPtr);
return code;
}
/*
*------------------------------------------------------------------------
*
* ThreadEventProc --
*
* Handle the event in the target thread.
*
* Results:
* Returns 1 to indicate that the event was processed.
*
* Side effects:
* Fills out the ThreadEventResult struct.
*
*------------------------------------------------------------------------
*/
static int
ThreadEventProc(evPtr, mask)
Tcl_Event *evPtr; /* Really ThreadEvent */
int mask;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
Tcl_Interp *interp = tsdPtr->interp;
int code;
CONST char *result, *errorCode, *errorInfo;
if (interp == NULL) {
code = TCL_ERROR;
result = "no target interp!";
errorCode = "THREAD";
errorInfo = "";
} else {
Tcl_Preserve((ClientData) interp);
Tcl_ResetResult(interp);
Tcl_CreateThreadExitHandler(ThreadFreeProc,
(ClientData) threadEventPtr->script);
code = Tcl_GlobalEval(interp, threadEventPtr->script);
Tcl_DeleteThreadExitHandler(ThreadFreeProc,
(ClientData) threadEventPtr->script);
if (code != TCL_OK) {
errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}
result = Tcl_GetStringResult(interp);
}
ckfree(threadEventPtr->script);
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->code = code;
resultPtr->result = ckalloc(strlen(result) + 1);
strcpy(resultPtr->result, result);
if (errorCode != NULL) {
resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
strcpy(resultPtr->errorCode, errorCode);
}
if (errorInfo != NULL) {
resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
strcpy(resultPtr->errorInfo, errorInfo);
}
Tcl_ConditionNotify(&resultPtr->done);
Tcl_MutexUnlock(&threadMutex);
}
if (interp != NULL) {
Tcl_Release((ClientData) interp);
}
return 1;
}
/*
*------------------------------------------------------------------------
*
* ThreadFreeProc --
*
* This is called from when we are exiting and memory needs
* to be freed.
*
* Results:
* None.
*
* Side effects:
* Clears up mem specified in ClientData
*
*------------------------------------------------------------------------
*/
/* ARGSUSED */
static void
ThreadFreeProc(clientData)
ClientData clientData;
{
if (clientData) {
ckfree((char *) clientData);
}
}
/*
*------------------------------------------------------------------------
*
* ThreadDeleteEvent --
*
* This is called from the ThreadExitProc to delete memory related
* to events that we put on the queue.
*
* Results:
* 1 it was our event and we want it removed, 0 otherwise.
*
* Side effects:
* It cleans up our events in the event queue for this thread.
*
*------------------------------------------------------------------------
*/
/* ARGSUSED */
static int
ThreadDeleteEvent(eventPtr, clientData)
Tcl_Event *eventPtr; /* Really ThreadEvent */
ClientData clientData; /* dummy */
{
if (eventPtr->proc == ThreadEventProc) {
ckfree((char *) ((ThreadEvent *) eventPtr)->script);
return 1;
}
/*
* If it was NULL, we were in the middle of servicing the event
* and it should be removed
*/
return (eventPtr->proc == NULL);
}
/*
*------------------------------------------------------------------------
*
* ThreadExitProc --
*
* This is called when the thread exits.
*
* Results:
* None.
*
* Side effects:
* It unblocks anyone that is waiting on a send to this thread.
* It cleans up any events in the event queue for this thread.
*
*------------------------------------------------------------------------
*/
/* ARGSUSED */
static void
ThreadExitProc(clientData)
ClientData clientData;
{
char *threadEvalScript = (char *) clientData;
ThreadEventResult *resultPtr, *nextPtr;
Tcl_ThreadId self = Tcl_GetCurrentThread();
Tcl_MutexLock(&threadMutex);
if (threadEvalScript) {
ckfree((char *) threadEvalScript);
threadEvalScript = NULL;
}
Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL);
for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
nextPtr = resultPtr->nextPtr;
if (resultPtr->srcThreadId == self) {
/*
* We are going away. By freeing up the result we signal
* to the other thread we don't care about the result.
*/
if (resultPtr->prevPtr) {
resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
} else {
resultList = resultPtr->nextPtr;
}
if (resultPtr->nextPtr) {
resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
}
resultPtr->nextPtr = resultPtr->prevPtr = 0;
resultPtr->eventPtr->resultPtr = NULL;
ckfree((char *)resultPtr);
} else if (resultPtr->dstThreadId == self) {
/*
* Dang. The target is going away. Unblock the caller.
* The result string must be dynamically allocated because
* the main thread is going to call free on it.
*/
char *msg = "target thread died";
resultPtr->result = ckalloc(strlen(msg)+1);
strcpy(resultPtr->result, msg);
resultPtr->code = TCL_ERROR;
Tcl_ConditionNotify(&resultPtr->done);
}
}
Tcl_MutexUnlock(&threadMutex);
}
#endif /* TCL_THREADS */
tcl8.4.20/generic/tclBinary.c 0000644 0036047 0045461 00000132555 12052456743 014437 0 ustar dgp 771div /*
* tclBinary.c --
*
* This file contains the implementation of the "binary" Tcl built-in
* command and the Tcl binary data object.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclPort.h"
#include
/*
* The following constants are used by GetFormatSpec to indicate various
* special conditions in the parsing of a format specifier.
*/
#define BINARY_ALL -1 /* Use all elements in the argument. */
#define BINARY_NOCOUNT -2 /* No count was specified in format. */
/*
* The following defines the maximum number of different (integer)
* numbers placed in the object cache by 'binary scan' before it bails
* out and switches back to Plan A (creating a new object for each
* value.) Theoretically, it would be possible to keep the cache
* about for the values that are already in it, but that makes the
* code slower in practise when overflow happens, and makes little
* odds the rest of the time (as measured on my machine.) It is also
* slower (on the sample I tried at least) to grow the cache to hold
* all items we might want to put in it; presumably the extra cost of
* managing the memory for the enlarged table outweighs the benefit
* from allocating fewer objects. This is probably because as the
* number of objects increases, the likelihood of reuse of any
* particular one drops, and there is very little gain from larger
* maximum cache sizes (the value below is chosen to allow caching to
* work in full with conversion of bytes.) - DKF
*/
#define BINARY_SCAN_MAX_CACHE 260
/*
* Prototypes for local procedures defined in this file:
*/
static void DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type,
Tcl_Obj *src, unsigned char **cursorPtr));
static void CopyNumber _ANSI_ARGS_((CONST VOID *from, VOID *to,
unsigned int length));
static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int GetFormatSpec _ANSI_ARGS_((char **formatPtr,
char *cmdPtr, int *countPtr));
static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer,
int type, Tcl_HashTable **numberCachePtr));
static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));
static void DeleteScanNumberCache _ANSI_ARGS_((
Tcl_HashTable *numberCachePtr));
/*
* The following object type represents an array of bytes. An array of
* bytes is not equivalent to an internationalized string. Conceptually, a
* string is an array of 16-bit quantities organized as a sequence of properly
* formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
* Accessor functions are provided to convert a ByteArray to a String or a
* String to a ByteArray. Two or more consecutive bytes in an array of bytes
* may look like a single UTF-8 character if the array is casually treated as
* a string. But obtaining the String from a ByteArray is guaranteed to
* produced properly formed UTF-8 sequences so that there is a one-to-one
* map between bytes and characters.
*
* Converting a ByteArray to a String proceeds by casting each byte in the
* array to a 16-bit quantity, treating that number as a Unicode character,
* and storing the UTF-8 version of that Unicode character in the String.
* For ByteArrays consisting entirely of values 1..127, the corresponding
* String representation is the same as the ByteArray representation.
*
* Converting a String to a ByteArray proceeds by getting the Unicode
* representation of each character in the String, casting it to a
* byte by truncating the upper 8 bits, and then storing the byte in the
* ByteArray. Converting from ByteArray to String and back to ByteArray
* is not lossy, but converting an arbitrary String to a ByteArray may be.
*/
Tcl_ObjType tclByteArrayType = {
"bytearray",
FreeByteArrayInternalRep,
DupByteArrayInternalRep,
UpdateStringOfByteArray,
SetByteArrayFromAny
};
/*
* The following structure is the internal rep for a ByteArray object.
* Keeps track of how much memory has been used and how much has been
* allocated for the byte array to enable growing and shrinking of the
* ByteArray object with fewer mallocs.
*/
typedef struct ByteArray {
int used; /* The number of bytes used in the byte
* array. */
int allocated; /* The amount of space actually allocated
* minus 1 byte. */
unsigned char bytes[4]; /* The array of bytes. The actual size of
* this field depends on the 'allocated' field
* above. */
} ByteArray;
#define BYTEARRAY_SIZE(len) \
((unsigned) (sizeof(ByteArray) - 4 + (len)))
#define GET_BYTEARRAY(objPtr) \
((ByteArray *) (objPtr)->internalRep.otherValuePtr)
#define SET_BYTEARRAY(objPtr, baPtr) \
(objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr)
/*
*---------------------------------------------------------------------------
*
* Tcl_NewByteArrayObj --
*
* This procedure is creates a new ByteArray object and initializes
* it from the given array of bytes.
*
* Results:
* The newly create object is returned. This object will have no
* initial string representation. The returned object has a ref count
* of 0.
*
* Side effects:
* Memory allocated for new object and copy of byte array argument.
*
*---------------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewByteArrayObj
Tcl_Obj *
Tcl_NewByteArrayObj(bytes, length)
CONST unsigned char *bytes; /* The array of bytes used to initialize
* the new object. */
int length; /* Length of the array of bytes, which must
* be >= 0. */
{
return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewByteArrayObj(bytes, length)
CONST unsigned char *bytes; /* The array of bytes used to initialize
* the new object. */
int length; /* Length of the array of bytes, which must
* be >= 0. */
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
Tcl_SetByteArrayObj(objPtr, bytes, length);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
*
* Tcl_DbNewByteArrayObj --
*
* This procedure is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It is the same as the Tcl_NewByteArrayObj
* above except that it calls Tcl_DbCkalloc directly with the file name
* and line number from its caller. This simplifies debugging since then
* the [memory active] command will report the correct file name and line
* number when reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
* result of calling Tcl_NewByteArrayObj.
*
* Results:
* The newly create object is returned. This object will have no
* initial string representation. The returned object has a ref count
* of 0.
*
* Side effects:
* Memory allocated for new object and copy of byte array argument.
*
*---------------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewByteArrayObj(bytes, length, file, line)
CONST unsigned char *bytes; /* The array of bytes used to initialize
* the new object. */
int length; /* Length of the array of bytes, which must
* be >= 0. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
Tcl_SetByteArrayObj(objPtr, bytes, length);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewByteArrayObj(bytes, length, file, line)
CONST unsigned char *bytes; /* The array of bytes used to initialize
* the new object. */
int length; /* Length of the array of bytes, which must
* be >= 0. */
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
return Tcl_NewByteArrayObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
*
* Tcl_SetByteArrayObj --
*
* Modify an object to be a ByteArray object and to have the specified
* array of bytes as its value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep and internal rep is freed.
* Memory allocated for copy of byte array argument.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetByteArrayObj(objPtr, bytes, length)
Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */
CONST unsigned char *bytes; /* The array of bytes to use as the new
* value. */
int length; /* Length of the array of bytes, which must
* be >= 0. */
{
Tcl_ObjType *typePtr;
ByteArray *byteArrayPtr;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_SetByteArrayObj called with shared object");
}
typePtr = objPtr->typePtr;
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
(*typePtr->freeIntRepProc)(objPtr);
}
Tcl_InvalidateStringRep(objPtr);
byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
byteArrayPtr->used = length;
byteArrayPtr->allocated = length;
memcpy((VOID *) byteArrayPtr->bytes, (VOID *) bytes, (size_t) length);
objPtr->typePtr = &tclByteArrayType;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetByteArrayFromObj --
*
* Attempt to get the array of bytes from the Tcl object. If the
* object is not already a ByteArray object, an attempt will be
* made to convert it to one.
*
* Results:
* Pointer to array of bytes representing the ByteArray object.
*
* Side effects:
* Frees old internal rep. Allocates memory for new internal rep.
*
*----------------------------------------------------------------------
*/
unsigned char *
Tcl_GetByteArrayFromObj(objPtr, lengthPtr)
Tcl_Obj *objPtr; /* The ByteArray object. */
int *lengthPtr; /* If non-NULL, filled with length of the
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
SetByteArrayFromAny(NULL, objPtr);
baPtr = GET_BYTEARRAY(objPtr);
if (lengthPtr != NULL) {
*lengthPtr = baPtr->used;
}
return (unsigned char *) baPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetByteArrayLength --
*
* This procedure changes the length of the byte array for this
* object. Once the caller has set the length of the array, it
* is acceptable to directly modify the bytes in the array up until
* Tcl_GetStringFromObj() has been called on this object.
*
* Results:
* The new byte array of the specified length.
*
* Side effects:
* Allocates enough memory for an array of bytes of the requested
* size. When growing the array, the old array is copied to the
* new array; new bytes are undefined. When shrinking, the
* old array is truncated to the specified length.
*
*---------------------------------------------------------------------------
*/
unsigned char *
Tcl_SetByteArrayLength(objPtr, length)
Tcl_Obj *objPtr; /* The ByteArray object. */
int length; /* New length for internal byte array. */
{
ByteArray *byteArrayPtr, *newByteArrayPtr;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_SetObjLength called with shared object");
}
if (objPtr->typePtr != &tclByteArrayType) {
SetByteArrayFromAny(NULL, objPtr);
}
byteArrayPtr = GET_BYTEARRAY(objPtr);
if (length > byteArrayPtr->allocated) {
newByteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
newByteArrayPtr->used = length;
newByteArrayPtr->allocated = length;
memcpy((VOID *) newByteArrayPtr->bytes,
(VOID *) byteArrayPtr->bytes, (size_t) byteArrayPtr->used);
ckfree((char *) byteArrayPtr);
byteArrayPtr = newByteArrayPtr;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
Tcl_InvalidateStringRep(objPtr);
byteArrayPtr->used = length;
return byteArrayPtr->bytes;
}
/*
*---------------------------------------------------------------------------
*
* SetByteArrayFromAny --
*
* Generate the ByteArray internal rep from the string rep.
*
* Results:
* The return value is always TCL_OK.
*
* Side effects:
* A ByteArray object is stored as the internal rep of objPtr.
*
*---------------------------------------------------------------------------
*/
static int
SetByteArrayFromAny(interp, objPtr)
Tcl_Interp *interp; /* Not used. */
Tcl_Obj *objPtr; /* The object to convert to type ByteArray. */
{
Tcl_ObjType *typePtr;
int length;
char *src, *srcEnd;
unsigned char *dst;
ByteArray *byteArrayPtr;
Tcl_UniChar ch;
typePtr = objPtr->typePtr;
if (typePtr != &tclByteArrayType) {
src = Tcl_GetStringFromObj(objPtr, &length);
srcEnd = src + length;
byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
src += Tcl_UtfToUniChar(src, &ch);
*dst++ = (unsigned char) ch;
}
byteArrayPtr->used = dst - byteArrayPtr->bytes;
byteArrayPtr->allocated = length;
if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) {
(*typePtr->freeIntRepProc)(objPtr);
}
objPtr->typePtr = &tclByteArrayType;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeByteArrayInternalRep --
*
* Deallocate the storage associated with a ByteArray data object's
* internal representation.
*
* Results:
* None.
*
* Side effects:
* Frees memory.
*
*----------------------------------------------------------------------
*/
static void
FreeByteArrayInternalRep(objPtr)
Tcl_Obj *objPtr; /* Object with internal rep to free. */
{
ckfree((char *) GET_BYTEARRAY(objPtr));
}
/*
*---------------------------------------------------------------------------
*
* DupByteArrayInternalRep --
*
* Initialize the internal representation of a ByteArray Tcl_Obj
* to a copy of the internal representation of an existing ByteArray
* object.
*
* Results:
* None.
*
* Side effects:
* Allocates memory.
*
*---------------------------------------------------------------------------
*/
static void
DupByteArrayInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
int length;
ByteArray *srcArrayPtr, *copyArrayPtr;
srcArrayPtr = GET_BYTEARRAY(srcPtr);
length = srcArrayPtr->used;
copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy((VOID *) copyArrayPtr->bytes, (VOID *) srcArrayPtr->bytes,
(size_t) length);
SET_BYTEARRAY(copyPtr, copyArrayPtr);
copyPtr->typePtr = &tclByteArrayType;
}
/*
*---------------------------------------------------------------------------
*
* UpdateStringOfByteArray --
*
* Update the string representation for a ByteArray data object.
* Note: This procedure does not invalidate an existing old string rep
* so storage will be lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from
* the ByteArray-to-string conversion.
*
* The object becomes a string object -- the internal rep is
* discarded and the typePtr becomes NULL.
*
*---------------------------------------------------------------------------
*/
static void
UpdateStringOfByteArray(objPtr)
Tcl_Obj *objPtr; /* ByteArray object whose string rep to
* update. */
{
int i, length, size;
unsigned char *src;
char *dst;
ByteArray *byteArrayPtr;
byteArrayPtr = GET_BYTEARRAY(objPtr);
src = byteArrayPtr->bytes;
length = byteArrayPtr->used;
/*
* How much space will string rep need?
*/
size = length;
for (i = 0; i < length; i++) {
if ((src[i] == 0) || (src[i] > 127)) {
size++;
}
}
dst = (char *) ckalloc((unsigned) (size + 1));
objPtr->bytes = dst;
objPtr->length = size;
if (size == length) {
memcpy((VOID *) dst, (VOID *) src, (size_t) size);
dst[size] = '\0';
} else {
for (i = 0; i < length; i++) {
dst += Tcl_UniCharToUtf(src[i], dst);
}
*dst = '\0';
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_BinaryObjCmd --
*
* This procedure implements the "binary" Tcl command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_BinaryObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int arg; /* Index of next argument to consume. */
int value = 0; /* Current integer value to be packed.
* Initialized to avoid compiler warning. */
char cmd; /* Current format character. */
int count; /* Count associated with current format
* character. */
char *format; /* Pointer to current position in format
* string. */
Tcl_Obj *resultPtr; /* Object holding result buffer. */
unsigned char *buffer; /* Start of result buffer. */
unsigned char *cursor; /* Current position within result buffer. */
unsigned char *maxPos; /* Greatest position within result buffer that
* cursor has visited.*/
char *errorString, *errorValue, *str;
int offset, size, length, index;
static CONST char *options[] = {
"format", "scan", NULL
};
enum options {
BINARY_FORMAT, BINARY_SCAN
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case BINARY_FORMAT: {
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
return TCL_ERROR;
}
/*
* To avoid copying the data, we format the string in two passes.
* The first pass computes the size of the output buffer. The
* second pass places the formatted data into the buffer.
*/
format = Tcl_GetString(objv[2]);
arg = 3;
offset = 0;
length = 0;
while (*format != '\0') {
str = format;
if (!GetFormatSpec(&format, &cmd, &count)) {
break;
}
switch (cmd) {
case 'a':
case 'A':
case 'b':
case 'B':
case 'h':
case 'H': {
/*
* For string-type specifiers, the count corresponds
* to the number of bytes in a single argument.
*/
if (arg >= objc) {
goto badIndex;
}
if (count == BINARY_ALL) {
Tcl_GetByteArrayFromObj(objv[arg], &count);
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
arg++;
if (cmd == 'a' || cmd == 'A') {
offset += count;
} else if (cmd == 'b' || cmd == 'B') {
offset += (count + 7) / 8;
} else {
offset += (count + 1) / 2;
}
break;
}
case 'c': {
size = 1;
goto doNumbers;
}
case 's':
case 'S': {
size = 2;
goto doNumbers;
}
case 'i':
case 'I': {
size = 4;
goto doNumbers;
}
case 'w':
case 'W': {
size = 8;
goto doNumbers;
}
case 'f': {
size = sizeof(float);
goto doNumbers;
}
case 'd': {
size = sizeof(double);
doNumbers:
if (arg >= objc) {
goto badIndex;
}
/*
* For number-type specifiers, the count corresponds
* to the number of elements in the list stored in
* a single argument. If no count is specified, then
* the argument is taken as a single non-list value.
*/
if (count == BINARY_NOCOUNT) {
arg++;
count = 1;
} else {
int listc;
Tcl_Obj **listv;
if (Tcl_ListObjGetElements(interp, objv[arg++],
&listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
Tcl_AppendResult(interp,
"number of elements in list does not match count",
(char *) NULL);
return TCL_ERROR;
}
}
offset += count*size;
break;
}
case 'x': {
if (count == BINARY_ALL) {
Tcl_AppendResult(interp,
"cannot use \"*\" in format string with \"x\"",
(char *) NULL);
return TCL_ERROR;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
offset += count;
break;
}
case 'X': {
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count > offset) || (count == BINARY_ALL)) {
count = offset;
}
if (offset > length) {
length = offset;
}
offset -= count;
break;
}
case '@': {
if (offset > length) {
length = offset;
}
if (count == BINARY_ALL) {
offset = length;
} else if (count == BINARY_NOCOUNT) {
goto badCount;
} else {
offset = count;
}
break;
}
default: {
errorString = str;
goto badField;
}
}
}
if (offset > length) {
length = offset;
}
if (length == 0) {
return TCL_OK;
}
/*
* Prepare the result object by preallocating the caclulated
* number of bytes and filling with nulls.
*/
resultPtr = Tcl_GetObjResult(interp);
if (Tcl_IsShared(resultPtr)) {
TclNewObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
}
buffer = Tcl_SetByteArrayLength(resultPtr, length);
memset((VOID *) buffer, 0, (size_t) length);
/*
* Pack the data into the result object. Note that we can skip
* the error checking during this pass, since we have already
* parsed the string once.
*/
arg = 3;
format = Tcl_GetString(objv[2]);
cursor = buffer;
maxPos = cursor;
while (*format != 0) {
if (!GetFormatSpec(&format, &cmd, &count)) {
break;
}
if ((count == 0) && (cmd != '@')) {
if (cmd != 'x') {
arg++;
}
continue;
}
switch (cmd) {
case 'a':
case 'A': {
char pad = (char) (cmd == 'a' ? '\0' : ' ');
unsigned char *bytes;
bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
if (length >= count) {
memcpy((VOID *) cursor, (VOID *) bytes,
(size_t) count);
} else {
memcpy((VOID *) cursor, (VOID *) bytes,
(size_t) length);
memset((VOID *) (cursor + length), pad,
(size_t) (count - length));
}
cursor += count;
break;
}
case 'b':
case 'B': {
unsigned char *last;
str = Tcl_GetStringFromObj(objv[arg++], &length);
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
last = cursor + ((count + 7) / 8);
if (count > length) {
count = length;
}
value = 0;
errorString = "binary";
if (cmd == 'B') {
for (offset = 0; offset < count; offset++) {
value <<= 1;
if (str[offset] == '1') {
value |= 1;
} else if (str[offset] != '0') {
errorValue = str;
goto badValue;
}
if (((offset + 1) % 8) == 0) {
*cursor++ = (unsigned char) value;
value = 0;
}
}
} else {
for (offset = 0; offset < count; offset++) {
value >>= 1;
if (str[offset] == '1') {
value |= 128;
} else if (str[offset] != '0') {
errorValue = str;
goto badValue;
}
if (!((offset + 1) % 8)) {
*cursor++ = (unsigned char) value;
value = 0;
}
}
}
if ((offset % 8) != 0) {
if (cmd == 'B') {
value <<= 8 - (offset % 8);
} else {
value >>= 8 - (offset % 8);
}
*cursor++ = (unsigned char) value;
}
while (cursor < last) {
*cursor++ = '\0';
}
break;
}
case 'h':
case 'H': {
unsigned char *last;
int c;
str = Tcl_GetStringFromObj(objv[arg++], &length);
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
last = cursor + ((count + 1) / 2);
if (count > length) {
count = length;
}
value = 0;
errorString = "hexadecimal";
if (cmd == 'H') {
for (offset = 0; offset < count; offset++) {
value <<= 4;
if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
errorValue = str;
goto badValue;
}
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= (c & 0xf);
if (offset % 2) {
*cursor++ = (char) value;
value = 0;
}
}
} else {
for (offset = 0; offset < count; offset++) {
value >>= 4;
if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
errorValue = str;
goto badValue;
}
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= ((c << 4) & 0xf0);
if (offset % 2) {
*cursor++ = (unsigned char)(value & 0xff);
value = 0;
}
}
}
if (offset % 2) {
if (cmd == 'H') {
value <<= 4;
} else {
value >>= 4;
}
*cursor++ = (unsigned char) value;
}
while (cursor < last) {
*cursor++ = '\0';
}
break;
}
case 'c':
case 's':
case 'S':
case 'i':
case 'I':
case 'w':
case 'W':
case 'd':
case 'f': {
int listc, i;
Tcl_Obj **listv;
if (count == BINARY_NOCOUNT) {
/*
* Note that we are casting away the const-ness of
* objv, but this is safe since we aren't going to
* modify the array.
*/
listv = (Tcl_Obj**)(objv + arg);
listc = 1;
count = 1;
} else {
Tcl_ListObjGetElements(interp, objv[arg],
&listc, &listv);
if (count == BINARY_ALL) {
count = listc;
}
}
arg++;
for (i = 0; i < count; i++) {
if (FormatNumber(interp, cmd, listv[i], &cursor)
!= TCL_OK) {
return TCL_ERROR;
}
}
break;
}
case 'x': {
if (count == BINARY_NOCOUNT) {
count = 1;
}
memset(cursor, 0, (size_t) count);
cursor += count;
break;
}
case 'X': {
if (cursor > maxPos) {
maxPos = cursor;
}
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count == BINARY_ALL)
|| (count > (cursor - buffer))) {
cursor = buffer;
} else {
cursor -= count;
}
break;
}
case '@': {
if (cursor > maxPos) {
maxPos = cursor;
}
if (count == BINARY_ALL) {
cursor = maxPos;
} else {
cursor = buffer + count;
}
break;
}
}
}
break;
}
case BINARY_SCAN: {
int i;
Tcl_Obj *valuePtr, *elementPtr;
Tcl_HashTable numberCacheHash;
Tcl_HashTable *numberCachePtr;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv,
"value formatString ?varName varName ...?");
return TCL_ERROR;
}
numberCachePtr = &numberCacheHash;
Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
format = Tcl_GetString(objv[3]);
cursor = buffer;
arg = 4;
offset = 0;
while (*format != '\0') {
str = format;
if (!GetFormatSpec(&format, &cmd, &count)) {
goto done;
}
switch (cmd) {
case 'a':
case 'A': {
unsigned char *src;
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_ALL) {
count = length - offset;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
if (count > (length - offset)) {
goto done;
}
}
src = buffer + offset;
size = count;
/*
* Trim trailing nulls and spaces, if necessary.
*/
if (cmd == 'A') {
while (size > 0) {
if (src[size-1] != '\0' && src[size-1] != ' ') {
break;
}
size--;
}
}
valuePtr = Tcl_NewByteArrayObj(src, size);
Tcl_IncrRefCount(valuePtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(valuePtr);
arg++;
if (resultPtr == NULL) {
DeleteScanNumberCache(numberCachePtr);
return TCL_ERROR;
}
offset += count;
break;
}
case 'b':
case 'B': {
unsigned char *src;
char *dest;
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_ALL) {
count = (length - offset) * 8;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
if (count > (length - offset) * 8) {
goto done;
}
}
src = buffer + offset;
valuePtr = Tcl_NewObj();
Tcl_SetObjLength(valuePtr, count);
dest = Tcl_GetString(valuePtr);
if (cmd == 'b') {
for (i = 0; i < count; i++) {
if (i % 8) {
value >>= 1;
} else {
value = *src++;
}
*dest++ = (char) ((value & 1) ? '1' : '0');
}
} else {
for (i = 0; i < count; i++) {
if (i % 8) {
value <<= 1;
} else {
value = *src++;
}
*dest++ = (char) ((value & 0x80) ? '1' : '0');
}
}
Tcl_IncrRefCount(valuePtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(valuePtr);
arg++;
if (resultPtr == NULL) {
DeleteScanNumberCache(numberCachePtr);
return TCL_ERROR;
}
offset += (count + 7 ) / 8;
break;
}
case 'h':
case 'H': {
char *dest;
unsigned char *src;
int i;
static CONST char hexdigit[] = "0123456789abcdef";
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_ALL) {
count = (length - offset)*2;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
if (count > (length - offset)*2) {
goto done;
}
}
src = buffer + offset;
valuePtr = Tcl_NewObj();
Tcl_SetObjLength(valuePtr, count);
dest = Tcl_GetString(valuePtr);
if (cmd == 'h') {
for (i = 0; i < count; i++) {
if (i % 2) {
value >>= 4;
} else {
value = *src++;
}
*dest++ = hexdigit[value & 0xf];
}
} else {
for (i = 0; i < count; i++) {
if (i % 2) {
value <<= 4;
} else {
value = *src++;
}
*dest++ = hexdigit[(value >> 4) & 0xf];
}
}
Tcl_IncrRefCount(valuePtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(valuePtr);
arg++;
if (resultPtr == NULL) {
DeleteScanNumberCache(numberCachePtr);
return TCL_ERROR;
}
offset += (count + 1) / 2;
break;
}
case 'c': {
size = 1;
goto scanNumber;
}
case 's':
case 'S': {
size = 2;
goto scanNumber;
}
case 'i':
case 'I': {
size = 4;
goto scanNumber;
}
case 'w':
case 'W': {
size = 8;
goto scanNumber;
}
case 'f': {
size = sizeof(float);
goto scanNumber;
}
case 'd': {
unsigned char *src;
size = sizeof(double);
/* fall through */
scanNumber:
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_NOCOUNT) {
if ((length - offset) < size) {
goto done;
}
valuePtr = ScanNumber(buffer+offset, cmd,
&numberCachePtr);
offset += size;
} else {
if (count == BINARY_ALL) {
count = (length - offset) / size;
}
if ((length - offset) < (count * size)) {
goto done;
}
valuePtr = Tcl_NewObj();
src = buffer+offset;
for (i = 0; i < count; i++) {
elementPtr = ScanNumber(src, cmd,
&numberCachePtr);
src += size;
Tcl_ListObjAppendElement(NULL, valuePtr,
elementPtr);
}
offset += count*size;
}
Tcl_IncrRefCount(valuePtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(valuePtr);
arg++;
if (resultPtr == NULL) {
DeleteScanNumberCache(numberCachePtr);
return TCL_ERROR;
}
break;
}
case 'x': {
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count == BINARY_ALL)
|| (count > (length - offset))) {
offset = length;
} else {
offset += count;
}
break;
}
case 'X': {
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count == BINARY_ALL) || (count > offset)) {
offset = 0;
} else {
offset -= count;
}
break;
}
case '@': {
if (count == BINARY_NOCOUNT) {
DeleteScanNumberCache(numberCachePtr);
goto badCount;
}
if ((count == BINARY_ALL) || (count > length)) {
offset = length;
} else {
offset = count;
}
break;
}
default: {
DeleteScanNumberCache(numberCachePtr);
errorString = str;
goto badField;
}
}
}
/*
* Set the result to the last position of the cursor.
*/
done:
Tcl_ResetResult(interp);
Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
DeleteScanNumberCache(numberCachePtr);
break;
}
}
return TCL_OK;
badValue:
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString,
" string but got \"", errorValue, "\" instead", NULL);
return TCL_ERROR;
badCount:
errorString = "missing count for \"@\" field specifier";
goto error;
badIndex:
errorString = "not enough arguments for all format specifiers";
goto error;
badField:
{
Tcl_UniChar ch;
char buf[TCL_UTF_MAX + 1];
Tcl_UtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
return TCL_ERROR;
}
error:
Tcl_AppendResult(interp, errorString, NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* GetFormatSpec --
*
* This function parses the format strings used in the binary
* format and scan commands.
*
* Results:
* Moves the formatPtr to the start of the next command. Returns
* the current command character and count in cmdPtr and countPtr.
* The count is set to BINARY_ALL if the count character was '*'
* or BINARY_NOCOUNT if no count was specified. Returns 1 on
* success, or 0 if the string did not have a format specifier.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
GetFormatSpec(formatPtr, cmdPtr, countPtr)
char **formatPtr; /* Pointer to format string. */
char *cmdPtr; /* Pointer to location of command char. */
int *countPtr; /* Pointer to repeat count value. */
{
/*
* Skip any leading blanks.
*/
while (**formatPtr == ' ') {
(*formatPtr)++;
}
/*
* The string was empty, except for whitespace, so fail.
*/
if (!(**formatPtr)) {
return 0;
}
/*
* Extract the command character and any trailing digits or '*'.
*/
*cmdPtr = **formatPtr;
(*formatPtr)++;
if (**formatPtr == '*') {
(*formatPtr)++;
(*countPtr) = BINARY_ALL;
} else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
(*countPtr) = strtoul(*formatPtr, formatPtr, 10);
} else {
(*countPtr) = BINARY_NOCOUNT;
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* FormatNumber --
*
* This routine is called by Tcl_BinaryObjCmd to format a number
* into a location pointed at by cursor.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Moves the cursor to the next location to be written into.
*
*----------------------------------------------------------------------
*/
static int
FormatNumber(interp, type, src, cursorPtr)
Tcl_Interp *interp; /* Current interpreter, used to report
* errors. */
int type; /* Type of number to format. */
Tcl_Obj *src; /* Number to format. */
unsigned char **cursorPtr; /* Pointer to index into destination buffer. */
{
long value;
double dvalue;
Tcl_WideInt wvalue;
switch (type) {
case 'd':
case 'f':
/*
* For floating point types, we need to copy the data using
* memcpy to avoid alignment issues.
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
return TCL_ERROR;
}
if (type == 'd') {
/*
* Can't just memcpy() here. [Bug 1116542]
*/
CopyNumber(&dvalue, *cursorPtr, sizeof(double));
*cursorPtr += sizeof(double);
} else {
float fvalue;
/*
* Because some compilers will generate floating point exceptions
* on an overflow cast (e.g. Borland), we restrict the values
* to the valid range for float.
*/
if (fabs(dvalue) > (double)FLT_MAX) {
fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
} else {
fvalue = (float) dvalue;
}
memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float));
*cursorPtr += sizeof(float);
}
return TCL_OK;
/*
* Next cases separate from other integer cases because we
* need a different API to get a wide.
*/
case 'w':
case 'W':
if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (type == 'w') {
*(*cursorPtr)++ = (unsigned char) wvalue;
*(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
} else {
*(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
*(*cursorPtr)++ = (unsigned char) wvalue;
}
return TCL_OK;
default:
if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
return TCL_ERROR;
}
if (type == 'c') {
*(*cursorPtr)++ = (unsigned char) value;
} else if (type == 's') {
*(*cursorPtr)++ = (unsigned char) value;
*(*cursorPtr)++ = (unsigned char) (value >> 8);
} else if (type == 'S') {
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) value;
} else if (type == 'i') {
*(*cursorPtr)++ = (unsigned char) value;
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) (value >> 16);
*(*cursorPtr)++ = (unsigned char) (value >> 24);
} else if (type == 'I') {
*(*cursorPtr)++ = (unsigned char) (value >> 24);
*(*cursorPtr)++ = (unsigned char) (value >> 16);
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) value;
}
return TCL_OK;
}
}
/* Ugly workaround for old and broken compiler! */
static void
CopyNumber(from, to, length)
CONST VOID *from;
VOID *to;
unsigned int length;
{
memcpy(to, from, length);
}
/*
*----------------------------------------------------------------------
*
* ScanNumber --
*
* This routine is called by Tcl_BinaryObjCmd to scan a number
* out of a buffer.
*
* Results:
* Returns a newly created object containing the scanned number.
* This object has a ref count of zero.
*
* Side effects:
* Might reuse an object in the number cache, place a new object
* in the cache, or delete the cache and set the reference to
* it (itself passed in by reference) to NULL.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
ScanNumber(buffer, type, numberCachePtrPtr)
unsigned char *buffer; /* Buffer to scan number from. */
int type; /* Format character from "binary scan" */
Tcl_HashTable **numberCachePtrPtr;
/* Place to look for cache of scanned
* value objects, or NULL if too many
* different numbers have been scanned. */
{
long value;
Tcl_WideUInt uwvalue;
/*
* We cannot rely on the compiler to properly sign extend integer values
* when we cast from smaller values to larger values because we don't know
* the exact size of the integer types. So, we have to handle sign
* extension explicitly by checking the high bit and padding with 1's as
* needed.
*/
switch (type) {
case 'c':
/*
* Characters need special handling. We want to produce a
* signed result, but on some platforms (such as AIX) chars
* are unsigned. To deal with this, check for a value that
* should be negative but isn't.
*/
value = buffer[0];
if (value & 0x80) {
value |= -0x100;
}
goto returnNumericObject;
case 's':
value = (long) (buffer[0] + (buffer[1] << 8));
goto shortValue;
case 'S':
value = (long) (buffer[1] + (buffer[0] << 8));
shortValue:
if (value & 0x8000) {
value |= -0x10000;
}
goto returnNumericObject;
case 'i':
value = (long) (buffer[0]
+ (buffer[1] << 8)
+ (buffer[2] << 16)
+ (buffer[3] << 24));
goto intValue;
case 'I':
value = (long) (buffer[3]
+ (buffer[2] << 8)
+ (buffer[1] << 16)
+ (buffer[0] << 24));
intValue:
/*
* Check to see if the value was sign extended properly on
* systems where an int is more than 32-bits.
*/
if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
value -= (((unsigned int)1)<<31);
value -= (((unsigned int)1)<<31);
}
returnNumericObject:
if (*numberCachePtrPtr == NULL) {
return Tcl_NewLongObj(value);
} else {
register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
register Tcl_HashEntry *hPtr;
int isNew;
hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
if (!isNew) {
return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
}
if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) {
/*
* We've overflowed the cache! Someone's parsing
* a LOT of varied binary data in a single call!
* Bail out by switching back to the old behaviour
* for the rest of the scan.
*
* Note that anyone just using the 'c' conversion
* (for bytes) cannot trigger this.
*/
DeleteScanNumberCache(tablePtr);
*numberCachePtrPtr = NULL;
return Tcl_NewLongObj(value);
} else {
register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
Tcl_IncrRefCount(objPtr);
Tcl_SetHashValue(hPtr, (ClientData) objPtr);
return objPtr;
}
}
/*
* Do not cache wide values; they are already too large to
* use as keys.
*/
case 'w':
uwvalue = ((Tcl_WideUInt) buffer[0])
| (((Tcl_WideUInt) buffer[1]) << 8)
| (((Tcl_WideUInt) buffer[2]) << 16)
| (((Tcl_WideUInt) buffer[3]) << 24)
| (((Tcl_WideUInt) buffer[4]) << 32)
| (((Tcl_WideUInt) buffer[5]) << 40)
| (((Tcl_WideUInt) buffer[6]) << 48)
| (((Tcl_WideUInt) buffer[7]) << 56);
return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
case 'W':
uwvalue = ((Tcl_WideUInt) buffer[7])
| (((Tcl_WideUInt) buffer[6]) << 8)
| (((Tcl_WideUInt) buffer[5]) << 16)
| (((Tcl_WideUInt) buffer[4]) << 24)
| (((Tcl_WideUInt) buffer[3]) << 32)
| (((Tcl_WideUInt) buffer[2]) << 40)
| (((Tcl_WideUInt) buffer[1]) << 48)
| (((Tcl_WideUInt) buffer[0]) << 56);
return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
/*
* Do not cache double values; they are already too large
* to use as keys and the values stored are utterly
* incompatible too.
*/
case 'f': {
float fvalue;
memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
return Tcl_NewDoubleObj(fvalue);
}
case 'd': {
double dvalue;
memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double));
return Tcl_NewDoubleObj(dvalue);
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* DeleteScanNumberCache --
*
* Deletes the hash table acting as a scan number cache.
*
* Results:
* None
*
* Side effects:
* Decrements the reference counts of the objects in the cache.
*
*----------------------------------------------------------------------
*/
static void
DeleteScanNumberCache(numberCachePtr)
Tcl_HashTable *numberCachePtr; /* Pointer to the hash table, or
* NULL (when the cache has already
* been deleted due to overflow.) */
{
Tcl_HashEntry *hEntry;
Tcl_HashSearch search;
if (numberCachePtr == NULL) {
return;
}
hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
while (hEntry != NULL) {
register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry);
if (value != NULL) {
Tcl_DecrRefCount(value);
}
hEntry = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(numberCachePtr);
}
tcl8.4.20/doc/ 0000755 0036047 0045461 00000000000 12153151142 011445 5 ustar dgp 771div tcl8.4.20/doc/UpVar.3 0000644 0036047 0045461 00000005377 11737050674 012621 0 ustar dgp 771div '\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_UpVar 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_UpVar, Tcl_UpVar2 \- link one variable to another
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_UpVar(\fIinterp, frameName, sourceName, destName, flags\fB)\fR
.sp
int
\fBTcl_UpVar2(\fIinterp, frameName, name1, name2, destName, flags\fB)\fR
.SH ARGUMENTS
.AS Tcl_VarTraceProc prevClientData
.AP Tcl_Interp *interp in
Interpreter containing variables; also used for error reporting.
.AP "CONST char" *frameName in
Identifies the stack frame containing source variable.
May have any of the forms accepted by
the \fBupvar\fR command, such as \fB#0\fR or \fB1\fR.
.AP "CONST char" *sourceName in
Name of source variable, in the frame given by \fIframeName\fR.
May refer to a scalar variable or to an array variable with a
parenthesized index.
.AP "CONST char" *destName in
Name of destination variable, which is to be linked to source
variable so that references to \fIdestName\fR
refer to the other variable. Must not currently exist except as
an upvar-ed variable.
.AP int flags in
Either TCL_GLOBAL_ONLY or 0; if non-zero, then \fIdestName\fR is
a global variable; otherwise it is a local to the current procedure
(or global if no procedure is active).
.AP "CONST char" *name1 in
First part of source variable's name (scalar name, or name of array
without array index).
.AP "CONST char" *name2 in
If source variable is an element of an array, gives the index of the element.
For scalar source variables, is NULL.
.BE
.SH DESCRIPTION
.PP
\fBTcl_UpVar\fR and \fBTcl_UpVar2\fR provide the same functionality
as the \fBupvar\fR command: they make a link from a source variable
to a destination variable, so that references to the destination are
passed transparently through to the source.
The name of the source variable may be specified either as a single
string such as \fBxyx\fR or \fBa(24)\fR (by calling \fBTcl_UpVar\fR)
or in two parts where the array name has been separated from the
element name (by calling \fBTcl_UpVar2\fR).
The destination variable name is specified in a single string; it
may not be an array element.
.PP
Both procedures return either TCL_OK or TCL_ERROR, and they
leave an error message in the interpreter's result if an error occurs.
.PP
As with the \fBupvar\fR command, the source variable need not exist;
if it does exist, unsetting it later does not destroy the link. The
destination variable may exist at the time of the call, but if so
it must exist as a linked variable.
.SH KEYWORDS
linked variable, upvar, variable
tcl8.4.20/doc/tclsh.1 0000644 0036047 0045461 00000013170 11737050674 012665 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH tclsh 1 "" Tcl "Tcl Applications"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
tclsh \- Simple shell containing Tcl interpreter
.SH SYNOPSIS
\fBtclsh\fR ?\fIfileName arg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
\fBTclsh\fR is a shell-like application that reads Tcl commands
from its standard input or from a file and evaluates them.
If invoked with no arguments then it runs interactively, reading
Tcl commands from standard input and printing command results and
error messages to standard output.
It runs until the \fBexit\fR command is invoked or until it
reaches end-of-file on its standard input.
If there exists a file \fB.tclshrc\fR (or \fBtclshrc.tcl\fR on
the Windows platforms) in the home directory of
the user, \fBtclsh\fR evaluates the file as a Tcl script
just before reading the first command from standard input.
.SH "SCRIPT FILES"
.PP
If \fBtclsh\fR is invoked with arguments then the first argument
is the name of a script file and any additional arguments
are made available to the script as variables (see below).
Instead of reading commands from standard input \fBtclsh\fR will
read Tcl commands from the named file; \fBtclsh\fR will exit
when it reaches the end of the file.
.VS 8.4
The end of the file may be marked either by the physical end of
the medium, or by the character, '\\032' ('\\u001a', control-Z).
If this character is present in the file, the \fBtclsh\fR application
will read text up to but not including the character. An application
that requires this character in the file may safely encode it as
``\\032'', ``\\x1a'', or ``\\u001a''; or may generate it by use of commands
such as \fBformat\fR or \fBbinary\fR.
.VE
There is no automatic evaluation of \fB.tclshrc\fR when the name
of a script file is presented on the \fBtclsh\fR command
line, but the script file can always \fBsource\fR it if desired.
.PP
If you create a Tcl script in a file whose first line is
.CS
\fB#!/usr/local/bin/tclsh\fR
.CE
then you can invoke the script file directly from your shell if
you mark the file as executable.
This assumes that \fBtclsh\fR has been installed in the default
location in /usr/local/bin; if it's installed somewhere else
then you'll have to modify the above line to match.
Many UNIX systems do not allow the \fB#!\fR line to exceed about
30 characters in length, so be sure that the \fBtclsh\fR
executable can be accessed with a short file name.
.PP
An even better approach is to start your script files with the
following three lines:
.CS
\fB#!/bin/sh
# the next line restarts using tclsh \e
exec tclsh "$0" ${1+"$@"}\fR
.CE
This approach has three advantages over the approach in the previous
paragraph. First, the location of the \fBtclsh\fR binary doesn't have
to be hard-wired into the script: it can be anywhere in your shell
search path. Second, it gets around the 30-character file name limit
in the previous approach.
Third, this approach will work even if \fBtclsh\fR is
itself a shell script (this is done on some systems in order to
handle multiple architectures or operating systems: the \fBtclsh\fR
script selects one of several binaries to run). The three lines
cause both \fBsh\fR and \fBtclsh\fR to process the script, but the
\fBexec\fR is only executed by \fBsh\fR.
\fBsh\fR processes the script first; it treats the second
line as a comment and executes the third line.
The \fBexec\fR statement cause the shell to stop processing and
instead to start up \fBtclsh\fR to reprocess the entire script.
When \fBtclsh\fR starts up, it treats all three lines as comments,
since the backslash at the end of the second line causes the third
line to be treated as part of the comment on the second line.
.PP
.VS
You should note that it is also common practise to install tclsh with
its version number as part of the name. This has the advantage of
allowing multiple versions of Tcl to exist on the same system at once,
but also the disadvantage of making it harder to write scripts that
start up uniformly across different versions of Tcl.
.VE
.SH "VARIABLES"
.PP
\fBTclsh\fR sets the following Tcl variables:
.TP 15
\fBargc\fR
Contains a count of the number of \fIarg\fR arguments (0 if none),
not including the name of the script file.
.TP 15
\fBargv\fR
Contains a Tcl list whose elements are the \fIarg\fR arguments,
in order, or an empty string if there are no \fIarg\fR arguments.
.TP 15
\fBargv0\fR
Contains \fIfileName\fR if it was specified.
Otherwise, contains the name by which \fBtclsh\fR was invoked.
.TP 15
\fBtcl_interactive\fR
Contains 1 if \fBtclsh\fR is running interactively (no
\fIfileName\fR was specified and standard input is a terminal-like
device), 0 otherwise.
.SH PROMPTS
.PP
When \fBtclsh\fR is invoked interactively it normally prompts for each
command with ``\fB% \fR''. You can change the prompt by setting the
variables \fBtcl_prompt1\fR and \fBtcl_prompt2\fR. If variable
\fBtcl_prompt1\fR exists then it must consist of a Tcl script
to output a prompt; instead of outputting a prompt \fBtclsh\fR
will evaluate the script in \fBtcl_prompt1\fR.
The variable \fBtcl_prompt2\fR is used in a similar way when
a newline is typed but the current command isn't yet complete;
if \fBtcl_prompt2\fR isn't set then no prompt is output for
incomplete commands.
.SH "STANDARD CHANNELS"
.PP
See \fBTcl_StandardChannels\fR for more explanations.
.SH "SEE ALSO"
fconfigure(n), tclvars(n)
.SH KEYWORDS
argument, interpreter, prompt, script file, shell
tcl8.4.20/doc/global.n 0000644 0036047 0045461 00000003250 11737050674 013103 0 ustar dgp 771div '\"
'\" Copyright (c) 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.
'\"
.so man.macros
.TH global n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
global \- Access global variables
.SH SYNOPSIS
\fBglobal \fIvarname \fR?\fIvarname ...\fR?
.BE
.SH DESCRIPTION
.PP
This command has no effect unless executed in the context of a proc body.
If the \fBglobal\fR command is executed in the context of a proc body, it
creates local variables linked to the corresponding global variables (though
these linked variables, like those created by \fBupvar\fR, are not included
in the list returned by \fBinfo locals\fR).
.PP
If \fIvarname\fR contains namespace qualifiers, the local variable's name is
the unqualified name of the global variable, as determined by the
\fBnamespace tail\fR command.
.SH EXAMPLES
This procedure sets the namespace variable \fI::a::x\fR
.CS
proc reset {} {
\fBglobal\fR a::x
set x 0
}
.CE
.PP
This procedure accumulates the strings passed to it in a global
buffer, separated by newlines. It is useful for situations when you
want to build a message piece-by-piece (as if with \fBputs\fR) but
send that full message in a single piece (e.g. over a connection
opened with \fBsocket\fR or as part of a counted HTTP response).
.CS
proc accum {string} {
\fBglobal\fR accumulator
append accumulator $string \\n
}
.CE
.SH "SEE ALSO"
namespace(n), upvar(n), variable(n)
.SH KEYWORDS
global, namespace, procedure, variable
tcl8.4.20/doc/tcltest.n 0000644 0036047 0045461 00000127604 11737050674 013337 0 ustar dgp 771div '\"
'\" Copyright (c) 1990-1994 The Regents of the University of California
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\" Copyright (c) 2000 Ajuba Solutions
'\" Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH "tcltest" n 2.2 tcltest "Tcl Bundled Packages"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
tcltest \- Test harness support code and utilities
.SH SYNOPSIS
.nf
\fBpackage require tcltest ?2.2.5?\fR
.sp
\fBtcltest::test \fIname description ?option value ...?\fR
\fBtcltest::test \fIname description ?constraints? body result\fR
.sp
\fBtcltest::loadTestedCommands\fR
\fBtcltest::makeDirectory \fIname ?directory?\fR
\fBtcltest::removeDirectory \fIname ?directory?\fR
\fBtcltest::makeFile \fIcontents name ?directory?\fR
\fBtcltest::removeFile \fIname ?directory?\fR
\fBtcltest::viewFile \fIname ?directory?\fR
\fBtcltest::cleanupTests \fI?runningMultipleTests?\fR
\fBtcltest::runAllTests\fR
.sp
\fBtcltest::configure\fR
\fBtcltest::configure \fIoption\fR
\fBtcltest::configure \fIoption value ?option value ...?\fR
\fBtcltest::customMatch \fImode command\fR
\fBtcltest::testConstraint \fIconstraint ?value?\fR
\fBtcltest::outputChannel \fI?channelID?\fR
\fBtcltest::errorChannel \fI?channelID?\fR
\fBtcltest::interpreter \fI?interp?\fR
.sp
\fBtcltest::debug \fI?level?\fR
\fBtcltest::errorFile \fI?filename?\fR
\fBtcltest::limitConstraints \fI?boolean?\fR
\fBtcltest::loadFile \fI?filename?\fR
\fBtcltest::loadScript \fI?script?\fR
\fBtcltest::match \fI?patternList?\fR
\fBtcltest::matchDirectories \fI?patternList?\fR
\fBtcltest::matchFiles \fI?patternList?\fR
\fBtcltest::outputFile \fI?filename?\fR
\fBtcltest::preserveCore \fI?level?\fR
\fBtcltest::singleProcess \fI?boolean?\fR
\fBtcltest::skip \fI?patternList?\fR
\fBtcltest::skipDirectories \fI?patternList?\fR
\fBtcltest::skipFiles \fI?patternList?\fR
\fBtcltest::temporaryDirectory \fI?directory?\fR
\fBtcltest::testsDirectory \fI?directory?\fR
\fBtcltest::verbose \fI?level?\fR
.sp
\fBtcltest::test \fIname description optionList\fR
\fBtcltest::bytestring \fIstring\fR
\fBtcltest::normalizeMsg \fImsg\fR
\fBtcltest::normalizePath \fIpathVar\fR
\fBtcltest::workingDirectory \fI?dir?\fR
.fi
.BE
.SH DESCRIPTION
.PP
The \fBtcltest\fR package provides several utility commands useful
in the construction of test suites for code instrumented to be
run by evaluation of Tcl commands. Notably the built-in commands
of the Tcl library itself are tested by a test suite using the
tcltest package.
.PP
All the commands provided by the \fBtcltest\fR package are defined
in and exported from the \fB::tcltest\fR namespace, as indicated in
the \fBSYNOPSIS\fR above. In the following sections, all commands
will be described by their simple names, in the interest of brevity.
.PP
The central command of \fBtcltest\fR is [\fBtest\fR] that defines
and runs a test. Testing with [\fBtest\fR] involves evaluation
of a Tcl script and comparing the result to an expected result, as
configured and controlled by a number of options. Several other
commands provided by \fBtcltest\fR govern the configuration of
[\fBtest\fR] and the collection of many [\fBtest\fR] commands into
test suites.
.PP
See \fBCREATING TEST SUITES WITH TCLTEST\fR below for an extended example
of how to use the commands of \fBtcltest\fR to produce test suites
for your Tcl-enabled code.
.SH COMMANDS
.TP
\fBtest\fR \fIname description ?option value ...?\fR
Defines and possibly runs a test with the name \fIname\fR and
description \fIdescription\fR. The name and description of a test
are used in messages reported by [\fBtest\fR] during the
test, as configured by the options of \fBtcltest\fR. The
remaining \fIoption value\fR arguments to [\fBtest\fR]
define the test, including the scripts to run, the conditions
under which to run them, the expected result, and the means
by which the expected and actual results should be compared.
See \fBTESTS\fR below for a complete description of the valid
options and how they define a test. The [\fBtest\fR] command
returns an empty string.
.TP
\fBtest\fR \fIname description ?constraints? body result\fR
This form of [\fBtest\fR] is provided to support test suites written
for version 1 of the \fBtcltest\fR package, and also a simpler
interface for a common usage. It is the same as
[\fBtest\fR \fIname description\fB -constraints \fIconstraints\fB -body
\fIbody\fB -result \fIresult\fR]. All other options to [\fBtest\fR]
take their default values. When \fIconstraints\fR is omitted, this
form of [\fBtest\fR] can be distinguished from the first because
all \fIoption\fRs begin with ``-''.
.TP
\fBloadTestedCommands\fR
Evaluates in the caller's context the script specified by
[\fBconfigure -load\fR] or [\fBconfigure -loadfile\fR].
Returns the result of that script evaluation, including any error
raised by the script. Use this command and the related
configuration options to provide the commands to be tested to
the interpreter running the test suite.
.TP
\fBmakeFile\fR \fIcontents name ?directory?\fR
Creates a file named \fIname\fR relative to
directory \fIdirectory\fR and write \fIcontents\fR
to that file using the encoding [\fBencoding system\fR].
If \fIcontents\fR does not end with a newline, a newline
will be appended so that the file named \fIname\fR
does end with a newline. Because the system encoding is used,
this command is only suitable for making text files.
The file will be removed by the next evaluation
of [\fBcleanupTests\fR], unless it is removed by
[\fBremoveFile\fR] first. The default value of
\fIdirectory\fR is the directory [\fBconfigure -tmpdir\fR].
Returns the full path of the file created. Use this command
to create any text file required by a test with contents as needed.
.TP
\fBremoveFile\fR \fIname ?directory?\fR
Forces the file referenced by \fIname\fR to be removed. This file name
should be relative to \fIdirectory\fR. The default value of
\fIdirectory\fR is the directory [\fBconfigure -tmpdir\fR].
Returns an empty string. Use this command to delete files
created by [\fBmakeFile\fR].
.TP
\fBmakeDirectory\fR \fIname ?directory?\fR
Creates a directory named \fIname\fR relative to directory \fIdirectory\fR.
The directory will be removed by the next evaluation of [\fBcleanupTests\fR],
unless it is removed by [\fBremoveDirectory\fR] first.
The default value of \fIdirectory\fR is the directory
[\fBconfigure -tmpdir\fR].
Returns the full path of the directory created. Use this command
to create any directories that are required to exist by a test.
.TP
\fBremoveDirectory\fR \fIname ?directory?\fR
Forces the directory referenced by \fIname\fR to be removed. This
directory should be relative to \fIdirectory\fR.
The default value of \fIdirectory\fR is the directory
[\fBconfigure -tmpdir\fR].
Returns an empty string. Use this command to delete any directories
created by [\fBmakeDirectory\fR].
.TP
\fBviewFile\fR \fIfile ?directory?\fR
Returns the contents of \fIfile\fR, except for any
final newline, just as [\fBread -nonewline\fR] would return.
This file name should be relative to \fIdirectory\fR.
The default value of \fIdirectory\fR is the directory
[\fBconfigure -tmpdir\fR]. Use this command
as a convenient way to turn the contents of a file generated
by a test into the result of that test for matching against
an expected result. The contents of the file are read using
the system encoding, so its usefulness is limited to text
files.
.TP
\fBcleanupTests\fR
Intended to clean up and summarize after several tests have been
run. Typically called once per test file, at the end of the file
after all tests have been completed. For best effectiveness, be
sure that the [\fBcleanupTests\fR] is evaluated even if an error
occurs earlier in the test file evaluation.
.sp
Prints statistics about the tests run and removes files that were
created by [\fBmakeDirectory\fR] and [\fBmakeFile\fR] since the
last [\fBcleanupTests\fR]. Names of files and directories
in the directory [\fBconfigure -tmpdir\fR] created since
the last [\fBcleanupTests\fR], but not created by
[\fBmakeFile\fR] or [\fBmakeDirectory\fR] are printed
to [\fBoutputChannel\fR]. This command also restores the original
shell environment, as described by the ::env
array. Returns an empty string.
.TP
\fBrunAllTests\fR
This is a master command meant to run an entire suite of tests,
spanning multiple files and/or directories, as governed by
the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR
below for a complete description of the many variations possible
with [\fBrunAllTests\fR].
.SH "CONFIGURATION COMMANDS"
.TP
\fBconfigure\fR
Returns the list of configurable options supported by \fBtcltest\fR.
See \fBCONFIGURABLE OPTIONS\fR below for the full list of options,
their valid values, and their effect on \fBtcltest\fR operations.
.TP
\fBconfigure \fIoption\fR
Returns the current value of the supported configurable option \fIoption\fR.
Raises an error if \fIoption\fR is not a supported configurable option.
.TP
\fBconfigure \fIoption value ?option value ...?\fR
Sets the value of each configurable option \fIoption\fR to the
corresponding value \fIvalue\fR, in order. Raises an error if
an \fIoption\fR is not a supported configurable option, or if
\fIvalue\fR is not a valid value for the corresponding \fIoption\fR,
or if a \fIvalue\fR is not provided. When an error is raised, the
operation of [\fBconfigure\fR] is halted, and subsequent \fIoption value\fR
arguments are not processed.
.sp
If the environment variable \fB::env(TCLTEST_OPTIONS)\fR exists when
the \fBtcltest\fR package is loaded (by [\fBpackage require tcltest\fR])
then its value is taken as a list of arguments to pass to [\fBconfigure\fR].
This allows the default values of the configuration options to be
set by the environment.
.TP
\fBcustomMatch \fImode script\fR
Registers \fImode\fR as a new legal value of the \fB-match\fR option
to [\fBtest\fR]. When the \fB-match \fImode\fR option is
passed to [\fBtest\fR], the script \fIscript\fR will be evaluated
to compare the actual result of evaluating the body of the test
to the expected result.
To perform the match, the \fIscript\fR is completed with two additional
words, the expected result, and the actual result, and the completed script
is evaluated in the global namespace.
The completed script is expected to return a boolean value indicating
whether or not the results match. The built-in matching modes of
[\fBtest\fR] are \fBexact\fR, \fBglob\fR, and \fBregexp\fR.
.TP
\fBtestConstraint \fIconstraint ?boolean?\fR
Sets or returns the boolean value associated with the named \fIconstraint\fR.
See \fBTEST CONSTRAINTS\fR below for more information.
.TP
\fBinterpreter\fR \fI?executableName?\fR
Sets or returns the name of the executable to be [\fBexec\fR]ed by
[\fBrunAllTests\fR] to run each test file when
[\fBconfigure -singleproc\fR] is false.
The default value for [\fBinterpreter\fR] is the name of the
currently running program as returned by [\fBinfo nameofexecutable\fR].
.TP
\fBoutputChannel\fR \fI?channelID?\fR
Sets or returns the output channel ID. This defaults to stdout.
Any test that prints test related output should send
that output to [\fBoutputChannel\fR] rather than letting
that output default to stdout.
.TP
\fBerrorChannel\fR \fI?channelID?\fR
Sets or returns the error channel ID. This defaults to stderr.
Any test that prints error messages should send
that output to [\fBerrorChannel\fR] rather than printing
directly to stderr.
.SH "SHORTCUT COMMANDS"
.TP
\fBdebug \fI?level?\fR
Same as [\fBconfigure -debug \fI?level?\fR].
.TP
\fBerrorFile \fI?filename?\fR
Same as [\fBconfigure -errfile \fI?filename?\fR].
.TP
\fBlimitConstraints \fI?boolean?\fR
Same as [\fBconfigure -limitconstraints \fI?boolean?\fR].
.TP
\fBloadFile \fI?filename?\fR
Same as [\fBconfigure -loadfile \fI?filename?\fR].
.TP
\fBloadScript \fI?script?\fR
Same as [\fBconfigure -load \fI?script?\fR].
.TP
\fBmatch \fI?patternList?\fR
Same as [\fBconfigure -match \fI?patternList?\fR].
.TP
\fBmatchDirectories \fI?patternList?\fR
Same as [\fBconfigure -relateddir \fI?patternList?\fR].
.TP
\fBmatchFiles \fI?patternList?\fR
Same as [\fBconfigure -file \fI?patternList?\fR].
.TP
\fBoutputFile \fI?filename?\fR
Same as [\fBconfigure -outfile \fI?filename?\fR].
.TP
\fBpreserveCore \fI?level?\fR
Same as [\fBconfigure -preservecore \fI?level?\fR].
.TP
\fBsingleProcess \fI?boolean?\fR
Same as [\fBconfigure -singleproc \fI?boolean?\fR].
.TP
\fBskip \fI?patternList?\fR
Same as [\fBconfigure -skip \fI?patternList?\fR].
.TP
\fBskipDirectories \fI?patternList?\fR
Same as [\fBconfigure -asidefromdir \fI?patternList?\fR].
.TP
\fBskipFiles \fI?patternList?\fR
Same as [\fBconfigure -notfile \fI?patternList?\fR].
.TP
\fBtemporaryDirectory \fI?directory?\fR
Same as [\fBconfigure -tmpdir \fI?directory?\fR].
.TP
\fBtestsDirectory \fI?directory?\fR
Same as [\fBconfigure -testdir \fI?directory?\fR].
.TP
\fBverbose \fI?level?\fR
Same as [\fBconfigure -verbose \fI?level?\fR].
.SH "OTHER COMMANDS"
.PP
The remaining commands provided by \fBtcltest\fR have better
alternatives provided by \fBtcltest\fR or \fBTcl\fR itself. They
are retained to support existing test suites, but should be avoided
in new code.
.TP
\fBtest\fR \fIname description optionList\fR
This form of [\fBtest\fR] was provided to enable passing many
options spanning several lines to [\fBtest\fR] as a single
argument quoted by braces, rather than needing to backslash quote
the newlines between arguments to [\fBtest\fR]. The \fIoptionList\fR
argument is expected to be a list with an even number of elements
representing \fIoption\fR and \fIvalue\fR arguments to pass
to [\fBtest\fR]. However, these values are not passed directly, as
in the alternate forms of [\fBswitch\fR]. Instead, this form makes
an unfortunate attempt to overthrow Tcl's substitution rules by
performing substitutions on some of the list elements as an attempt to
implement a ``do what I mean'' interpretation of a brace-enclosed
``block''. The result is nearly impossible to document clearly, and
for that reason this form is not recommended. See the examples in
\fBCREATING TEST SUITES WITH TCLTEST\fR below to see that this
form is really not necessary to avoid backslash-quoted newlines.
If you insist on using this form, examine
the source code of \fBtcltest\fR if you want to know the substitution
details, or just enclose the third through last argument
to [\fBtest\fR] in braces and hope for the best.
.TP
\fBworkingDirectory\fR \fI?directoryName?\fR
Sets or returns the current working directory when the test suite is
running. The default value for workingDirectory is the directory in
which the test suite was launched. The Tcl commands [\fBcd\fR] and
[\fBpwd\fR] are sufficient replacements.
.TP
\fBnormalizeMsg\fR \fImsg\fR
Returns the result of removing the ``extra'' newlines from \fImsg\fR,
where ``extra'' is rather imprecise. Tcl offers plenty of string
processing commands to modify strings as you wish, and
[\fBcustomMatch\fR] allows flexible matching of actual and expected
results.
.TP
\fBnormalizePath\fR \fIpathVar\fR
Resolves symlinks in a path, thus creating a path without internal
redirection. It is assumed that \fIpathVar\fR is absolute.
\fIpathVar\fR is modified in place. The Tcl command [\fBfile normalize\fR]
is a sufficient replacement.
.TP
\fBbytestring\fR \fIstring\fR
Construct a string that consists of the requested sequence of bytes,
as opposed to a string of properly formed UTF-8 characters using the
value supplied in \fIstring\fR. This allows the tester to create
denormalized or improperly formed strings to pass to C procedures that
are supposed to accept strings with embedded NULL types and confirm
that a string result has a certain pattern of bytes. This is
exactly equivalent to the Tcl command [\fBencoding convertfrom identity\fR].
.SH TESTS
.PP
The [\fBtest\fR] command is the heart of the \fBtcltest\fR package.
Its essential function is to evaluate a Tcl script and compare
the result with an expected result. The options of [\fBtest\fR]
define the test script, the environment in which to evaluate it,
the expected result, and how the compare the actual result to
the expected result. Some configuration options of \fBtcltest\fR
also influence how [\fBtest\fR] operates.
.PP
The valid options for [\fBtest\fR] are summarized:
.CS
.ta 0.8i
\fBtest\fR \fIname\fR \fIdescription\fR
?-constraints \fIkeywordList|expression\fR?
?-setup \fIsetupScript\fR?
?-body \fItestScript\fR?
?-cleanup \fIcleanupScript\fR?
?-result \fIexpectedAnswer\fR?
?-output \fIexpectedOutput\fR?
?-errorOutput \fIexpectedError\fR?
?-returnCodes \fIcodeList\fR?
?-match \fImode\fR?
.CE
The \fIname\fR may be any string. It is conventional to choose
a \fIname\fR according to the pattern:
.CS
\fItarget\fR-\fImajorNum\fR.\fIminorNum\fR
.CE
For white-box (regression) tests, the target should be the name of the
C function or Tcl procedure being tested. For black-box tests, the
target should be the name of the feature being tested. Some conventions
call for the names of black-box tests to have the suffix \fB_bb\fR.
Related tests should share a major number. As a test suite evolves,
it is best to have the same test name continue to correspond to the
same test, so that it remains meaningful to say things like ``Test
foo-1.3 passed in all releases up to 3.4, but began failing in
release 3.5.''
.PP
During evaluation of [\fBtest\fR], the \fIname\fR will be compared
to the lists of string matching patterns returned by
[\fBconfigure -match\fR], and [\fBconfigure -skip\fR]. The test
will be run only if \fIname\fR matches any of the patterns from
[\fBconfigure -match\fR] and matches none of the patterns
from [\fBconfigure -skip\fR].
.PP
The \fIdescription\fR should be a short textual description of the
test. The \fIdescription\fR is included in output produced by the
test, typically test failure messages. Good \fIdescription\fR values
should briefly explain the purpose of the test to users of a test suite.
The name of a Tcl or C function being tested should be included in the
description for regression tests. If the test case exists to reproduce
a bug, include the bug ID in the description.
.PP
Valid attributes and associated values are:
.TP
\fB-constraints \fIkeywordList|expression\fR
The optional \fB-constraints\fR attribute can be list of one or more
keywords or an expression. If the \fB-constraints\fR value is a list of
keywords, each of these keywords should be the name of a constraint
defined by a call to [\fBtestConstraint\fR]. If any of the listed
constraints is false or does not exist, the test is skipped. If the
\fB-constraints\fR value is an expression, that expression
is evaluated. If the expression evaluates to true, then the test is run.
Note that the expression form of \fB-constraints\fR may interfere with the
operation of [\fBconfigure -constraints\fR] and
[\fBconfigure -limitconstraints\fR], and is not recommended.
Appropriate constraints should be added to any tests that should
not always be run. That is, conditional evaluation of a test
should be accomplished by the \fB-constraints\fR option, not by
conditional evaluation of [\fBtest\fR]. In that way, the same
number of tests are always reported by the test suite, though
the number skipped may change based on the testing environment.
The default value is an empty list.
See \fBTEST CONSTRAINTS\fR below for a list of built-in constraints
and information on how to add your own constraints.
.TP
\fB-setup \fIscript\fR
The optional \fB-setup\fR attribute indicates a \fIscript\fR that will be run
before the script indicated by the \fB-body\fR attribute. If evaluation
of \fIscript\fR raises an error, the test will fail. The default value
is an empty script.
.TP
\fB-body \fIscript\fR
The \fB-body\fR attribute indicates the \fIscript\fR to run to carry out the
test. It must return a result that can be checked for correctness.
If evaluation of \fIscript\fR raises an error, the test will fail.
The default value is an empty script.
.TP
\fB-cleanup \fIscript\fR
The optional \fB-cleanup\fR attribute indicates a \fIscript\fR that will be
run after the script indicated by the \fB-body\fR attribute.
If evaluation of \fIscript\fR raises an error, the test will fail.
The default value is an empty script.
.TP
\fB-match \fImode\fR
The \fB-match\fR attribute determines how expected answers supplied by
\fB-result\fR, \fB-output\fR, and \fB-errorOutput\fR are compared. Valid
values for \fImode\fR are \fBregexp\fR, \fBglob\fR, \fBexact\fR, and
any value registered by a prior call to [\fBcustomMatch\fR]. The default
value is \fBexact\fR.
.TP
\fB-result \fIexpectedValue\fR
The \fB-result\fR attribute supplies the \fIexpectedValue\fR against which
the return value from script will be compared. The default value is
an empty string.
.TP
\fB-output \fIexpectedValue\fR
The \fB-output\fR attribute supplies the \fIexpectedValue\fR against which
any output sent to \fBstdout\fR or [\fBoutputChannel\fR] during evaluation
of the script(s) will be compared. Note that only output printed using
[\fB::puts\fR] is used for comparison. If \fB-output\fR is not specified,
output sent to \fBstdout\fR and [\fBoutputChannel\fR] is not processed for
comparison.
.TP
\fB-errorOutput \fIexpectedValue\fR
The \fB-errorOutput\fR attribute supplies the \fIexpectedValue\fR against
which any output sent to \fBstderr\fR or [\fBerrorChannel\fR] during
evaluation of the script(s) will be compared. Note that only output
printed using [\fB::puts\fR] is used for comparison. If \fB-errorOutput\fR
is not specified, output sent to \fBstderr\fR and [\fBerrorChannel\fR] is
not processed for comparison.
.TP
\fB-returnCodes \fIexpectedCodeList\fR
The optional \fB-returnCodes\fR attribute supplies \fIexpectedCodeList\fR,
a list of return codes that may be accepted from evaluation of the
\fB-body\fR script. If evaluation of the \fB-body\fR script returns
a code not in the \fIexpectedCodeList\fR, the test fails. All
return codes known to [\fBreturn\fR], in both numeric and symbolic
form, including extended return codes, are acceptable elements in
the \fIexpectedCodeList\fR. Default value is \fB{ok return}\fR.
.PP
To pass, a test must successfully evaluate its \fB-setup\fR, \fB-body\fR,
and \fB-cleanup\fR scripts. The return code of the \fB-body\fR script and
its result must match expected values, and if specified, output and error
data from the test must match expected \fB-output\fR and \fB-errorOutput\fR
values. If any of these conditions are not met, then the test fails.
Note that all scripts are evaluated in the context of the caller
of [\fBtest\fR].
.PP
As long as [\fBtest\fR] is called with valid syntax and legal
values for all attributes, it will not raise an error. Test
failures are instead reported as output written to [\fBoutputChannel\fR].
In default operation, a successful test produces no output. The output
messages produced by [\fBtest\fR] are controlled by the
[\fBconfigure -verbose\fR] option as described in \fBCONFIGURABLE OPTIONS\fR
below. Any output produced by the test scripts themselves should be
produced using [\fB::puts\fR] to [\fBoutputChannel\fR] or
[\fBerrorChannel\fR], so that users of the test suite may
easily capture output with the [\fBconfigure -outfile\fR] and
[\fBconfigure -errfile\fR] options, and so that the \fB-output\fR
and \fB-errorOutput\fR attributes work properly.
.SH "TEST CONSTRAINTS"
.PP
Constraints are used to determine whether or not a test should be skipped.
Each constraint has a name, which may be any string, and a boolean
value. Each [\fBtest\fR] has a \fB-constraints\fR value which is a
list of constraint names. There are two modes of constraint control.
Most frequently, the default mode is used, indicated by a setting
of [\fBconfigure -limitconstraints\fR] to false. The test will run
only if all constraints in the list are true-valued. Thus,
the \fB-constraints\fR option of [\fBtest\fR] is a convenient, symbolic
way to define any conditions required for the test to be possible or
meaningful. For example, a [\fBtest\fR] with \fB-constraints unix\fR
will only be run if the constraint \fBunix\fR is true, which indicates
the test suite is being run on a Unix platform.
.PP
Each [\fBtest\fR] should include whatever \fB-constraints\fR are
required to constrain it to run only where appropriate. Several
constraints are pre-defined in the \fBtcltest\fR package, listed
below. The registration of user-defined constraints is performed
by the [\fBtestConstraint\fR] command. User-defined constraints
may appear within a test file, or within the script specified
by the [\fBconfigure -load\fR] or [\fBconfigure -loadfile\fR]
options.
.PP
The following is a list of constraints pre-defined by the
\fBtcltest\fR package itself:
.TP
\fIsingleTestInterp\fR
test can only be run if all test files are sourced into a single interpreter
.TP
\fIunix\fR
test can only be run on any Unix platform
.TP
\fIwin\fR
test can only be run on any Windows platform
.TP
\fInt\fR
test can only be run on any Windows NT platform
.TP
\fI95\fR
test can only be run on any Windows 95 platform
.TP
\fI98\fR
test can only be run on any Windows 98 platform
.TP
\fImac\fR
test can only be run on any Mac platform
.TP
\fIunixOrWin\fR
test can only be run on a Unix or Windows platform
.TP
\fImacOrWin\fR
test can only be run on a Mac or Windows platform
.TP
\fImacOrUnix\fR
test can only be run on a Mac or Unix platform
.TP
\fItempNotWin\fR
test can not be run on Windows. This flag is used to temporarily
disable a test.
.TP
\fItempNotMac\fR
test can not be run on a Mac. This flag is used
to temporarily disable a test.
.TP
\fIunixCrash\fR
test crashes if it's run on Unix. This flag is used to temporarily
disable a test.
.TP
\fIwinCrash\fR
test crashes if it's run on Windows. This flag is used to temporarily
disable a test.
.TP
\fImacCrash\fR
test crashes if it's run on a Mac. This flag is used to temporarily
disable a test.
.TP
\fIemptyTest\fR
test is empty, and so not worth running, but it remains as a
place-holder for a test to be written in the future. This constraint
has value false to cause tests to be skipped unless the user specifies
otherwise.
.TP
\fIknownBug\fR
test is known to fail and the bug is not yet fixed. This constraint
has value false to cause tests to be skipped unless the user specifies
otherwise.
.TP
\fInonPortable\fR
test can only be run in some known development environment.
Some tests are inherently non-portable because they depend on things
like word length, file system configuration, window manager, etc.
This constraint has value false to cause tests to be skipped unless
the user specifies otherwise.
.TP
\fIuserInteraction\fR
test requires interaction from the user. This constraint has
value false to causes tests to be skipped unless the user specifies
otherwise.
.TP
\fIinteractive\fR
test can only be run in if the interpreter is in interactive mode
(when the global tcl_interactive variable is set to 1).
.TP
\fInonBlockFiles\fR
test can only be run if platform supports setting files into
nonblocking mode
.TP
\fIasyncPipeClose\fR
test can only be run if platform supports async flush and async close
on a pipe
.TP
\fIunixExecs\fR
test can only be run if this machine has Unix-style commands
\fBcat\fR, \fBecho\fR, \fBsh\fR, \fBwc\fR, \fBrm\fR, \fBsleep\fR,
\fBfgrep\fR, \fBps\fR, \fBchmod\fR, and \fBmkdir\fR available
.TP
\fIhasIsoLocale\fR
test can only be run if can switch to an ISO locale
.TP
\fIroot\fR
test can only run if Unix user is root
.TP
\fInotRoot\fR
test can only run if Unix user is not root
.TP
\fIeformat\fR
test can only run if app has a working version of sprintf with respect
to the "e" format of floating-point numbers.
.TP
\fIstdio\fR
test can only be run if [\fBinterpreter\fR] can be [\fBopen\fR]ed
as a pipe.
.PP
The alternative mode of constraint control is enabled by setting
[\fBconfigure -limitconstraints\fR] to true. With that configuration
setting, all existing constraints other than those in the constraint
list returned by [\fBconfigure -constraints\fR] are set to false.
When the value of [\fBconfigure -constraints\fR]
is set, all those constraints are set to true. The effect is that
when both options [\fBconfigure -constraints\fR] and
[\fBconfigure -limitconstraints\fR] are in use, only those tests including
only constraints from the [\fBconfigure -constraints\fR] list
are run; all others are skipped. For example, one might set
up a configuration with
.CS
\fBconfigure\fR -constraints knownBug \e
-limitconstraints true \e
-verbose pass
.CE
to run exactly those tests that exercise known bugs, and discover
whether any of them pass, indicating the bug had been fixed.
.SH "RUNNING ALL TESTS"
.PP
The single command [\fBrunAllTests\fR] is evaluated to run an entire
test suite, spanning many files and directories. The configuration
options of \fBtcltest\fR control the precise operations. The
[\fBrunAllTests\fR] command begins by printing a summary of its
configuration to [\fBoutputChannel\fR].
.PP
Test files to be evaluated are sought in the directory
[\fBconfigure -testdir\fR]. The list of files in that directory
that match any of the patterns in [\fBconfigure -file\fR] and
match none of the patterns in [\fBconfigure -notfile\fR] is generated
and sorted. Then each file will be evaluated in turn. If
[\fBconfigure -singleproc\fR] is true, then each file will
be [\fBsource\fR]d in the caller's context. If it is false,
then a copy of [\fBinterpreter\fR] will be [\fBexec\fR]d to
evaluate each file. The multi-process operation is useful
when testing can cause errors so severe that a process
terminates. Although such an error may terminate a child
process evaluating one file, the master process can continue
with the rest of the test suite. In multi-process operation,
the configuration of \fBtcltest\fR in the master process is
passed to the child processes as command line arguments,
with the exception of [\fBconfigure -outfile\fR]. The
[\fBrunAllTests\fR] command in the
master process collects all output from the child processes
and collates their results into one master report. Any
reports of individual test failures, or messages requested
by a [\fBconfigure -verbose\fR] setting are passed directly
on to [\fBoutputChannel\fR] by the master process.
.PP
After evaluating all selected test files, a summary of the
results is printed to [\fBoutputChannel\fR]. The summary
includes the total number of [\fBtest\fR]s evaluated, broken
down into those skipped, those passed, and those failed.
The summary also notes the number of files evaluated, and the names
of any files with failing tests or errors. A list of
the constraints that caused tests to be skipped, and the
number of tests skipped for each is also printed. Also,
messages are printed if it appears that evaluation of
a test file has caused any temporary files to be left
behind in [\fBconfigure -tmpdir\fR].
.PP
Having completed and summarized all selected test files,
[\fBrunAllTests\fR] then recursively acts on subdirectories
of [\fBconfigure -testdir\fR]. All subdirectories that
match any of the patterns in [\fBconfigure -relateddir\fR]
and do not match any of the patterns in
[\fBconfigure -asidefromdir\fR] are examined. If
a file named \fBall.tcl\fR is found in such a directory,
it will be [\fBsource\fR]d in the caller's context.
Whether or not an examined directory contains an
\fBall.tcl\fR file, its subdirectories are also scanned
against the [\fBconfigure -relateddir\fR] and
[\fBconfigure -asidefromdir\fR] patterns. In this way,
many directories in a directory tree can have all their
test files evaluated by a single [\fBrunAllTests\fR]
command.
.SH "CONFIGURABLE OPTIONS"
The [\fBconfigure\fR] command is used to set and query the configurable
options of \fBtcltest\fR. The valid options are:
.TP
\fB-singleproc \fIboolean\fR
Controls whether or not [\fBrunAllTests\fR] spawns a child process for
each test file. No spawning when \fIboolean\fR is true. Default
value is false.
.TP
\fB-debug \fIlevel\fR
Sets the debug level to \fIlevel\fR, an integer value indicating how
much debugging information should be printed to stdout. Note that
debug messages always go to stdout, independent of the value of
[\fBconfigure -outfile\fR]. Default value is 0. Levels are defined as:
.RS
.IP 0
Do not display any debug information.
.IP 1
Display information regarding whether a test is skipped because it
doesn't match any of the tests that were specified using by
[\fBconfigure -match\fR] (userSpecifiedNonMatch) or matches any of
the tests specified by [\fBconfigure -skip\fR] (userSpecifiedSkip). Also
print warnings about possible lack of cleanup or balance in test files.
Also print warnings about any re-use of test names.
.IP 2
Display the flag array parsed by the command line processor, the
contents of the ::env array, and all user-defined variables that exist
in the current namespace as they are used.
.IP 3
Display information regarding what individual procs in the test
harness are doing.
.RE
.TP
\fB-verbose \fIlevel\fR
Sets the type of output verbosity desired to \fIlevel\fR,
a list of zero or more of the elements \fBbody\fR, \fBpass\fR,
\fBskip\fR, \fBstart\fR, and \fBerror\fR. Default value
is \fB{body error}\fR.
Levels are defined as:
.RS
.IP "body (b)"
Display the body of failed tests
.IP "pass (p)"
Print output when a test passes
.IP "skip (s)"
Print output when a test is skipped
.IP "start (t)"
Print output whenever a test starts
.IP "error (e)"
Print errorInfo and errorCode, if they exist, when a test return code
does not match its expected return code
.RE
The single letter abbreviations noted above are also recognized
so that [\fBconfigure -verbose pt\fR] is the same as
[\fBconfigure -verbose {pass start}\fR].
.TP
\fB-preservecore \fIlevel\fR
Sets the core preservation level to \fIlevel\fR. This level
determines how stringent checks for core files are. Default
value is 0. Levels are defined as:
.RS
.IP 0
No checking - do not check for core files at the end of each test
command, but do check for them in [\fBrunAllTests\fR] after all
test files have been evaluated.
.IP 1
Also check for core files at the end of each [\fBtest\fR] command.
.IP 2
Check for core files at all times described above, and save a
copy of each core file produced in [\fBconfigure -tmpdir\fR].
.RE
.TP
\fB-limitconstraints \fIboolean\fR
Sets the mode by which [\fBtest\fR] honors constraints as described
in \fBTESTS\fR above. Default value is false.
.TP
\fB-constraints \fIlist\fR
Sets all the constraints in \fIlist\fR to true. Also used in
combination with [\fBconfigure -limitconstraints true\fR] to control an
alternative constraint mode as described in \fBTESTS\fR above.
Default value is an empty list.
.TP
\fB-tmpdir \fIdirectory\fR
Sets the temporary directory to be used by [\fBmakeFile\fR],
[\fBmakeDirectory\fR], [\fBviewFile\fR], [\fBremoveFile\fR],
and [\fBremoveDirectory\fR] as the default directory where
temporary files and directories created by test files should
be created. Default value is [\fBworkingDirectory\fR].
.TP
\fB-testdir \fIdirectory\fR
Sets the directory searched by [\fBrunAllTests\fR] for test files
and subdirectories. Default value is [\fBworkingDirectory\fR].
.TP
\fB-file \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what test files to evaluate. Default value is \fB*.test\fR.
.TP
\fB-notfile \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what test files to skip. Default value is \fBl.*.test\fR, so
that any SCCS lock files are skipped.
.TP
\fB-relateddir \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what subdirectories to search for an \fBall.tcl\fR file. Default
value is \fB*\fR.
.TP
\fB-asidefromdir \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what subdirectories to skip when searching for an \fBall.tcl\fR file.
Default value is an empty list.
.TP
\fB-match \fIpatternList\fR
Set the list of patterns used by [\fBtest\fR] to determine whether
a test should be run. Default value is \fB*\fR.
.TP
\fB-skip \fIpatternList\fR
Set the list of patterns used by [\fBtest\fR] to determine whether
a test should be skipped. Default value is an empty list.
.TP
\fB-load \fIscript\fR
Sets a script to be evaluated by [\fBloadTestedCommands\fR].
Default value is an empty script.
.TP
\fB-loadfile \fIfilename\fR
Sets the filename from which to read a script to be evaluated
by [\fBloadTestedCommands\fR]. This is an alternative to
\fB-load\fR. They cannot be used together.
.TP
\fB-outfile \fIfilename\fR
Sets the file to which all output produced by tcltest should be
written. A file named \fIfilename\fR will be [\fBopen\fR]ed for writing,
and the resulting channel will be set as the value of [\fBoutputChannel\fR].
.TP
\fB-errfile \fIfilename\fR
Sets the file to which all error output produced by tcltest
should be written. A file named \fIfilename\fR will be [\fBopen\fR]ed
for writing, and the resulting channel will be set as the value
of [\fBerrorChannel\fR].
.SH "CREATING TEST SUITES WITH TCLTEST"
.PP
The fundamental element of a test suite is the individual [\fBtest\fR]
command. We begin with several examples.
.IP [1]
Test of a script that returns normally.
.CS
\fBtest\fR example-1.0 {normal return} {
format %s value
} value
.CE
.IP [2]
Test of a script that requires context setup and cleanup. Note the
bracing and indenting style that avoids any need for line continuation.
.CS
\fBtest\fR example-1.1 {test file existence} -setup {
set file [makeFile {} test]
} -body {
file exists $file
} -cleanup {
removeFile test
} -result 1
.CE
.IP [3]
Test of a script that raises an error.
.CS
\fBtest\fR example-1.2 {error return} -body {
error message
} -returnCodes error -result message
.CE
.IP [4]
Test with a constraint.
.CS
\fBtest\fR example-1.3 {user owns created files} -constraints {
unix
} -setup {
set file [makeFile {} test]
} -body {
file attributes $file -owner
} -cleanup {
removeFile test
} -result $::tcl_platform(user)
.CE
.PP
At the next higher layer of organization, several [\fBtest\fR] commands
are gathered together into a single test file. Test files should have
names with the \fB.test\fR extension, because that is the default pattern
used by [\fBrunAllTests\fR] to find test files. It is a good rule of
thumb to have one test file for each source code file of your project.
It is good practice to edit the test file and the source code file
together, keeping tests synchronized with code changes.
.PP
Most of the code in the test file should be the [\fBtest\fR] commands.
Use constraints to skip tests, rather than conditional evaluation
of [\fBtest\fR]. That is, do this:
.IP [5]
.CS
\fBtestConstraint\fR X [expr $myRequirement]
\fBtest\fR goodConditionalTest {} X {
# body
} result
.CE
and do not do this:
.IP [6]
.CS
if $myRequirement {
test badConditionalTest {} {
#body
} result
}
.CE
.PP
Use the \fB-setup\fR and \fB-cleanup\fR options to establish and release
all context requirements of the test body. Do not make tests depend on
prior tests in the file. Those prior tests might be skipped. If several
consecutive tests require the same context, the appropriate setup
and cleanup scripts may be stored in variable for passing to each tests
\fB-setup\fR and \fB-cleanup\fR options. This is a better solution than
performing setup outside of [\fBtest\fR] commands, because the setup will
only be done if necessary, and any errors during setup will be reported,
and not cause the test file to abort.
.PP
A test file should be able to be combined with other test files and not
interfere with them, even when [\fBconfigure -singleproc 1\fR] causes
all files to be evaluated in a common interpreter. A simple way to
achieve this is to have your tests define all their commands and variables
in a namespace that is deleted when the test file evaluation is complete.
A good namespace to use is a child namespace \fBtest\fR of the namespace
of the module you are testing.
.PP
A test file should also be able to be evaluated directly as a script,
not depending on being called by a master [\fBrunAllTests\fR]. This
means that each test file should process command line arguments to give
the tester all the configuration control that \fBtcltest\fR provides.
.PP
After all [\fBtest\fR]s in a test file, the command [\fBcleanupTests\fR]
should be called.
.IP [7]
Here is a sketch of a sample test file illustrating those points:
.CS
package require tcltest 2.2
eval \fB::tcltest::configure\fR $argv
package require example
namespace eval ::example::test {
namespace import ::tcltest::*
\fBtestConstraint\fR X [expr {...}]
variable SETUP {#common setup code}
variable CLEANUP {#common cleanup code}
\fBtest\fR example-1 {} -setup $SETUP -body {
# First test
} -cleanup $CLEANUP -result {...}
\fBtest\fR example-2 {} -constraints X -setup $SETUP -body {
# Second test; constrained
} -cleanup $CLEANUP -result {...}
\fBtest\fR example-3 {} {
# Third test; no context required
} {...}
\fBcleanupTests\fR
}
namespace delete ::example::test
.CE
.PP
The next level of organization is a full test suite, made up of several
test files. One script is used to control the entire suite. The
basic function of this script is to call [\fBrunAllTests\fR] after
doing any necessary setup. This script is usually named \fBall.tcl\fR
because that's the default name used by [\fBrunAllTests\fR] when combining
multiple test suites into one testing run.
.IP [8]
Here is a sketch of a sample test suite master script:
.CS
package require Tcl 8.4
package require tcltest 2.2
package require example
\fB::tcltest::configure\fR -testdir \
[file dirname [file normalize [info script]]]
eval \fB::tcltest::configure\fR $argv
\fB::tcltest::runAllTests\fR
.CE
.SH COMPATIBILITY
.PP
A number of commands and variables in the \fB::tcltest\fR namespace
provided by earlier releases of \fBtcltest\fR have not been documented
here. They are no longer part of the supported public interface of
\fBtcltest\fR and should not be used in new test suites. However,
to continue to support existing test suites written to the older
interface specifications, many of those deprecated commands and
variables still work as before. For example, in many circumstances,
[\fBconfigure\fR] will be automatically called shortly after
[\fBpackage require tcltest 2.1\fR] succeeds with arguments
from the variable \fB::argv\fR. This is to support test suites
that depend on the old behavior that \fBtcltest\fR was automatically
configured from command line arguments. New test files should not
depend on this, but should explicitly include
.CS
eval \fB::tcltest::configure\fR $::argv
.CE
to establish a configuration from command line arguments.
.SH "KNOWN ISSUES"
There are two known issues related to nested evaluations of [\fBtest\fR].
The first issue relates to the stack level in which test scripts are
executed. Tests nested within other tests may be executed at the same
stack level as the outermost test. For example, in the following code:
.CS
\fBtest\fR level-1.1 {level 1} {
-body {
\fBtest\fR level-2.1 {level 2} {
}
}
}
.CE
any script executed in level-2.1 may be executed at the same stack
level as the script defined for level-1.1.
.PP
In addition, while two [\fBtest\fR]s have been run, results will only
be reported by [\fBcleanupTests\fR] for tests at the same level as
test level-1.1. However, test results for all tests run prior to
level-1.1 will be available when test level-2.1 runs. What this
means is that if you try to access the test results for test level-2.1,
it will may say that 'm' tests have run, 'n' tests have
been skipped, 'o' tests have passed and 'p' tests have failed,
where 'm', 'n', 'o', and 'p' refer to tests that were run at the
same test level as test level-1.1.
.PP
Implementation of output and error comparison in the test command
depends on usage of ::puts in your application code. Output is
intercepted by redefining the ::puts command while the defined test
script is being run. Errors thrown by C procedures or printed
directly from C applications will not be caught by the test command.
Therefore, usage of the \fB-output\fR and \fB-errorOutput\fR
options to [\fBtest\fR] is useful only for pure Tcl applications
that use [\fB::puts\fR] to produce output.
.SH KEYWORDS
test, test harness, test suite
tcl8.4.20/doc/foreach.n 0000644 0036047 0045461 00000005430 11737050674 013254 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH foreach n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
foreach \- Iterate over all elements in one or more lists
.SH SYNOPSIS
\fBforeach \fIvarname list body\fR
.br
\fBforeach \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR
.BE
.SH DESCRIPTION
.PP
The \fBforeach\fR command implements a loop where the loop
variable(s) take on values from one or more lists.
In the simplest case there is one loop variable, \fIvarname\fR,
and one list, \fIlist\fR, that is a list of values to assign to \fIvarname\fR.
The \fIbody\fR argument is a Tcl script.
For each element of \fIlist\fR (in order
from first to last), \fBforeach\fR assigns the contents of the
element to \fIvarname\fR as if the \fBlindex\fR command had been used
to extract the element, then calls the Tcl interpreter to execute
\fIbody\fR.
.PP
In the general case there can be more than one value list
(e.g., \fIlist1\fR and \fIlist2\fR),
and each value list can be associated with a list of loop variables
(e.g., \fIvarlist1\fR and \fIvarlist2\fR).
During each iteration of the loop
the variables of each \fIvarlist\fP are assigned
consecutive values from the corresponding \fIlist\fP.
Values in each \fIlist\fP are used in order from first to last,
and each value is used exactly once.
The total number of loop iterations is large enough to use
up all the values from all the value lists.
If a value list does not contain enough
elements for each of its loop variables in each iteration,
empty values are used for the missing elements.
.PP
The \fBbreak\fR and \fBcontinue\fR statements may be
invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR
command. \fBForeach\fR returns an empty string.
.SH EXAMPLES
.PP
The following loop uses i and j as loop variables to iterate over
pairs of elements of a single list.
.DS
set x {}
\fBforeach\fR {i j} {a b c d e f} {
lappend x $j $i
}
# The value of x is "b a d c f e"
# There are 3 iterations of the loop.
.DE
.PP
The next loop uses i and j to iterate over two lists in parallel.
.DS
set x {}
\fBforeach\fR i {a b c} j {d e f g} {
lappend x $i $j
}
# The value of x is "a d b e c f {} g"
# There are 4 iterations of the loop.
.DE
.PP
The two forms are combined in the following example.
.DS
set x {}
\fBforeach\fR i {a b c} {j k} {d e f g} {
lappend x $i $j $k
}
# The value of x is "a d e b f g c {} {}"
# There are 3 iterations of the loop.
.DE
.SH "SEE ALSO"
for(n), while(n), break(n), continue(n)
.SH KEYWORDS
foreach, iteration, list, looping
tcl8.4.20/doc/GetTime.3 0000644 0036047 0045461 00000003255 11737050674 013113 0 ustar dgp 771div '\"
'\" Copyright (c) 2001 by Kevin B. Kenny.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_GetTime 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetTime \- get date and time
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_GetTime\fR(\fI timePtr \fR)
.SH ARGUMENTS
.AS "Tcl_Time *" timePtr
.AP "Tcl_Time *" timePtr out
Points to memory in which to store the date and time information.
.BE
.SH DESCRIPTION
.PP
The \fBTcl_GetTime\fR function retrieves the current time as a
\fITcl_Time\fR structure in memory the caller provides. This
structure has the following definition:
.CS
typedef struct Tcl_Time {
long sec;
long usec;
} Tcl_Time;
.CE
.PP
On return, the \fIsec\fR member of the structure is filled in with the
number of seconds that have elapsed since the \fIepoch:\fR the epoch
is the point in time of 00:00 UTC, 1 January 1970. This number does
\fInot\fR count leap seconds \- an interval of one day advances it by
86400 seconds regardless of whether a leap second has been inserted.
.PP
The \fIusec\fR member of the structure is filled in with the number of
microseconds that have elapsed since the start of the second
designated by \fIsec\fR. The Tcl library makes every effort to keep
this number as precise as possible, subject to the limitations of the
computer system. On multiprocessor variants of Windows, this number
may be limited to the 10- or 20-ms granularity of the system clock.
(On single-processor Windows systems, the \fIusec\fR field is derived
from a performance counter and is highly precise.)
.SH "SEE ALSO"
clock
.SH KEYWORDS
date, time
tcl8.4.20/doc/CrtMathFnc.3 0000644 0036047 0045461 00000013736 11737050674 013553 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
void
\fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR)
.sp
.VS 8.4
int
\fBTcl_GetMathFuncInfo\fR(\fIinterp, name, numArgsPtr, argTypesPtr, procPtr, clientDataPtr\fR)
.sp
Tcl_Obj *
\fBTcl_ListMathFuncs\fR(\fIinterp, pattern\fR)
.VE
.SH ARGUMENTS
.AS Tcl_ValueType *clientDataPtr
.AP Tcl_Interp *interp in
Interpreter in which new function will be defined.
.VS 8.4
.AP "CONST char" *name in
.VE
Name for new function.
.AP int numArgs in
Number of arguments to new function; also gives size of \fIargTypes\fR array.
.AP Tcl_ValueType *argTypes in
Points to an array giving the permissible types for each argument to
function.
.AP Tcl_MathProc *proc in
Procedure that implements the function.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR when it is invoked.
.AP int *numArgsPtr out
Points to a variable that will be set to contain the number of
arguments to the function.
.AP Tcl_ValueType **argTypesPtr out
Points to a variable that will be set to contain a pointer to an array
giving the permissible types for each argument to the function which
will need to be freed up using \fITcl_Free\fR.
.AP Tcl_MathProc **procPtr out
Points to a variable that will be set to contain a pointer to the
implementation code for the function (or NULL if the function is
implemented directly in bytecode.)
.AP ClientData *clientDataPtr out
Points to a variable that will be set to contain the clientData
argument passed to \fITcl_CreateMathFunc\fR when the function was
created if the function is not implemented directly in bytecode.
.AP "CONST char" *pattern in
Pattern to match against function names so as to filter them (by
passing to \fITcl_StringMatch\fR), or NULL to not apply any filter.
.BE
.SH DESCRIPTION
.PP
Tcl allows a number of mathematical functions to be used in
expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR.
\fBTcl_CreateMathFunc\fR allows applications to add additional functions
to those already provided by Tcl or to replace existing functions.
\fIName\fR is the name of the function as it will appear in expressions.
If \fIname\fR doesn't already exist as a function then a new function
is created. If it does exist, then the existing function is replaced.
\fINumArgs\fR and \fIargTypes\fR describe the arguments to the function.
Each entry in the \fIargTypes\fR array must be
.VS 8.4
one of TCL_INT, TCL_DOUBLE, TCL_WIDE_INT,
or TCL_EITHER to indicate whether the corresponding argument must be an
integer, a double-precision floating value, a wide (64-bit) integer,
or any, respectively.
.VE 8.4
.PP
Whenever the function is invoked in an expression Tcl will invoke
\fIproc\fR. \fIProc\fR should have arguments and result that match
the type \fBTcl_MathProc\fR:
.CS
typedef int Tcl_MathProc(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
Tcl_Value *\fIargs\fR,
Tcl_Value *\fIresultPtr\fR);
.CE
.PP
When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR
arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR.
\fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures,
which describe the actual arguments to the function:
.VS 8.4
.CS
typedef struct Tcl_Value {
Tcl_ValueType \fItype\fR;
long \fIintValue\fR;
double \fIdoubleValue\fR;
Tcl_WideInt \fIwideValue\fR;
} Tcl_Value;
.CE
.PP
The \fItype\fR field indicates the type of the argument and is
one of TCL_INT, TCL_DOUBLE or TCL_WIDE_INT.
.VE 8.4
It will match the \fIargTypes\fR value specified for the function unless
the \fIargTypes\fR value was TCL_EITHER. Tcl converts
the argument supplied in the expression to the type requested in
\fIargTypes\fR, if that is necessary.
Depending on the value of the \fItype\fR field, the \fIintValue\fR,
.VS 8.4
\fIdoubleValue\fR or \fIwideValue\fR
.VE 8.4
field will contain the actual value of the argument.
.PP
\fIProc\fR should compute its result and store it either as an integer
in \fIresultPtr->intValue\fR or as a floating value in
\fIresultPtr->doubleValue\fR.
It should set also \fIresultPtr->type\fR to one of
.VS 8.4
TCL_INT, TCL_DOUBLE or TCL_WIDE_INT
.VE 8.4
to indicate which value was set.
Under normal circumstances \fIproc\fR should return TCL_OK.
If an error occurs while executing the function, \fIproc\fR should
return TCL_ERROR and leave an error message in the interpreter's result.
.PP
.VS 8.4
\fBTcl_GetMathFuncInfo\fR retrieves the values associated with
function \fIname\fR that were passed to a preceding
\fBTcl_CreateMathFunc\fR call. Normally, the return code is
\fBTCL_OK\fR but if the named function does not exist, \fBTCL_ERROR\fR
is returned and an error message is placed in the interpreter's
result.
.PP
If an error did not occur, the array reference placed in the variable
pointed to by \fIargTypesPtr\fR is newly allocated, and should be
released by passing it to \fBTcl_Free\fR. Some functions (the
standard set implemented in the core) are implemented directly at the
bytecode level; attempting to retrieve values for them causes a NULL
to be stored in the variable pointed to by \fIprocPtr\fR and the
variable pointed to by \fIclientDataPtr\fR will not be modified.
.PP
\fBTcl_ListMathFuncs\fR returns a Tcl object containing a list of all
the math functions defined in the interpreter whose name matches
\fIpattern\fR. In the case of an error, NULL is returned and an error
message is left in the interpreter result, and otherwise the returned
object will have a reference count of zero.
.VE
.SH KEYWORDS
expression, mathematical function
.SH "SEE ALSO"
expr(n), info(n), Tcl_Free(3), Tcl_NewListObj(3)
tcl8.4.20/doc/set.n 0000644 0036047 0045461 00000004655 11737050674 012450 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH set n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
set \- Read and write variables
.SH SYNOPSIS
\fBset \fIvarName \fR?\fIvalue\fR?
.BE
.SH DESCRIPTION
.PP
Returns the value of variable \fIvarName\fR.
If \fIvalue\fR is specified, then set
the value of \fIvarName\fR to \fIvalue\fR, creating a new variable
if one doesn't already exist, and return its value.
If \fIvarName\fR contains an open parenthesis and ends with a
close parenthesis, then it refers to an array element: the characters
before the first open parenthesis are the name of the array,
and the characters between the parentheses are the index within the array.
Otherwise \fIvarName\fR refers to a scalar variable.
.PP
If \fIvarName\fR includes namespace qualifiers
(in the array name if it refers to an array element), or if \fIvarName\fR
is unqualified (does not include the names of any containing namespaces)
but no procedure is active,
\fIvarName\fR refers to a namespace variable
resolved according to the rules described under \fBNAME RESOLUTION\fR in
the \fBnamespace\fR manual page.
.PP
If a procedure is active and \fIvarName\fR is unqualified, then
\fIvarName\fR refers to a parameter or local variable of the procedure,
unless \fIvarName\fR was declared to resolve differently through one of the
\fBglobal\fR, \fBvariable\fR or \fBupvar\fR commands.
.SH EXAMPLES
Store a random number in the variable \fIr\fR:
.CS
\fBset\fR r [expr rand()]
.CE
.PP
Store a short message in an array element:
.CS
\fBset\fR anAry(msg) "Hello, World!"
.CE
.PP
Store a short message in an array element specified by a variable:
.CS
\fBset\fR elemName "msg"
\fBset\fR anAry($elemName) "Hello, World!"
.CE
.PP
Copy a value into the variable \fIout\fR from a variable whose name is
stored in the \fIvbl\fR (note that it is often easier to use arrays in
practice instead of doing double-dereferencing):
.CS
\fBset\fR in0 "small random"
\fBset\fR in1 "large random"
\fBset\fR vbl in[expr {rand() >= 0.5}]
\fBset\fR out [\fBset\fR $vbl]
.CE
.SH "SEE ALSO"
expr(n), global(n), namespace(n), proc(n), trace(n), unset(n), upvar(n), variable(n)
.SH KEYWORDS
read, write, variable
tcl8.4.20/doc/append.n 0000644 0036047 0045461 00000002355 11737050674 013117 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH append n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
append \- Append to variable
.SH SYNOPSIS
\fBappend \fIvarName \fR?\fIvalue value value ...\fR?
.BE
.SH DESCRIPTION
.PP
Append all of the \fIvalue\fR arguments to the current value
of variable \fIvarName\fR. If \fIvarName\fR doesn't exist,
it is given a value equal to the concatenation of all the
\fIvalue\fR arguments.
The result of this command is the new value stored in variable
\fIvarName\fR.
This command provides an efficient way to build up long
variables incrementally.
For example, ``\fBappend a $b\fR'' is much more efficient than
``\fBset a $a$b\fR'' if \fB$a\fR is long.
.SH EXAMPLE
Building a string of comma-separated numbers piecemeal using a loop.
.CS
set var 0
for {set i 1} {$i<=10} {incr i} {
\fBappend\fR var "," $i
}
puts $var
# Prints 0,1,2,3,4,5,6,7,8,9,10
.CE
.SH "SEE ALSO"
concat(n), lappend(n)
.SH KEYWORDS
append, variable
tcl8.4.20/doc/SaveResult.3 0000644 0036047 0045461 00000004464 11737050674 013655 0 ustar dgp 771div '\"
'\" Copyright (c) 1997 by Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's result
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_SaveResult(\fIinterp, statePtr\fB)\fR
.sp
\fBTcl_RestoreResult(\fIinterp, statePtr\fB)\fR
.sp
\fBTcl_DiscardResult(\fIstatePtr\fB)\fR
.SH ARGUMENTS
.AS Tcl_SavedResult statePtr
.AP Tcl_Interp *interp in
Interpreter for which state should be saved.
.AP Tcl_SavedResult *statePtr in
Pointer to location where interpreter result should be saved or restored.
.BE
.SH DESCRIPTION
.PP
These routines allows a C procedure to take a snapshot of the current
interpreter result so that it can be restored after a call
to \fBTcl_Eval\fR or some other routine that modifies the interpreter
result. These routines are passed a pointer to a structure that is
used to store enough information to restore the interpreter result
state. This structure can be allocated on the stack of the calling
procedure. These routines do not save the state of any error
information in the interpreter (e.g. the \fBerrorCode\fR or
\fBerrorInfo\fR variables).
.PP
\fBTcl_SaveResult\fR moves the string and object results
of \fIinterp\fR into the location specified by \fIstatePtr\fR.
\fBTcl_SaveResult\fR clears the result for \fIinterp\fR and
leaves the result in its normal empty initialized state.
.PP
\fBTcl_RestoreResult\fR moves the string and object results from
\fIstatePtr\fR back into \fIinterp\fR. Any result or error that was
already in the interpreter will be cleared. The \fIstatePtr\fR is left
in an uninitialized state and cannot be used until another call to
\fBTcl_SaveResult\fR.
.PP
\fBTcl_DiscardResult\fR releases the saved interpreter state
stored at \fBstatePtr\fR. The state structure is left in an
uninitialized state and cannot be used until another call to
\fBTcl_SaveResult\fR.
.PP
Once \fBTcl_SaveResult\fR is called to save the interpreter
result, either \fBTcl_RestoreResult\fR or
\fBTcl_DiscardResult\fR must be called to properly clean up the
memory associated with the saved state.
.SH KEYWORDS
result, state, interp
tcl8.4.20/doc/break.n 0000644 0036047 0045461 00000002372 11737050674 012733 0 ustar dgp 771div '\"
'\" Copyright (c) 1993-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH break n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
break \- Abort looping command
.SH SYNOPSIS
\fBbreak\fR
.BE
.SH DESCRIPTION
.PP
This command is typically invoked inside the body of a looping command
such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR.
It returns a \fBTCL_BREAK\fR code, which causes a break exception
to occur.
The exception causes the current script to be aborted
out to the innermost containing loop command, which then
aborts its execution and returns normally.
Break exceptions are also handled in a few other situations, such
as the \fBcatch\fR command, Tk event bindings, and the outermost
scripts of procedure bodies.
.SH EXAMPLE
Print a line for each of the integers from 0 to 5:
.CS
for {set x 0} {$x<10} {incr x} {
if {$x > 5} {
\fBbreak\fR
}
puts "x is $x"
}
.CE
.SH "SEE ALSO"
catch(n), continue(n), for(n), foreach(n), return(n), while(n)
.SH KEYWORDS
abort, break, loop
tcl8.4.20/doc/SetRecLmt.3 0000644 0036047 0045461 00000003506 11737050674 013416 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_SetRecursionLimit 3 7.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_SetRecursionLimit\fR(\fIinterp, depth\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp
.AP Tcl_Interp *interp in
Interpreter whose recursion limit is to be set.
Must be greater than zero.
.AP int depth in
New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR.
.BE
.SH DESCRIPTION
.PP
At any given time Tcl enforces a limit on the number of recursive
calls that may be active for \fBTcl_Eval\fR and related procedures
such as \fBTcl_GlobalEval\fR.
Any call to \fBTcl_Eval\fR that exceeds this depth is aborted with
an error.
By default the recursion limit is 1000.
.PP
\fBTcl_SetRecursionLimit\fR may be used to change the maximum
allowable nesting depth for an interpreter.
The \fIdepth\fR argument specifies a new limit for \fIinterp\fR,
and \fBTcl_SetRecursionLimit\fR returns the old limit.
To read out the old limit without modifying it, invoke
\fBTcl_SetRecursionLimit\fR with \fIdepth\fR equal to 0.
.PP
The \fBTcl_SetRecursionLimit\fR only sets the size of the Tcl
call stack: it cannot by itself prevent stack overflows on the
C stack being used by the application. If your machine has a
limit on the size of the C stack, you may get stack overflows
before reaching the limit set by \fBTcl_SetRecursionLimit\fR.
If this happens, see if there is a mechanism in your system for
increasing the maximum size of the C stack.
.SH KEYWORDS
nesting depth, recursion
tcl8.4.20/doc/encoding.n 0000644 0036047 0045461 00000006214 11737050674 013434 0 ustar dgp 771div '\"
'\" Copyright (c) 1998 by Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH encoding n "8.1" Tcl "Tcl Built-In Commands"
.BS
.SH NAME
encoding \- Manipulate encodings
.SH SYNOPSIS
\fBencoding \fIoption\fR ?\fIarg arg ...\fR?
.BE
.SH INTRODUCTION
.PP
Strings in Tcl are encoded using 16-bit Unicode characters. Different
operating system interfaces or applications may generate strings in
other encodings such as Shift-JIS. The \fBencoding\fR command helps
to bridge the gap between Unicode and these other formats.
.SH DESCRIPTION
.PP
Performs one of several encoding related operations, depending on
\fIoption\fR. The legal \fIoption\fRs are:
.TP
\fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR
Convert \fIdata\fR to Unicode from the specified \fIencoding\fR. The
characters in \fIdata\fR are treated as binary data where the lower
8-bits of each character is taken as a single byte. The resulting
sequence of bytes is treated as a string in the specified
\fIencoding\fR. If \fIencoding\fR is not specified, the current
system encoding is used.
.TP
\fBencoding convertto\fR ?\fIencoding\fR? \fIstring\fR
Convert \fIstring\fR from Unicode to the specified \fIencoding\fR.
The result is a sequence of bytes that represents the converted
string. Each byte is stored in the lower 8-bits of a Unicode
character. If \fIencoding\fR is not specified, the current
system encoding is used.
.TP
\fBencoding names\fR
Returns a list containing the names of all of the encodings that are
currently available.
.TP
\fBencoding system\fR ?\fIencoding\fR?
Set the system encoding to \fIencoding\fR. If \fIencoding\fR is
omitted then the command returns the current system encoding. The
system encoding is used whenever Tcl passes strings to system calls.
.SH EXAMPLE
.PP
It is common practice to write script files using a text editor that
produces output in the euc-jp encoding, which represents the ASCII
characters as singe bytes and Japanese characters as two bytes. This
makes it easy to embed literal strings that correspond to non-ASCII
characters by simply typing the strings in place in the script.
However, because the \fBsource\fR command always reads files using the
current system encoding, Tcl will only source such files correctly
when the encoding used to write the file is the same. This tends not
to be true in an internationalized setting. For example, if such a
file was sourced in North America (where the ISO8859-1 is normally
used), each byte in the file would be treated as a separate character
that maps to the 00 page in Unicode. The resulting Tcl strings will
not contain the expected Japanese characters. Instead, they will
contain a sequence of Latin-1 characters that correspond to the bytes
of the original string. The \fBencoding\fR command can be used to
convert this string to the expected Japanese Unicode characters. For
example,
.CS
set s [\fBencoding convertfrom\fR euc-jp "\\xA4\\xCF"]
.CE
would return the Unicode string "\\u306F", which is the Hiragana
letter HA.
.SH "SEE ALSO"
Tcl_GetEncoding(3)
.SH KEYWORDS
encoding
tcl8.4.20/doc/CrtObjCmd.3 0000644 0036047 0045461 00000031466 11737050674 013371 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Command
\fBTcl_CreateObjCommand\fR(\fIinterp, cmdName, proc, clientData, deleteProc\fR)
.sp
int
\fBTcl_DeleteCommand\fR(\fIinterp, cmdName\fR)
.sp
int
\fBTcl_DeleteCommandFromToken\fR(\fIinterp, token\fR)
.sp
int
\fBTcl_GetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR)
.sp
int
\fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR)
.sp
.VS 8.4
int
\fBTcl_GetCommandInfoFromToken\fR(\fItoken, infoPtr\fR)
.sp
int
\fBTcl_SetCommandInfoFromToken\fR(\fItoken, infoPtr\fR)
.VE
.sp
.VS 8.4
CONST char *
.VE
\fBTcl_GetCommandName\fR(\fIinterp, token\fR)
.sp
void
\fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR)
.sp
Tcl_Command
\fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR)
.SH ARGUMENTS
.AS Tcl_ObjCmdProc *deleteProc in/out
.AP Tcl_Interp *interp in
Interpreter in which to create a new command or that contains a command.
.VS 8.4
.AP char *cmdName in
.VE
Name of command.
.AP Tcl_ObjCmdProc *proc in
Implementation of the new command: \fIproc\fR will be called whenever
\fIcmdName\fR is invoked as a command.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR.
.AP Tcl_CmdDeleteProc *deleteProc in
Procedure to call before \fIcmdName\fR is deleted from the interpreter;
allows for command-specific cleanup. If NULL, then no procedure is
called before the command is deleted.
.AP Tcl_Command token in
Token for command, returned by previous call to \fBTcl_CreateObjCommand\fR.
The command must not have been deleted.
.AP Tcl_CmdInfo *infoPtr in/out
Pointer to structure containing various information about a
Tcl command.
.AP Tcl_Obj *objPtr in
Object containing the name of a Tcl command.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CreateObjCommand\fR defines a new command in \fIinterp\fR
and associates it with procedure \fIproc\fR
such that whenever \fIname\fR is
invoked as a Tcl command (e.g., via a call to \fBTcl_EvalObjEx\fR)
the Tcl interpreter will call \fIproc\fR to process the command.
.PP
\fBTcl_CreateObjCommand\fR deletes any existing command
\fIname\fR already associated with the interpreter
(however see below for an exception where the existing command
is not deleted).
It returns a token that may be used to refer
to the command in subsequent calls to \fBTcl_GetCommandName\fR.
If \fIname\fR contains any \fB::\fR namespace qualifiers,
then the command is added to the specified namespace;
otherwise the command is added to the global namespace.
If \fBTcl_CreateObjCommand\fR is called for an interpreter that is in
the process of being deleted, then it does not create a new command
and it returns NULL.
\fIproc\fR should have arguments and result that match the type
\fBTcl_ObjCmdProc\fR:
.CS
typedef int Tcl_ObjCmdProc(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIobjc\fR,
.VS
Tcl_Obj *CONST \fIobjv\fR[]);
.CE
When \fIproc\fR is invoked, the \fIclientData\fR and \fIinterp\fR parameters
will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to
\fBTcl_CreateObjCommand\fR. Typically, \fIclientData\fR points to an
application-specific data structure that describes what to do when the
command procedure is invoked. \fIObjc\fR and \fIobjv\fR describe the
arguments to the command, \fIobjc\fR giving the number of argument objects
(including the command name) and \fIobjv\fR giving the values of the
arguments. The \fIobjv\fR array will contain \fIobjc\fR values, pointing to
the argument objects. Unlike \fIargv\fR[\fIargv\fR] used in a
string-based command procedure, \fIobjv\fR[\fIobjc\fR] will not contain NULL.
.PP
Additionally, when \fIproc\fR is invoked, it must not modify the contents
of the \fIobjv\fR array by assigning new pointer values to any element of the
array (for example, \fIobjv\fR[\fB2\fR] = \fBNULL\fR) because this will
cause memory to be lost and the runtime stack to be corrupted. The
\fBCONST\fR in the declaration of \fIobjv\fR will cause ANSI-compliant
compilers to report any such attempted assignment as an error. However,
it is acceptable to modify the internal representation of any individual
object argument. For instance, the user may call
\fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer
representation of that object; that call may change the type of the object
that \fIobjv\fR[\fB2\fR] points at, but will not change where
\fIobjv\fR[\fB2\fR] points.
.VE
.PP
\fIproc\fR must return an integer code that is either \fBTCL_OK\fR,
\fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR.
See the Tcl overview man page
for details on what these codes mean. Most normal commands will only
return \fBTCL_OK\fR or \fBTCL_ERROR\fR.
In addition, if \fIproc\fR needs to return a non-empty result,
it can call \fBTcl_SetObjResult\fR to set the interpreter's result.
In the case of a \fBTCL_OK\fR return code this gives the result
of the command,
and in the case of \fBTCL_ERROR\fR this gives an error message.
Before invoking a command procedure,
\fBTcl_EvalObjEx\fR sets interpreter's result to
point to an object representing an empty string, so simple
commands can return an empty result by doing nothing at all.
.PP
The contents of the \fIobjv\fR array belong to Tcl and are not
guaranteed to persist once \fIproc\fR returns: \fIproc\fR should
not modify them.
Call \fBTcl_SetObjResult\fR if you want
to return something from the \fIobjv\fR array.
.PP
Ordinarily, \fBTcl_CreateObjCommand\fR deletes any existing command
\fIname\fR already associated with the interpreter.
However, if the existing command was created by a previous call to
\fBTcl_CreateCommand\fR,
\fBTcl_CreateObjCommand\fR does not delete the command
but instead arranges for the Tcl interpreter to call the
\fBTcl_ObjCmdProc\fR \fIproc\fR in the future.
The old string-based \fBTcl_CmdProc\fR associated with the command
is retained and its address can be obtained by subsequent
\fBTcl_GetCommandInfo\fR calls. This is done for backwards compatibility.
.PP
\fIDeleteProc\fR will be invoked when (if) \fIname\fR is deleted.
This can occur through a call to \fBTcl_DeleteCommand\fR,
\fBTcl_DeleteCommandFromToken\fR, or \fBTcl_DeleteInterp\fR,
or by replacing \fIname\fR in another call to \fBTcl_CreateObjCommand\fR.
\fIDeleteProc\fR is invoked before the command is deleted, and gives the
application an opportunity to release any structures associated
with the command. \fIDeleteProc\fR should have arguments and
result that match the type \fBTcl_CmdDeleteProc\fR:
.CS
typedef void Tcl_CmdDeleteProc(ClientData \fIclientData\fR);
.CE
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument passed to \fBTcl_CreateObjCommand\fR.
.PP
\fBTcl_DeleteCommand\fR deletes a command from a command interpreter.
Once the call completes, attempts to invoke \fIcmdName\fR in
\fIinterp\fR will result in errors.
If \fIcmdName\fR isn't bound as a command in \fIinterp\fR then
\fBTcl_DeleteCommand\fR does nothing and returns -1; otherwise
it returns 0.
There are no restrictions on \fIcmdName\fR: it may refer to
a built-in command, an application-specific command, or a Tcl procedure.
If \fIname\fR contains any \fB::\fR namespace qualifiers,
the command is deleted from the specified namespace.
.PP
Given a token returned by \fBTcl_CreateObjCommand\fR,
\fBTcl_DeleteCommandFromToken\fR deletes the command
from a command interpreter.
It will delete a command even if that command has been renamed.
Once the call completes, attempts to invoke the command in
\fIinterp\fR will result in errors.
If the command corresponding to \fItoken\fR
has already been deleted from \fIinterp\fR then
\fBTcl_DeleteCommand\fR does nothing and returns -1;
otherwise it returns 0.
.PP
\fBTcl_GetCommandInfo\fR checks to see whether its \fIcmdName\fR argument
exists as a command in \fIinterp\fR.
\fIcmdName\fR may include \fB::\fR namespace qualifiers
to identify a command in a particular namespace.
If the command is not found, then it returns 0.
Otherwise it places information about the command
in the \fBTcl_CmdInfo\fR structure
pointed to by \fIinfoPtr\fR and returns 1.
A \fBTcl_CmdInfo\fR structure has the following fields:
.CS
typedef struct Tcl_CmdInfo {
int isNativeObjectProc;
Tcl_ObjCmdProc *objProc;
ClientData objClientData;
Tcl_CmdProc *proc;
ClientData clientData;
Tcl_CmdDeleteProc *deleteProc;
ClientData deleteData;
Tcl_Namespace *namespacePtr;
} Tcl_CmdInfo;
.CE
The \fIisNativeObjectProc\fR field has the value 1
if \fBTcl_CreateObjCommand\fR was called to register the command;
it is 0 if only \fBTcl_CreateCommand\fR was called.
It allows a program to determine whether it is faster to
call \fIobjProc\fR or \fIproc\fR:
\fIobjProc\fR is normally faster
if \fIisNativeObjectProc\fR has the value 1.
The fields \fIobjProc\fR and \fIobjClientData\fR
have the same meaning as the \fIproc\fR and \fIclientData\fR
arguments to \fBTcl_CreateObjCommand\fR;
they hold information about the object-based command procedure
that the Tcl interpreter calls to implement the command.
The fields \fIproc\fR and \fIclientData\fR
hold information about the string-based command procedure
that implements the command.
If \fBTcl_CreateCommand\fR was called for this command,
this is the procedure passed to it;
otherwise, this is a compatibility procedure
registered by \fBTcl_CreateObjCommand\fR
that simply calls the command's
object-based procedure after converting its string arguments to Tcl objects.
The field \fIdeleteData\fR is the ClientData value
to pass to \fIdeleteProc\fR; it is normally the same as
\fIclientData\fR but may be set independently using the
\fBTcl_SetCommandInfo\fR procedure.
The field \fInamespacePtr\fR holds a pointer to the
Tcl_Namespace that contains the command.
.PP
\fBTcl_GetCommandInfoFromToken\fR is identical to
\fBTcl_GetCommandInfo\fR except that it uses a command token returned
from \fBTcl_CreateObjCommand\fR in place of the command name. If the
\fItoken\fR parameter is NULL, it returns 0; otherwise, it returns 1
and fills in the structure designated by \fIinfoPtr\fR.
.PP
\fBTcl_SetCommandInfo\fR is used to modify the procedures and
ClientData values associated with a command.
Its \fIcmdName\fR argument is the name of a command in \fIinterp\fR.
\fIcmdName\fR may include \fB::\fR namespace qualifiers
to identify a command in a particular namespace.
If this command does not exist then \fBTcl_SetCommandInfo\fR returns 0.
Otherwise, it copies the information from \fI*infoPtr\fR to
Tcl's internal structure for the command and returns 1.
.PP
\fBTcl_SetCommandInfoFromToken\fR is identical to
\fBTcl_SetCommandInfo\fR except that it takes a command token as
returned by \fBTcl_CreateObjCommand\fR instead of the command name.
If the \fItoken\fR parameter is NULL, it returns 0. Otherwise, it
copies the information from \fI*infoPtr\fR to Tcl's internal structure
for the command and returns 1.
.PP
Note that \fBTcl_SetCommandInfo\fR and
\fBTcl_SetCommandInfoFromToken\fR both allow the ClientData for a
command's deletion procedure to be given a different value than the
ClientData for its command procedure.
.PP
Note that neither \fBTcl_SetCommandInfo\fR nor
\fBTcl_SetCommandInfoFromToken\fR will change a command's namespace.
Use \fBTcl_Eval\fR to call the \fBrename\fR command to do that.
.PP
\fBTcl_GetCommandName\fR provides a mechanism for tracking commands
that have been renamed.
Given a token returned by \fBTcl_CreateObjCommand\fR
when the command was created, \fBTcl_GetCommandName\fR returns the
string name of the command. If the command has been renamed since it
was created, then \fBTcl_GetCommandName\fR returns the current name.
This name does not include any \fB::\fR namespace qualifiers.
The command corresponding to \fItoken\fR must not have been deleted.
The string returned by \fBTcl_GetCommandName\fR is in dynamic memory
owned by Tcl and is only guaranteed to retain its value as long as the
command isn't deleted or renamed; callers should copy the string if
they need to keep it for a long time.
.PP
\fBTcl_GetCommandFullName\fR produces the fully-qualified name
of a command from a command token.
The name, including all namespace prefixes,
is appended to the object specified by \fIobjPtr\fP.
.PP
\fBTcl_GetCommandFromObj\fR returns a token for the command
specified by the name in a \fBTcl_Obj\fP.
The command name is resolved relative to the current namespace.
Returns NULL if the command is not found.
.SH "SEE ALSO"
Tcl_CreateCommand, Tcl_ResetResult, Tcl_SetObjResult
.SH KEYWORDS
bind, command, create, delete, namespace, object
tcl8.4.20/doc/Utf.3 0000644 0036047 0045461 00000024551 11737050674 012315 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Utf 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_UniChar, Tcl_UniCharCaseMatch, Tcl_UniCharNcasecmp, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings.
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
typedef ... Tcl_UniChar;
.sp
int
\fBTcl_UniCharToUtf\fR(\fIch, buf\fR)
.sp
int
\fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR)
.VS 8.4
.sp
char *
\fBTcl_UniCharToUtfDString\fR(\fIuniStr, numChars, dstPtr\fR)
.sp
Tcl_UniChar *
\fBTcl_UtfToUniCharDString\fR(\fIsrc, len, dstPtr\fR)
.VE 8.4
.sp
int
\fBTcl_UniCharLen\fR(\fIuniStr\fR)
.sp
int
\fBTcl_UniCharNcmp\fR(\fIuniStr, uniStr, num\fR)
.VS 8.4
.sp
int
\fBTcl_UniCharNcasecmp\fR(\fIuniStr, uniStr, num\fR)
.sp
int
\fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR)
.VE 8.4
.sp
int
\fBTcl_UtfNcmp\fR(\fIsrc, src, num\fR)
.sp
int
\fBTcl_UtfNcasecmp\fR(\fIsrc, src, num\fR)
.sp
int
\fBTcl_UtfCharComplete\fR(\fIsrc, len\fR)
.sp
int
\fBTcl_NumUtfChars\fR(\fIsrc, len\fR)
.VS 8.4
.sp
CONST char *
\fBTcl_UtfFindFirst\fR(\fIsrc, ch\fR)
.sp
CONST char *
\fBTcl_UtfFindLast\fR(\fIsrc, ch\fR)
.sp
CONST char *
\fBTcl_UtfNext\fR(\fIsrc\fR)
.sp
CONST char *
\fBTcl_UtfPrev\fR(\fIsrc, start\fR)
.VE 8.4
.sp
Tcl_UniChar
\fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR)
.VS 8.4
.sp
CONST char *
\fBTcl_UtfAtIndex\fR(\fIsrc, index\fR)
.VE 8.4
.sp
int
\fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR)
.SH ARGUMENTS
.AS "CONST Tcl_UniChar" numChars in/out
.AP char *buf out
Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most
TCL_UTF_MAX bytes are stored in the buffer.
.AP int ch in
The Tcl_UniChar to be converted or examined.
.AP Tcl_UniChar *chPtr out
Filled with the Tcl_UniChar represented by the head of the UTF-8 string.
.AP "CONST char" *src in
Pointer to a UTF-8 string.
.AP "CONST Tcl_UniChar" *uniStr in
A null-terminated Unicode string.
.AP "CONST Tcl_UniChar" *uniPattern in
A null-terminated Unicode string.
.AP int len in
The length of the UTF-8 string in bytes (not UTF-8 characters). If
negative, all bytes up to the first null byte are used.
.AP int numChars in
The length of the Unicode string in characters. Must be greater than or
equal to 0.
.AP "Tcl_DString" *dstPtr in/out
A pointer to a previously-initialized \fBTcl_DString\fR.
.AP "unsigned long" num in
The number of characters to compare.
.AP "CONST char" *start in
Pointer to the beginning of a UTF-8 string.
.AP int index in
The index of a character (not byte) in the UTF-8 string.
.AP int *readPtr out
If non-NULL, filled with the number of bytes in the backslash sequence,
including the backslash character.
.AP char *dst out
Buffer in which the bytes represented by the backslash sequence are stored.
At most TCL_UTF_MAX bytes are stored in the buffer.
.VS 8.4
.AP int nocase in
Specifies whether the match should be done case-sensitive (0) or
case-insensitive (1).
.VE 8.4
.BE
.SH DESCRIPTION
.PP
These routines convert between UTF-8 strings and Tcl_UniChars. A
Tcl_UniChar is a Unicode character represented as an unsigned, fixed-size
quantity. A UTF-8 character is a Unicode character represented as
a varying-length sequence of up to TCL_UTF_MAX bytes. A multibyte UTF-8
sequence consists of a lead byte followed by some number of trail bytes.
.PP
\fBTCL_UTF_MAX\fR is the maximum number of bytes that it takes to
represent one Unicode character in the UTF-8 representation.
.PP
\fBTcl_UniCharToUtf\fR stores the Tcl_UniChar \fIch\fR as a UTF-8 string
in starting at \fIbuf\fR. The return value is the number of bytes stored
in \fIbuf\fR.
.PP
\fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR
and stores it as a Tcl_UniChar in \fI*chPtr\fR. The return value is the
number of bytes read from \fIsrc\fR.. The caller must ensure that the
source buffer is long enough such that this routine does not run off the
end and dereference non-existent or random memory; if the source buffer
is known to be null-terminated, this will not happen. If the input is
not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first
byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and
0x00ff and return 1.
.PP
\fBTcl_UniCharToUtfDString\fR converts the given Unicode string
to UTF-8, storing the result in a previously-initialized \fBTcl_DString\fR.
You must specify the length of the given Unicode string.
The return value is a pointer to the UTF-8 representation of the
Unicode string. Storage for the return value is appended to the
end of the \fBTcl_DString\fR.
.PP
\fBTcl_UtfToUniCharDString\fR converts the given UTF-8 string to Unicode,
storing the result in the previously-initialized \fBTcl_DString\fR.
you may either specify the length of the given UTF-8 string or "-1",
in which case \fBTcl_UtfToUniCharDString\fR uses \fBstrlen\fR to
calculate the length. The return value is a pointer to the Unicode
representation of the UTF-8 string. Storage for the return value
is appended to the end of the \fBTcl_DString\fR. The Unicode string
is terminated with a Unicode null character.
.PP
\fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode
characters. It accepts a null-terminated Unicode string and returns
the number of Unicode characters (not bytes) in that string.
.PP
\fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to
\fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters.
They accepts two null-terminated Unicode strings and the number of characters
to compare. Both strings are assumed to be at least \fIlen\fR characters
long. \fBTcl_UniCharNcmp\fR compares the two strings character-by-character
according to the Unicode character ordering. It returns an integer greater
than, equal to, or less than 0 if the first string is greater than, equal
to, or less than the second string respectively. \fBTcl_UniCharNcasecmp\fR
is the Unicode case insensitive version.
.PP
.VS 8.4
\fBTcl_UniCharCaseMatch\fR is the Unicode equivalent to
\fBTcl_StringCaseMatch\fR. It accepts a null-terminated Unicode string,
a Unicode pattern, and a boolean value specifying whether the match should
be case sensitive and returns whether the string matches the pattern.
.VE 8.4
.PP
\fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It
accepts two null-terminated UTF-8 strings and the number of characters
to compare. (Both strings are assumed to be at least \fIlen\fR
characters long.) \fBTcl_UtfNcmp\fR compares the two strings
character-by-character according to the Unicode character ordering.
It returns an integer greater than, equal to, or less than 0 if the
first string is greater than, equal to, or less than the second string
respectively.
.PP
\fBTcl_UtfNcasecmp\fR corresponds to \fBstrncasecmp\fR for UTF-8
strings. It is similar to \fBTcl_UtfNcmp\fR except comparisons ignore
differences in case when comparing upper, lower or title case
characters.
.PP
\fBTcl_UtfCharComplete\fR returns 1 if the source UTF-8 string \fIsrc\fR
of length \fIlen\fR bytes is long enough to be decoded by
\fBTcl_UtfToUniChar\fR, or 0 otherwise. This function does not guarantee
that the UTF-8 string is properly formed. This routine is used by
procedures that are operating on a byte at a time and need to know if a
full Tcl_UniChar has been seen.
.PP
\fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It
returns the number of Tcl_UniChars that are represented by the UTF-8 string
\fIsrc\fR. The length of the source string is \fIlen\fR bytes. If the
length is negative, all bytes up to the first null byte are used.
.PP
\fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings. It
returns a pointer to the first occurrence of the Tcl_UniChar \fIch\fR
in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is
considered part of the UTF-8 string.
.PP
\fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings. It
returns a pointer to the last occurrence of the Tcl_UniChar \fIch\fR
in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is
considered part of the UTF-8 string.
.PP
Given \fIsrc\fR, a pointer to some location in a UTF-8 string,
\fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the
string. The caller must not ask for the next character after the last
character in the string if the string is not terminated by a null
character.
.PP
Given \fIsrc\fR, a pointer to some location in a UTF-8 string (or to a
null byte immediately following such a string), \fBTcl_UtfPrev\fR
returns a pointer to the closest preceding byte that starts a UTF-8
character.
This function will not back up to a position before \fIstart\fR,
the start of the UTF-8 string. If \fIsrc\fR was already at \fIstart\fR, the
return value will be \fIstart\fR.
.PP
\fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the
Pascal Ord() function. It returns the Tcl_UniChar represented at the
specified character (not byte) \fIindex\fR in the UTF-8 string
\fIsrc\fR. The source string must contain at least \fIindex\fR
characters. Behavior is undefined if a negative \fIindex\fR is given.
.PP
\fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not
byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must
contain at least \fIindex\fR characters. This is equivalent to calling
\fBTcl_UtfNext\fR \fIindex\fR times. If a negative \fIindex\fR is given,
the return pointer points to the first character in the source string.
.PP
\fBTcl_UtfBackslash\fR is a utility procedure used by several of the Tcl
commands. It parses a backslash sequence and stores the properly formed
UTF-8 character represented by the backslash sequence in the output
buffer \fIdst\fR. At most TCL_UTF_MAX bytes are stored in the buffer.
\fBTcl_UtfBackslash\fR modifies \fI*readPtr\fR to contain the number
of bytes in the backslash sequence, including the backslash character.
The return value is the number of bytes stored in the output buffer.
.PP
See the \fBTcl\fR manual entry for information on the valid backslash
sequences. All of the sequences described in the Tcl manual entry are
supported by \fBTcl_UtfBackslash\fR.
.SH KEYWORDS
utf, unicode, backslash
tcl8.4.20/doc/expr.n 0000644 0036047 0045461 00000040566 12052456743 012632 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-2000 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH expr n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
expr \- Evaluate an expression
.SH SYNOPSIS
\fBexpr \fIarg \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
Concatenates \fIarg\fRs (adding separator spaces between them),
evaluates the result as a Tcl expression, and returns the value.
The operators permitted in Tcl expressions are a subset of
the operators permitted in C expressions, and they have the
same meaning and precedence as the corresponding C operators.
Expressions almost always yield numeric results
(integer or floating-point values).
For example, the expression
.CS
\fBexpr 8.2 + 6\fR
.CE
evaluates to 14.2.
Tcl expressions differ from C expressions in the way that
operands are specified. Also, Tcl expressions support
non-numeric operands and string comparisons.
.SH OPERANDS
.PP
A Tcl expression consists of a combination of operands, operators,
and parentheses.
White space may be used between the operands and operators and
parentheses; it is ignored by the expression's instructions.
Where possible, operands are interpreted as integer values.
Integer values may be specified in decimal (the normal case), in octal (if the
first character of the operand is \fB0\fR), or in hexadecimal (if the first
two characters of the operand are \fB0x\fR).
If an operand does not have one of the integer formats given
above, then it is treated as a floating-point number if that is
possible. Floating-point numbers may be specified in any of the
ways accepted by an ANSI-compliant C compiler (except that the
\fBf\fR, \fBF\fR, \fBl\fR, and \fBL\fR suffixes will not be permitted in
most installations). For example, all of the
following are valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16.
If no numeric interpretation is possible (note that all literal
operands that are not numeric or boolean must be quoted with either
braces or with double quotes), then an operand is left as a string
(and only a limited set of operators may be applied to it).
.PP
.VS 8.4
On 32-bit systems, integer values MAX_INT (0x7FFFFFFF) and MIN_INT
(-0x80000000) will be represented as 32-bit values, and integer values
outside that range will be represented as 64-bit values (if that is
possible at all.)
.VE 8.4
.PP
Operands may be specified in any of the following ways:
.IP [1]
As a numeric value, either integer or floating-point.
.IP [2]
As a boolean value, using any form understood by \fBstring is boolean\fR.
.IP [3]
As a Tcl variable, using standard \fB$\fR notation.
The variable's value will be used as the operand.
.IP [4]
As a string enclosed in double-quotes.
The expression parser will perform backslash, variable, and
command substitutions on the information between the quotes,
and use the resulting value as the operand
.IP [5]
As a string enclosed in braces.
The characters between the open brace and matching close brace
will be used as the operand without any substitutions.
.IP [6]
As a Tcl command enclosed in brackets.
The command will be executed and its result will be used as
the operand.
.IP [7]
As a mathematical function whose arguments have any of the above
forms for operands, such as \fBsin($x)\fR. See below for a list of defined
functions.
.LP
Where the above substitutions occur (e.g. inside quoted strings), they
are performed by the expression's instructions.
However, the command parser may already have performed one round of
substitution before the expression processor was called.
As discussed below, it is usually best to enclose expressions
in braces to prevent the command parser from performing substitutions
on the contents.
.PP
For some examples of simple expressions, suppose the variable
\fBa\fR has the value 3 and
the variable \fBb\fR has the value 6.
Then the command on the left side of each of the lines below
will produce the value on the right side of the line:
.CS
.ta 6c
\fBexpr 3.1 + $a 6.1
expr 2 + "$a.$b" 5.6
expr 4*[llength "6 2"] 8
expr {{word one} < "word $a"} 0\fR
.CE
.SH OPERATORS
.PP
The valid operators are listed below, grouped in decreasing order
of precedence:
.TP 20
\fB\-\0\0+\0\0~\0\0!\fR
Unary minus, unary plus, bit-wise NOT, logical NOT. None of these operators
may be applied to string operands, and bit-wise NOT may be
applied only to integers.
.TP 20
\fB*\0\0/\0\0%\fR
Multiply, divide, remainder. None of these operators may be
applied to string operands, and remainder may be applied only
to integers.
The remainder will always have the same sign as the divisor and
an absolute value smaller than the divisor.
.TP 20
\fB+\0\0\-\fR
Add and subtract. Valid for any numeric operands.
.TP 20
\fB<<\0\0>>\fR
Left and right shift. Valid for integer operands only.
A right shift always propagates the sign bit.
.TP 20
\fB<\0\0>\0\0<=\0\0>=\fR
Boolean less, greater, less than or equal, and greater than or equal.
Each operator produces 1 if the condition is true, 0 otherwise.
These operators may be applied to strings as well as numeric operands,
in which case string comparison is used.
.TP 20
\fB==\0\0!=\fR
Boolean equal and not equal. Each operator produces a zero/one result.
Valid for all operand types.
.VS 8.4
.TP 20
\fBeq\0\0ne\fR
Boolean string equal and string not equal. Each operator produces a
zero/one result. The operand types are interpreted only as strings.
.VE 8.4
.TP 20
\fB&\fR
Bit-wise AND. Valid for integer operands only.
.TP 20
\fB^\fR
Bit-wise exclusive OR. Valid for integer operands only.
.TP 20
\fB|\fR
Bit-wise OR. Valid for integer operands only.
.TP 20
\fB&&\fR
Logical AND. Produces a 1 result if both operands are non-zero,
0 otherwise.
Valid for boolean and numeric (integers or floating-point) operands only.
.TP 20
\fB||\fR
Logical OR. Produces a 0 result if both operands are zero, 1 otherwise.
Valid for boolean and numeric (integers or floating-point) operands only.
.TP 20
\fIx\fB?\fIy\fB:\fIz\fR
If-then-else, as in C. If \fIx\fR
evaluates to non-zero, then the result is the value of \fIy\fR.
Otherwise the result is the value of \fIz\fR.
The \fIx\fR operand must have a boolean or numeric value.
.LP
See the C manual for more details on the results
produced by each operator.
All of the binary operators group left-to-right within the same
precedence level. For example, the command
.CS
\fBexpr 4*2 < 7\fR
.CE
returns 0.
.PP
The \fB&&\fR, \fB||\fR, and \fB?:\fR operators have ``lazy
evaluation'', just as in C,
which means that operands are not evaluated if they are
not needed to determine the outcome. For example, in the command
.CS
\fBexpr {$v ? [a] : [b]}\fR
.CE
only one of \fB[a]\fR or \fB[b]\fR will actually be evaluated,
depending on the value of \fB$v\fR. Note, however, that this is
only true if the entire expression is enclosed in braces; otherwise
the Tcl parser will evaluate both \fB[a]\fR and \fB[b]\fR before
invoking the \fBexpr\fR command.
.SH "MATH FUNCTIONS"
.PP
Tcl supports the following mathematical functions in expressions, all
of which work solely with floating-point numbers unless otherwise noted:
.DS
.ta 3c 6c 9c
\fBabs\fR \fBcosh\fR \fBlog\fR \fBsqrt\fR
\fBacos\fR \fBdouble\fR \fBlog10\fR \fBsrand\fR
\fBasin\fR \fBexp\fR \fBpow\fR \fBtan\fR
\fBatan\fR \fBfloor\fR \fBrand\fR \fBtanh\fR
\fBatan2\fR \fBfmod\fR \fBround\fR \fBwide\fR
\fBceil\fR \fBhypot\fR \fBsin\fR
\fBcos\fR \fBint\fR \fBsinh\fR
.DE
.PP
.TP
\fBabs(\fIarg\fB)\fR
Returns the absolute value of \fIarg\fR. \fIArg\fR may be either
integer or floating-point, and the result is returned in the same form.
.TP
\fBacos(\fIarg\fB)\fR
Returns the arc cosine of \fIarg\fR, in the range [\fI0\fR,\fIpi\fR]
radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR].
.TP
\fBasin(\fIarg\fB)\fR
Returns the arc sine of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR]
radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR].
.TP
\fBatan(\fIarg\fB)\fR
Returns the arc tangent of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR]
radians.
.TP
\fBatan2(\fIy, x\fB)\fR
Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [\fI-pi\fR,\fIpi\fR]
radians. \fIx\fR and \fIy\fR cannot both be 0. If \fIx\fR is greater
than \fI0\fR, this is equivalent to \fBatan(\fIy/x\fB)\fR.
.TP
\fBceil(\fIarg\fB)\fR
Returns the smallest integral floating-point value (i.e. with a zero
fractional part) not less than \fIarg\fR.
.TP
\fBcos(\fIarg\fB)\fR
Returns the cosine of \fIarg\fR, measured in radians.
.TP
\fBcosh(\fIarg\fB)\fR
Returns the hyperbolic cosine of \fIarg\fR. If the result would cause
an overflow, an error is returned.
.TP
\fBdouble(\fIarg\fB)\fR
If \fIarg\fR is a floating-point value, returns \fIarg\fR, otherwise converts
\fIarg\fR to floating-point and returns the converted value.
.TP
\fBexp(\fIarg\fB)\fR
Returns the exponential of \fIarg\fR, defined as \fIe\fR**\fIarg\fR.
If the result would cause an overflow, an error is returned.
.TP
\fBfloor(\fIarg\fB)\fR
Returns the largest integral floating-point value (i.e. with a zero
fractional part) not greater than \fIarg\fR.
.TP
\fBfmod(\fIx, y\fB)\fR
Returns the floating-point remainder of the division of \fIx\fR by
\fIy\fR. If \fIy\fR is 0, an error is returned.
.TP
\fBhypot(\fIx, y\fB)\fR
Computes the length of the hypotenuse of a right-angled triangle
\fBsqrt(\fIx\fR*\fIx\fR+\fIy\fR*\fIy\fB)\fR.
.TP
\fBint(\fIarg\fB)\fR
.VS 8.4
If \fIarg\fR is an integer value of the same width as the machine
word, returns \fIarg\fR, otherwise
converts \fIarg\fR to an integer (of the same size as a machine word,
i.e. 32-bits on 32-bit systems, and 64-bits on 64-bit systems) by
truncation and returns the converted value.
.VE 8.4
.TP
\fBlog(\fIarg\fB)\fR
Returns the natural logarithm of \fIarg\fR. \fIArg\fR must be a
positive value.
.TP
\fBlog10(\fIarg\fB)\fR
Returns the base 10 logarithm of \fIarg\fR. \fIArg\fR must be a
positive value.
.TP
\fBpow(\fIx, y\fB)\fR
Computes the value of \fIx\fR raised to the power \fIy\fR. If \fIx\fR
is negative, \fIy\fR must be an integer value.
.TP
\fBrand()\fR
Returns a pseudo-random floating-point value in the range (\fI0\fR,\fI1\fR).
The generator algorithm is a simple linear congruential generator that
is not cryptographically secure. Each result from \fBrand\fR completely
determines all future results from subsequent calls to \fBrand\fR, so
\fBrand\fR should not be used to generate a sequence of secrets, such as
one-time passwords. The seed of the generator is initialized from the
internal clock of the machine or may be set with the \fBsrand\fR function.
.TP
\fBround(\fIarg\fB)\fR
If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts
\fIarg\fR to integer by rounding and returns the converted value.
.TP
\fBsin(\fIarg\fB)\fR
Returns the sine of \fIarg\fR, measured in radians.
.TP
\fBsinh(\fIarg\fB)\fR
Returns the hyperbolic sine of \fIarg\fR. If the result would cause
an overflow, an error is returned.
.TP
\fBsqrt(\fIarg\fB)\fR
Returns the square root of \fIarg\fR. \fIArg\fR must be non-negative.
.TP
\fBsrand(\fIarg\fB)\fR
The \fIarg\fR, which must be an integer, is used to reset the seed for
the random number generator of \fBrand\fR. Returns the first random
number (see \fBrand()\fR) from that seed. Each interpreter has its own seed.
.TP
\fBtan(\fIarg\fB)\fR
Returns the tangent of \fIarg\fR, measured in radians.
.TP
\fBtanh(\fIarg\fB)\fR
Returns the hyperbolic tangent of \fIarg\fR.
.TP
\fBwide(\fIarg\fB)\fR
.VS 8.4
Converts \fIarg\fR to an integer value at least 64-bits wide (by sign-extension
if \fIarg\fR is a 32-bit number) if it is not one already.
.VE 8.4
.PP
In addition to these predefined functions, applications may
define additional functions using \fBTcl_CreateMathFunc\fR().
.SH "TYPES, OVERFLOW, AND PRECISION"
.PP
All internal computations involving integers are done with the C type
\fIlong\fR, and all internal computations involving floating-point are
done with the C type \fIdouble\fR.
When converting a string to floating-point, exponent overflow is
detected and results in a Tcl error.
For conversion to integer from string, detection of overflow depends
on the behavior of some routines in the local C library, so it should
be regarded as unreliable.
In any case, integer overflow and underflow are generally not detected
reliably for intermediate results. Floating-point overflow and underflow
are detected to the degree supported by the hardware, which is generally
pretty reliable.
.PP
Conversion among internal representations for integer, floating-point,
and string operands is done automatically as needed.
For arithmetic computations, integers are used until some
floating-point number is introduced, after which floating-point is used.
For example,
.CS
\fBexpr 5 / 4\fR
.CE
returns 1, while
.CS
\fBexpr 5 / 4.0\fR
\fBexpr 5 / ( [string length "abcd"] + 0.0 )\fR
.CE
both return 1.25.
Floating-point values are always returned with a ``\fB.\fR''
or an \fBe\fR so that they will not look like integer values. For
example,
.CS
\fBexpr 20.0/5.0\fR
.CE
returns \fB4.0\fR, not \fB4\fR.
.SH "STRING OPERATIONS"
.PP
String values may be used as operands of the comparison operators,
although the expression evaluator tries to do comparisons as integer
or floating-point when it can,
i.e., when all arguments to the operator allow numeric interpretations,
.VS 8.4
except in the case of the \fBeq\fR and \fBne\fR operators.
.VE 8.4
If one of the operands of a comparison is a string and the other
has a numeric value, the numeric operand is converted back to
a string using the C \fIsprintf\fR format specifier
\fB%d\fR for integers and \fB%g\fR for floating-point values.
For example, the commands
.CS
\fBexpr {"0x03" > "2"}\fR
\fBexpr {"0y" > "0x12"}\fR
.CE
both return 1. The first comparison is done using integer
comparison, and the second is done using string comparison.
Because of Tcl's tendency to treat values as numbers whenever
possible, it isn't generally a good idea to use operators like \fB==\fR
when you really want string comparison and the values of the
operands could be arbitrary; it's better in these cases to use
.VS 8.4
the \fBeq\fR or \fBne\fR operators, or
.VE 8.4
the \fBstring\fR command instead.
.SH "PERFORMANCE CONSIDERATIONS"
.PP
Enclose expressions in braces for the best speed and the smallest
storage requirements.
This allows the Tcl bytecode compiler to generate the best code.
.PP
As mentioned above, expressions are substituted twice:
once by the Tcl parser and once by the \fBexpr\fR command.
For example, the commands
.CS
\fBset a 3\fR
\fBset b {$a + 2}\fR
\fBexpr $b*4\fR
.CE
return 11, not a multiple of 4.
This is because the Tcl parser will first substitute \fB$a + 2\fR for
the variable \fBb\fR,
then the \fBexpr\fR command will evaluate the expression \fB$a + 2*4\fR.
.PP
Most expressions do not require a second round of substitutions.
Either they are enclosed in braces or, if not,
their variable and command substitutions yield numbers or strings
that don't themselves require substitutions.
However, because a few unbraced expressions
need two rounds of substitutions,
the bytecode compiler must emit
additional instructions to handle this situation.
The most expensive code is required for
unbraced expressions that contain command substitutions.
These expressions must be implemented by generating new code
each time the expression is executed.
.SH EXAMPLES
Define a procedure that computes an "interesting" mathematical
function:
.CS
proc calc {x y} {
\fBexpr\fR { ($x*$x - $y*$y) / exp($x*$x + $y*$y) }
}
.CE
.PP
Convert polar coordinates into cartesian coordinates:
.CS
# convert from ($radius,$angle)
set x [\fBexpr\fR { $radius * cos($angle) }]
set y [\fBexpr\fR { $radius * sin($angle) }]
.CE
.PP
Convert cartesian coordinates into polar coordinates:
.CS
# convert from ($x,$y)
set radius [\fBexpr\fR { hypot($y, $x) }]
set angle [\fBexpr\fR { atan2($y, $x) }]
.CE
.PP
Print a message describing the relationship of two string values to
each other:
.CS
puts "a and b are [\fBexpr\fR {$a eq $b ? {equal} : {different}}]"
.CE
.PP
Set a variable to whether an environment variable is both defined at
all and also set to a true boolean value:
.CS
set isTrue [\fBexpr\fR {
[info exists ::env(SOME_ENV_VAR)] &&
[string is true -strict $::env(SOME_ENV_VAR)]
}]
.CE
.PP
Generate a random integer in the range 0..99 inclusive:
.CS
set randNum [\fBexpr\fR { int(100 * rand()) }]
.CE
.SH "SEE ALSO"
array(n), for(n), if(n), string(n), Tcl(n), while(n)
.SH KEYWORDS
arithmetic, boolean, compare, expression, fuzzy comparison
tcl8.4.20/doc/safe.n 0000644 0036047 0045461 00000036265 11737050674 012575 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Safe\ Base \- A mechanism for creating and manipulating safe interpreters.
.SH SYNOPSIS
\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR?
.sp
\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
.sp
\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
.sp
\fB::safe::interpDelete\fR \fIslave\fR
.sp
\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR
.sp
\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR
.sp
\fB::safe::setLogCmd\fR ?\fIcmd arg...\fR?
.SH OPTIONS
.PP
?\fB\-accessPath\fR \fIpathList\fR?
?\fB\-statics\fR \fIboolean\fR? ?\fB\-noStatics\fR?
?\fB\-nested\fR \fIboolean\fR? ?\fB\-nestedLoadOk\fR?
?\fB\-deleteHook\fR \fIscript\fR?
.BE
.SH DESCRIPTION
Safe Tcl is a mechanism for executing untrusted Tcl scripts
safely and for providing mediated access by such scripts to
potentially dangerous functionality.
.PP
The Safe Base ensures that untrusted Tcl scripts cannot harm the
hosting application.
The Safe Base prevents integrity and privacy attacks. Untrusted Tcl
scripts are prevented from corrupting the state of the hosting
application or computer. Untrusted scripts are also prevented from
disclosing information stored on the hosting computer or in the
hosting application to any party.
.PP
The Safe Base allows a master interpreter to create safe, restricted
interpreters that contain a set of predefined aliases for the \fBsource\fR,
\fBload\fR, \fBfile\fR, \fBencoding\fR, and \fBexit\fR commands and
are able to use the auto-loading and package mechanisms.
.PP
No knowledge of the file system structure is leaked to the
safe interpreter, because it has access only to a virtualized path
containing tokens. When the safe interpreter requests to source a file, it
uses the token in the virtual path as part of the file name to source; the
master interpreter transparently
translates the token into a real directory name and executes the
requested operation (see the section \fBSECURITY\fR below for details).
Different levels of security can be selected by using the optional flags
of the commands described below.
.PP
All commands provided in the master interpreter by the Safe Base reside in
the \fBsafe\fR namespace:
.SH COMMANDS
The following commands are provided in the master interpreter:
.TP
\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR?
Creates a safe interpreter, installs the aliases described in the section
\fBALIASES\fR and initializes the auto-loading and package mechanism as
specified by the supplied \fBoptions\fR.
See the \fBOPTIONS\fR section below for a description of the
optional arguments.
If the \fIslave\fR argument is omitted, a name will be generated.
\fB::safe::interpCreate\fR always returns the interpreter name.
.TP
\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
This command is similar to \fBinterpCreate\fR except it that does not
create the safe interpreter. \fIslave\fR must have been created by some
other means, like \fBinterp create \-safe\fR.
.TP
\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
If no \fIoptions\fR are given, returns the settings for all options for the
named safe interpreter as a list of options and their current values
for that \fIslave\fR.
If a single additional argument is provided,
it will return a list of 2 elements \fIname\fR and \fIvalue\fR where
\fIname\fR is the full name of that option and \fIvalue\fR the current value
for that option and the \fIslave\fR.
If more than two additional arguments are provided, it will reconfigure the
safe interpreter and change each and only the provided options.
See the section on \fBOPTIONS\fR below for options description.
Example of use:
.RS
.CS
# Create a new interp with the same configuration as "$i0" :
set i1 [eval safe::interpCreate [safe::interpConfigure $i0]]
# Get the current deleteHook
set dh [safe::interpConfigure $i0 \-del]
# Change (only) the statics loading ok attribute of an interp
# and its deleteHook (leaving the rest unchanged) :
safe::interpConfigure $i0 \-delete {foo bar} \-statics 0 ;
.CE
.RE
.TP
\fB::safe::interpDelete\fR \fIslave\fR
Deletes the safe interpreter and cleans up the corresponding
master interpreter data structures.
If a \fIdeleteHook\fR script was specified for this interpreter it is
evaluated before the interpreter is deleted, with the name of the
interpreter as an additional argument.
.TP
\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR
This command finds and returns the token for the real directory
\fIdirectory\fR in the safe interpreter's current virtual access path.
It generates an error if the directory is not found.
Example of use:
.RS
.CS
$slave eval [list set tk_library [::safe::interpFindInAccessPath $name $tk_library]]
.CE
.RE
.TP
\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR
This command adds \fIdirectory\fR to the virtual path maintained for the
safe interpreter in the master, and returns the token that can be used in
the safe interpreter to obtain access to files in that directory.
If the directory is already in the virtual path, it only returns the token
without adding the directory to the virtual path again.
Example of use:
.RS
.CS
$slave eval [list set tk_library [::safe::interpAddToAccessPath $name $tk_library]]
.CE
.RE
.TP
\fB::safe::setLogCmd\fR ?\fIcmd arg...\fR?
This command installs a script that will be called when interesting
life cycle events occur for a safe interpreter.
When called with no arguments, it returns the currently installed script.
When called with one argument, an empty string, the currently installed
script is removed and logging is turned off.
The script will be invoked with one additional argument, a string
describing the event of interest.
The main purpose is to help in debugging safe interpreters.
Using this facility you can get complete error messages while the safe
interpreter gets only generic error messages.
This prevents a safe interpreter from seeing messages about failures
and other events that might contain sensitive information such as real
directory names.
.RS
Example of use:
.CS
::safe::setLogCmd puts stderr
.CE
Below is the output of a sample session in which a safe interpreter
attempted to source a file not found in its virtual access path.
Note that the safe interpreter only received an error message saying that
the file was not found:
.CS
NOTICE for slave interp10 : Created
NOTICE for slave interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=()
NOTICE for slave interp10 : auto_path in interp10 has been set to {$p(:0:)}
ERROR for slave interp10 : /foo/bar/init.tcl: no such file or directory
.CE
.RE
.SH OPTIONS
The following options are common to
\fB::safe::interpCreate\fR, \fB::safe::interpInit\fR,
and \fB::safe::interpConfigure\fR.
Any option name can be abbreviated to its minimal
non-ambiguous name.
Option names are not case sensitive.
.TP
\fB\-accessPath\fR \fIdirectoryList\fR
This option sets the list of directories from which the safe interpreter
can \fBsource\fR and \fBload\fR files.
If this option is not specified, or if it is given as the
empty list, the safe interpreter will use the same directories as its
master for auto-loading.
See the section \fBSECURITY\fR below for more detail about virtual paths,
tokens and access control.
.TP
\fB\-statics\fR \fIboolean\fR
This option specifies if the safe interpreter will be allowed
to load statically linked packages (like \fBload {} Tk\fR).
The default value is \fBtrue\fR :
safe interpreters are allowed to load statically linked packages.
.TP
\fB\-noStatics\fR
This option is a convenience shortcut for \fB-statics false\fR and
thus specifies that the safe interpreter will not be allowed
to load statically linked packages.
.TP
\fB\-nested\fR \fIboolean\fR
This option specifies if the safe interpreter will be allowed
to load packages into its own sub-interpreters.
The default value is \fBfalse\fR :
safe interpreters are not allowed to load packages into
their own sub-interpreters.
.TP
\fB\-nestedLoadOk\fR
This option is a convenience shortcut for \fB-nested true\fR and
thus specifies the safe interpreter will be allowed
to load packages into its own sub-interpreters.
.TP
\fB\-deleteHook\fR \fIscript\fR
When this option is given a non-empty \fIscript\fR, it will be
evaluated in the master with the name of
the safe interpreter as an additional argument
just before actually deleting the safe interpreter.
Giving an empty value removes any currently installed deletion hook
script for that safe interpreter.
The default value (\fB{}\fR) is not to have any deletion call back.
.SH ALIASES
The following aliases are provided in a safe interpreter:
.TP
\fBsource\fR \fIfileName\fR
The requested file, a Tcl source file, is sourced into the safe interpreter
if it is found.
The \fBsource\fR alias can only source files from directories in
the virtual path for the safe interpreter. The \fBsource\fR alias requires
the safe interpreter to
use one of the token names in its virtual path to denote the directory in
which the file to be sourced can be found.
See the section on \fBSECURITY\fR for more discussion of restrictions on
valid filenames.
.TP
\fBload\fR \fIfileName\fR
The requested file, a shared object file, is dynamically loaded into the
safe interpreter if it is found.
The filename must contain a token name mentioned in the virtual path for
the safe interpreter for it to be found successfully.
Additionally, the shared object file must contain a safe entry point; see
the manual page for the \fBload\fR command for more details.
.TP
\fBfile\fR ?\fIsubCmd args...\fR?
The \fBfile\fR alias provides access to a safe subset of the subcommands of
the \fBfile\fR command; it allows only \fBdirname\fR, \fBjoin\fR,
\fBextension\fR, \fBroot\fR, \fBtail\fR, \fBpathname\fR and \fBsplit\fR
subcommands. For more details on what these subcommands do see the manual
page for the \fBfile\fR command.
.TP
\fBencoding\fR ?\fIsubCmd args...\fR?
The \fBencoding\fR alias provides access to a safe subset of the
subcommands of the \fBencoding\fR command; it disallows setting of
the system encoding, but allows all other subcommands including
\fBsystem\fR to check the current encoding.
.TP
\fBexit\fR
The calling interpreter is deleted and its computation is stopped, but the
Tcl process in which this interpreter exists is not terminated.
.SH SECURITY
The Safe Base does not attempt to completely prevent annoyance and
denial of service attacks. These forms of attack prevent the
application or user from temporarily using the computer to perform
useful work, for example by consuming all available CPU time or
all available screen real estate.
These attacks, while aggravating, are deemed to be of lesser importance
in general than integrity and privacy attacks that the Safe Base
is to prevent.
.PP
The commands available in a safe interpreter, in addition to
the safe set as defined in \fBinterp\fR manual page, are mediated aliases
for \fBsource\fR, \fBload\fR, \fBexit\fR, and safe subsets of
\fBfile\fR and \fBencoding\fR. The safe interpreter can also auto-load
code and it can request that packages be loaded.
.PP
Because some of these commands access the local file system, there is a
potential for information leakage about its directory structure.
To prevent this, commands that take file names as arguments in a safe
interpreter use tokens instead of the real directory names.
These tokens are translated to the real directory name while a request to,
e.g., source a file is mediated by the master interpreter.
This virtual path system is maintained in the master interpreter for each safe
interpreter created by \fB::safe::interpCreate\fR or initialized by
\fB::safe::interpInit\fR and
the path maps tokens accessible in the safe interpreter into real path
names on the local file system thus preventing safe interpreters
from gaining knowledge about the
structure of the file system of the host on which the interpreter is
executing.
The only valid file names arguments
for the \fBsource\fR and \fBload\fR aliases provided to the slave
are path in the form of
\fB[file join \fR\fItoken filename\fR\fB]\fR (i.e. when using the
native file path formats: \fItoken\fR\fB/\fR\fIfilename\fR
on Unix, \fItoken\fR\fB\\\fIfilename\fR on Windows,
and \fItoken\fR\fB:\fR\fIfilename\fR on the Mac),
where \fItoken\fR is representing one of the directories
of the \fIaccessPath\fR list and \fIfilename\fR is
one file in that directory (no sub directories access are allowed).
.PP
When a token is used in a safe interpreter in a request to source or
load a file, the token is checked and
translated to a real path name and the file to be
sourced or loaded is located on the file system.
The safe interpreter never gains knowledge of the actual path name under
which the file is stored on the file system.
.PP
To further prevent potential information leakage from sensitive files that
are accidentally included in the set of files that can be sourced by a safe
interpreter, the \fBsource\fR alias restricts access to files
meeting the following constraints: the file name must
fourteen characters or shorter, must not contain more than one dot ("\fB.\fR"),
must end up with the extension \fB.tcl\fR or be called \fBtclIndex\fR.
.PP
Each element of the initial access path
list will be assigned a token that will be set in
the slave \fBauto_path\fR and the first element of that list will be set as
the \fBtcl_library\fR for that slave.
.PP
If the access path argument is not given or is the empty list,
the default behavior is to let the slave access the same packages
as the master has access to (Or to be more precise:
only packages written in Tcl (which by definition can't be dangerous
as they run in the slave interpreter) and C extensions that
provides a Safe_Init entry point). For that purpose, the master's
\fBauto_path\fR will be used to construct the slave access path.
In order that the slave successfully loads the Tcl library files
(which includes the auto-loading mechanism itself) the \fBtcl_library\fR will be
added or moved to the first position if necessary, in the
slave access path, so the slave
\fBtcl_library\fR will be the same as the master's (its real
path will still be invisible to the slave though).
In order that auto-loading works the same for the slave and
the master in this by default case, the first-level
sub directories of each directory in the master \fBauto_path\fR will
also be added (if not already included) to the slave access path.
You can always specify a more
restrictive path for which sub directories will never be searched by
explicitly specifying your directory list with the \fB\-accessPath\fR flag
instead of relying on this default mechanism.
.PP
When the \fIaccessPath\fR is changed after the first creation or
initialization (i.e. through \fBinterpConfigure -accessPath \fR\fIlist\fR),
an \fBauto_reset\fR is automatically evaluated in the safe interpreter
to synchronize its \fBauto_index\fR with the new token list.
.SH "SEE ALSO"
interp(n), library(n), load(n), package(n), source(n), unknown(n)
.SH KEYWORDS
alias, auto\-loading, auto_mkindex, load, master interpreter, safe
interpreter, slave interpreter, source
tcl8.4.20/doc/Thread.3 0000644 0036047 0045461 00000021337 11737050674 012765 0 ustar dgp 771div '\"
'\" Copyright (c) 1999 Scriptics Corporation
'\" Copyright (c) 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.
'\"
.so man.macros
.TH Threads 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_CreateThread, Tcl_JoinThread \- Tcl thread support.
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
void
\fBTcl_ConditionNotify\fR(\fIcondPtr\fR)
.sp
void
\fBTcl_ConditionWait\fR(\fIcondPtr, mutexPtr, timePtr\fR)
.sp
void
\fBTcl_ConditionFinalize\fR(\fIcondPtr\fR)
.sp
Void *
\fBTcl_GetThreadData\fR(\fIkeyPtr, size\fR)
.sp
void
\fBTcl_MutexLock\fR(\fImutexPtr\fR)
.sp
void
\fBTcl_MutexUnlock\fR(\fImutexPtr\fR)
.sp
void
\fBTcl_MutexFinalize\fR(\fImutexPtr\fR)
.sp
int
\fBTcl_CreateThread\fR(\fIidPtr, threadProc, clientData, stackSize, flags\fR)
.sp
int
\fBTcl_JoinThread\fR(\fIid, result\fR)
.SH ARGUMENTS
.AS Tcl_ThreadDataKey *keyPtr
.AP Tcl_Condition *condPtr in
A condition variable, which must be associated with a mutex lock.
.AP Tcl_Mutex *mutexPtr in
A mutex lock.
.AP Tcl_Time *timePtr in
A time limit on the condition wait. NULL to wait forever.
Note that a polling value of 0 seconds doesn't make much sense.
.AP Tcl_ThreadDataKey *keyPtr in
This identifies a block of thread local storage. The key should be
static and process-wide, yet each thread will end up associating
a different block of storage with this key.
.AP int *size in
The size of the thread local storage block. This amount of data
is allocated and initialized to zero the first time each thread
calls \fBTcl_GetThreadData\fR.
.AP Tcl_ThreadId *idPtr out
The referred storage will contain the id of the newly created thread as
returned by the operating system.
.AP Tcl_ThreadId id in
Id of the thread waited upon.
.AP Tcl_ThreadCreateProc threadProc in
This procedure will act as the \fBmain()\fR of the newly created
thread. The specified \fIclientData\fR will be its sole argument.
.AP ClientData clientData in
Arbitrary information. Passed as sole argument to the \fIthreadProc\fR.
.AP int stackSize in
The size of the stack given to the new thread.
.AP int flags in
Bitmask containing flags allowing the caller to modify behaviour of
the new thread.
.AP int *result out
The referred storage is used to place the exit code of the thread
waited upon into it.
.BE
.SH INTRODUCTION
Beginning with the 8.1 release, the Tcl core is thread safe, which
allows you to incorporate Tcl into multithreaded applications without
customizing the Tcl core. To enable Tcl multithreading support,
you must include the \fB--enable-threads\fR option to \fBconfigure\fR
when you configure and compile your Tcl core.
.PP
An important constraint of the Tcl threads implementation is that
\fIonly the thread that created a Tcl interpreter can use that
interpreter\fR. In other words, multiple threads can not access
the same Tcl interpreter. (However, as was the case in previous
releases, a single thread can safely create and use multiple
interpreters.)
.PP
.VS 8.3.1
Tcl does provide \fBTcl_CreateThread\fR for creating threads. The
caller can determine the size of the stack given to the new thread and
modify the behaviour through the supplied \fIflags\fR. The value
\fBTCL_THREAD_STACK_DEFAULT\fR for the \fIstackSize\fR indicates that
the default size as specified by the operating system is to be used
for the new thread. As for the flags, currently are only the values
\fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR defined. The
first of them invokes the default behaviour with no
specialties. Using the second value marks the new thread as
\fIjoinable\fR. This means that another thread can wait for the such
marked thread to exit and join it.
.PP
Restrictions: On some unix systems the pthread-library does not
contain the functionality to specify the stacksize of a thread. The
specified value for the stacksize is ignored on these systems. Both
Windows and Macintosh currently do not support joinable threads. This
flag value is therefore ignored on these platforms.
.VE
.PP
Tcl does provide \fBTcl_ExitThread\fR and \fBTcl_FinalizeThread\fR
for terminating threads and invoking optional per-thread exit
handlers. See the \fBTcl_Exit\fR page for more information on these
procedures.
.PP
.VS
The \fBTcl_JoinThread\fR function is provided to allow threads to wait
upon the exit of another thread, which must have been marked as
joinable through usage of the \fBTCL_THREAD_JOINABLE\fR-flag during
its creation via \fBTcl_CreateThread\fR.
.PP
Trying to wait for the exit of a non-joinable thread or a thread which
is already waited upon will result in an error. Waiting for a joinable
thread which already exited is possible, the system will retain the
necessary information until after the call to \fBTcl_JoinThread\fR.
This means that not calling \fBTcl_JoinThread\fR for a joinable thread
will cause a memory leak.
.VE
.PP
Tcl provides \fBTcl_ThreadQueueEvent\fR and \fBTcl_ThreadAlert\fR
for handling event queueing in multithreaded applications. See
the \fBNotifier\fR manual page for more information on these procedures.
.PP
In this release, the Tcl language itself provides no support for
creating multithreaded scripts (for example, scripts that could spawn
a Tcl interpreter in a separate thread). If you need to add this
feature at this time, see the \fItclThreadTest.c\fR
file in the Tcl source distribution for an experimental implementation
or use the Tcl "Threading Extension" package implementing thread creation
and management commands at the script level.
.SH DESCRIPTION
A mutex is a lock that is used to serialize all threads through a piece
of code by calling \fBTcl_MutexLock\fR and \fBTcl_MutexUnlock\fR.
If one thread holds a mutex, any other thread calling \fBTcl_MutexLock\fR will
block until \fBTcl_MutexUnlock\fR is called.
.VS
A mutex can be destroyed after its use by calling \fBTcl_MutexFinalize\fR.
The result of locking a mutex twice from the same thread is undefined.
On some platforms it will result in a deadlock.
.VE
The \fBTcl_MutexLock\fR, \fBTcl_MutexUnlock\fR and \fBTcl_MutexFinalize\fR
procedures are defined as empty macros if not compiling with threads enabled.
For declaration of mutexes the \fBTCL_DECLARE_MUTEX\fR macro should be used.
This macro assures correct mutex handling even when the core is compiled
without threads enabled.
.PP
A condition variable is used as a signaling mechanism:
a thread can lock a mutex and then wait on a condition variable
with \fBTcl_ConditionWait\fR. This atomically releases the mutex lock
and blocks the waiting thread until another thread calls
\fBTcl_ConditionNotify\fR. The caller of \fBTcl_ConditionNotify\fR should
have the associated mutex held by previously calling \fBTcl_MutexLock\fR,
but this is not enforced. Notifying the
condition variable unblocks all threads waiting on the condition variable,
but they do not proceed until the mutex is released with \fBTcl_MutexUnlock\fR.
The implementation of \fBTcl_ConditionWait\fR automatically locks
the mutex before returning.
.PP
The caller of \fBTcl_ConditionWait\fR should be prepared for spurious
notifications by calling \fBTcl_ConditionWait\fR within a while loop
that tests some invariant.
.PP
.VS
A condition variable can be destroyed after its use by calling
\fBTcl_ConditionFinalize\fR.
.PP
The \fBTcl_ConditionNotify\fR, \fBTcl_ConditionWait\fR and
\fBTcl_ConditionFinalize\fR procedures are defined as empty macros if
not compiling with threads enabled.
.VE
.PP
The \fBTcl_GetThreadData\fR call returns a pointer to a block of
thread-private data. Its argument is a key that is shared by all threads
and a size for the block of storage. The storage is automatically
allocated and initialized to all zeros the first time each thread asks for it.
The storage is automatically deallocated by \fBTcl_FinalizeThread\fR.
.SH INITIALIZATION
.PP
All of these synchronization objects are self initializing.
They are implemented as opaque pointers that should be NULL
upon first use.
The mutexes and condition variables are
.VS
either cleaned up by process exit handlers (if living that long) or
explicitly by calls to \fBTcl_MutexFinalize\fR or
\fBTcl_ConditionFinalize\fR.
.VE
Thread local storage is reclaimed during \fBTcl_FinalizeThread\fR.
.SH "CREATING THREADS"
The API to create threads is not finalized at this time.
There are private facilities to create threads that contain a new
Tcl interpreter, and to send scripts among threads.
Dive into tclThreadTest.c and tclThread.c for examples.
.SH "SEE ALSO"
Tcl_GetCurrentThread, Tcl_ThreadQueueEvent, Tcl_ThreadAlert,
Tcl_ExitThread, Tcl_FinalizeThread,
Tcl_CreateThreadExitHandler, Tcl_DeleteThreadExitHandler
.SH KEYWORDS
thread, mutex, condition variable, thread local storage
tcl8.4.20/doc/StrMatch.3 0000644 0036047 0045461 00000003054 11737050674 013277 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_StringMatch 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_StringMatch, Tcl_StringCaseMatch \- test whether a string matches a pattern
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_StringMatch\fR(\fIstring\fR, \fIpattern\fR)
.sp
int
\fBTcl_StringCaseMatch\fR(\fIstring\fR, \fIpattern\fR, \fInocase\fR)
.SH ARGUMENTS
.AP char *string in
String to test.
.AP char *pattern in
Pattern to match against string. May contain special
characters from the set *?\e[].
.AP int nocase in
Specifies whether the match should be done case-sensitive (0) or
case-insensitive (1).
.BE
.SH DESCRIPTION
.PP
This utility procedure determines whether a string matches
a given pattern. If it does, then \fBTcl_StringMatch\fR returns
1. Otherwise \fBTcl_StringMatch\fR returns 0. The algorithm
used for matching is the same algorithm used in the ``string match''
Tcl command and is similar to the algorithm used by the C-shell
for file name matching; see the Tcl manual entry for details.
.VS 8.1
.PP
In \fBTcl_StringCaseMatch\fR, the algorithm is the same, but you have
the option to make the matching case-insensitive. If you choose this
(by passing \fBnocase\fR as 1), then the string and pattern are
essentially matched in the lower case.
.VE 8.1
.SH KEYWORDS
match, pattern, string
tcl8.4.20/doc/Environment.3 0000644 0036047 0045461 00000001707 11737050674 014061 0 ustar dgp 771div '\"
'\" Copyright (c) 1997-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.
'\"
.so man.macros
.TH Tcl_PutEnv 3 "7.5" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_PutEnv \- procedures to manipulate the environment
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_PutEnv\fR(\fIstring\fR)
.SH ARGUMENTS
.AP "CONST char" *string in
Info about environment variable in the form NAME=value.
The \fIstring\fR argument is in the system encoding.
.BE
.SH DESCRIPTION
.PP
\fBTcl_PutEnv\fR sets an environment variable. The information is
passed in a single string of the form NAME=value. This procedure is
intended to be a stand-in for the UNIX \fBputenv\fR system call. All
tcl-based applications using \fBputenv\fR should redefine it to
\fBTcl_PutEnv\fR so that they will interface properly to the Tcl
runtime.
.SH KEYWORDS
environment, variable
tcl8.4.20/doc/Encoding.3 0000644 0036047 0045461 00000061101 11737050674 013275 0 ustar dgp 771div '\"
'\" Copyright (c) 1997-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.
'\"
.so man.macros
.TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings.
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Encoding
\fBTcl_GetEncoding\fR(\fIinterp, name\fR)
.sp
void
\fBTcl_FreeEncoding\fR(\fIencoding\fR)
.sp
char *
\fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR)
.sp
int
\fBTcl_ExternalToUtf\fR(\fIinterp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
dstCharsPtr\fR)
.sp
char *
\fBTcl_UtfToExternalDString\fR(\fIencoding, src, srcLen, dstPtr\fR)
.sp
int
\fBTcl_UtfToExternal\fR(\fIinterp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
dstCharsPtr\fR)
.sp
char *
\fBTcl_WinTCharToUtf\fR(\fItsrc, srcLen, dstPtr\fR)
.sp
TCHAR *
\fBTcl_WinUtfToTChar\fR(\fIsrc, srcLen, dstPtr\fR)
.sp
CONST char *
\fBTcl_GetEncodingName\fR(\fIencoding\fR)
.sp
int
\fBTcl_SetSystemEncoding\fR(\fIinterp, name\fR)
.sp
void
\fBTcl_GetEncodingNames\fR(\fIinterp\fR)
.sp
Tcl_Encoding
\fBTcl_CreateEncoding\fR(\fItypePtr\fR)
.sp
CONST char *
\fBTcl_GetDefaultEncodingDir\fR(\fIvoid\fR)
.sp
void
\fBTcl_SetDefaultEncodingDir\fR(\fIpath\fR)
.SH ARGUMENTS
.AS Tcl_EncodingState *dstWrotePtr
.AP Tcl_Interp *interp in
Interpreter to use for error reporting, or NULL if no error reporting is
desired.
.AP "CONST char" *name in
Name of encoding to load.
.AP Tcl_Encoding encoding in
The encoding to query, free, or use for converting text. If \fIencoding\fR is
NULL, the current system encoding is used.
.AP "CONST char" *src in
For the \fBTcl_ExternalToUtf\fR functions, an array of bytes in the
specified encoding that are to be converted to UTF-8. For the
\fBTcl_UtfToExternal\fR and \fBTcl_WinUtfToTChar\fR functions, an array of
UTF-8 characters to be converted to the specified encoding.
.AP "CONST TCHAR" *tsrc in
An array of Windows TCHAR characters to convert to UTF-8.
.AP int srcLen in
Length of \fIsrc\fR or \fItsrc\fR in bytes. If the length is negative, the
encoding-specific length of the string is used.
.AP Tcl_DString *dstPtr out
Pointer to an uninitialized or free \fBTcl_DString\fR in which the converted
result will be stored.
.AP int flags in
Various flag bits OR-ed together.
TCL_ENCODING_START signifies that the
source buffer is the first block in a (potentially multi-block) input
stream, telling the conversion routine to reset to an initial state and
perform any initialization that needs to occur before the first byte is
converted. TCL_ENCODING_END signifies that the source buffer is the last
block in a (potentially multi-block) input stream, telling the conversion
routine to perform any finalization that needs to occur after the last
byte is converted and then to reset to an initial state.
TCL_ENCODING_STOPONERROR signifies that the conversion routine should
return immediately upon reading a source character that doesn't exist in
the target encoding; otherwise a default fallback character will
automatically be substituted.
.AP Tcl_EncodingState *statePtr in/out
Used when converting a (generally long or indefinite length) byte stream
in a piece by piece fashion. The conversion routine stores its current
state in \fI*statePtr\fR after \fIsrc\fR (the buffer containing the
current piece) has been converted; that state information must be passed
back when converting the next piece of the stream so the conversion
routine knows what state it was in when it left off at the end of the
last piece. May be NULL, in which case the value specified for \fIflags\fR
is ignored and the source buffer is assumed to contain the complete string to
convert.
.AP char *dst out
Buffer in which the converted result will be stored. No more than
\fIdstLen\fR bytes will be stored in \fIdst\fR.
.AP int dstLen in
The maximum length of the output buffer \fIdst\fR in bytes.
.AP int *srcReadPtr out
Filled with the number of bytes from \fIsrc\fR that were actually
converted. This may be less than the original source length if there was
a problem converting some source characters. May be NULL.
.AP int *dstWrotePtr out
Filled with the number of bytes that were actually stored in the output
buffer as a result of the conversion. May be NULL.
.AP int *dstCharsPtr out
Filled with the number of characters that correspond to the number of bytes
stored in the output buffer. May be NULL.
.AP Tcl_EncodingType *typePtr in
Structure that defines a new type of encoding.
.AP "CONST char" *path in
A path to the location of the encoding file.
.BE
.SH INTRODUCTION
.PP
These routines convert between Tcl's internal character representation,
UTF-8, and character representations used by various operating systems or
file systems, such as Unicode, ASCII, or Shift-JIS. When operating on
strings, such as such as obtaining the names of files or displaying
characters using international fonts, the strings must be translated into
one or possibly multiple formats that the various system calls can use. For
instance, on a Japanese Unix workstation, a user might obtain a filename
represented in the EUC-JP file encoding and then translate the characters to
the jisx0208 font encoding in order to display the filename in a Tk widget.
The purpose of the encoding package is to help bridge the translation gap.
UTF-8 provides an intermediate staging ground for all the various
encodings. In the example above, text would be translated into UTF-8 from
whatever file encoding the operating system is using. Then it would be
translated from UTF-8 into whatever font encoding the display routines
require.
.PP
Some basic encodings are compiled into Tcl. Others can be defined by the
user or dynamically loaded from encoding files in a
platform-independent manner.
.SH DESCRIPTION
.PP
\fBTcl_GetEncoding\fR finds an encoding given its \fIname\fR. The name may
refer to a builtin Tcl encoding, a user-defined encoding registered by
calling \fBTcl_CreateEncoding\fR, or a dynamically-loadable encoding
file. The return value is a token that represents the encoding and can be
used in subsequent calls to procedures such as \fBTcl_GetEncodingName\fR,
\fBTcl_FreeEncoding\fR, and \fBTcl_UtfToExternal\fR. If the name did not
refer to any known or loadable encoding, NULL is returned and an error
message is returned in \fIinterp\fR.
.PP
The encoding package maintains a database of all encodings currently in use.
The first time \fIname\fR is seen, \fBTcl_GetEncoding\fR returns an
encoding with a reference count of 1. If the same \fIname\fR is requested
further times, then the reference count for that encoding is incremented
without the overhead of allocating a new encoding and all its associated
data structures.
.PP
When an \fIencoding\fR is no longer needed, \fBTcl_FreeEncoding\fR
should be called to release it. When an \fIencoding\fR is no longer in use
anywhere (i.e., it has been freed as many times as it has been gotten)
\fBTcl_FreeEncoding\fR will release all storage the encoding was using
and delete it from the database.
.PP
\fBTcl_ExternalToUtfDString\fR converts a source buffer \fIsrc\fR from the
specified \fIencoding\fR into UTF-8. The converted bytes are stored in
\fIdstPtr\fR, which is then null-terminated. The caller should eventually
call \fBTcl_DStringFree\fR to free any information stored in \fIdstPtr\fR.
When converting, if any of the characters in the source buffer cannot be
represented in the target encoding, a default fallback character will be
used. The return value is a pointer to the value stored in the DString.
.PP
\fBTcl_ExternalToUtf\fR converts a source buffer \fIsrc\fR from the specified
\fIencoding\fR into UTF-8. Up to \fIsrcLen\fR bytes are converted from the
source buffer and up to \fIdstLen\fR converted bytes are stored in \fIdst\fR.
In all cases, \fI*srcReadPtr\fR is filled with the number of bytes that were
successfully converted from \fIsrc\fR and \fI*dstWrotePtr\fR is filled with
the corresponding number of bytes that were stored in \fIdst\fR. The return
value is one of the following:
.RS
.IP \fBTCL_OK\fR 29
All bytes of \fIsrc\fR were converted.
.IP \fBTCL_CONVERT_NOSPACE\fR 29
The destination buffer was not large enough for all of the converted data; as
many characters as could fit were converted though.
.IP \fBTCL_CONVERT_MULTIBYTE\fR 29
The last fews bytes in the source buffer were the beginning of a multibyte
sequence, but more bytes were needed to complete this sequence. A
subsequent call to the conversion routine should pass a buffer containing
the unconverted bytes that remained in \fIsrc\fR plus some further bytes
from the source stream to properly convert the formerly split-up multibyte
sequence.
.IP \fBTCL_CONVERT_SYNTAX\fR 29
The source buffer contained an invalid character sequence. This may occur
if the input stream has been damaged or if the input encoding method was
misidentified.
.IP \fBTCL_CONVERT_UNKNOWN\fR 29
The source buffer contained a character that could not be represented in
the target encoding and TCL_ENCODING_STOPONERROR was specified.
.RE
.LP
\fBTcl_UtfToExternalDString\fR converts a source buffer \fIsrc\fR from UTF-8
into the specified \fIencoding\fR. The converted bytes are stored in
\fIdstPtr\fR, which is then terminated with the appropriate encoding-specific
null. The caller should eventually call \fBTcl_DStringFree\fR to free any
information stored in \fIdstPtr\fR. When converting, if any of the
characters in the source buffer cannot be represented in the target
encoding, a default fallback character will be used. The return value is
a pointer to the value stored in the DString.
.PP
\fBTcl_UtfToExternal\fR converts a source buffer \fIsrc\fR from UTF-8 into
the specified \fIencoding\fR. Up to \fIsrcLen\fR bytes are converted from
the source buffer and up to \fIdstLen\fR converted bytes are stored in
\fIdst\fR. In all cases, \fI*srcReadPtr\fR is filled with the number of
bytes that were successfully converted from \fIsrc\fR and \fI*dstWrotePtr\fR
is filled with the corresponding number of bytes that were stored in
\fIdst\fR. The return values are the same as the return values for
\fBTcl_ExternalToUtf\fR.
.PP
\fBTcl_WinUtfToTChar\fR and \fBTcl_WinTCharToUtf\fR are
Windows-only convenience
functions for converting between UTF-8 and Windows strings. On Windows 95
(as with the Macintosh and Unix operating systems),
all strings exchanged between Tcl and the operating system are "char"
based. On Windows NT, some strings exchanged between Tcl and the
operating system are "char" oriented while others are in Unicode. By
convention, in Windows a TCHAR is a character in the ANSI code page
on Windows 95 and a Unicode character on Windows NT.
.PP
If you planned to use the same "char" based interfaces on both Windows
95 and Windows NT, you could use \fBTcl_UtfToExternal\fR and
\fBTcl_ExternalToUtf\fR (or their \fBTcl_DString\fR equivalents) with an
encoding of NULL (the current system encoding). On the other hand,
if you planned to use the Unicode interface when running on Windows NT
and the "char" interfaces when running on Windows 95, you would have
to perform the following type of test over and over in your program
(as represented in pseudo-code):
.CS
if (running NT) {
encoding <- Tcl_GetEncoding("unicode");
nativeBuffer <- Tcl_UtfToExternal(encoding, utfBuffer);
Tcl_FreeEncoding(encoding);
} else {
nativeBuffer <- Tcl_UtfToExternal(NULL, utfBuffer);
.CE
\fBTcl_WinUtfToTChar\fR and \fBTcl_WinTCharToUtf\fR automatically
handle this test and use the proper encoding based on the current
operating system. \fBTcl_WinUtfToTChar\fR returns a pointer to
a TCHAR string, and \fBTcl_WinTCharToUtf\fR expects a TCHAR string
pointer as the \fIsrc\fR string. Otherwise, these functions
behave identically to \fBTcl_UtfToExternalDString\fR and
\fBTcl_ExternalToUtfDString\fR.
.PP
\fBTcl_GetEncodingName\fR is roughly the inverse of \fBTcl_GetEncoding\fR.
Given an \fIencoding\fR, the return value is the \fIname\fR argument that
was used to create the encoding. The string returned by
\fBTcl_GetEncodingName\fR is only guaranteed to persist until the
\fIencoding\fR is deleted. The caller must not modify this string.
.PP
\fBTcl_SetSystemEncoding\fR sets the default encoding that should be used
whenever the user passes a NULL value for the \fIencoding\fR argument to
any of the other encoding functions. If \fIname\fR is NULL, the system
encoding is reset to the default system encoding, \fBbinary\fR. If the
name did not refer to any known or loadable encoding, TCL_ERROR is
returned and an error message is left in \fIinterp\fR. Otherwise, this
procedure increments the reference count of the new system encoding,
decrements the reference count of the old system encoding, and returns
TCL_OK.
.PP
\fBTcl_GetEncodingNames\fR sets the \fIinterp\fR result to a list
consisting of the names of all the encodings that are currently defined
or can be dynamically loaded, searching the encoding path specified by
\fBTcl_SetDefaultEncodingDir\fR. This procedure does not ensure that the
dynamically-loadable encoding files contain valid data, but merely that they
exist.
.PP
\fBTcl_CreateEncoding\fR defines a new encoding and registers the C
procedures that are called back to convert between the encoding and
UTF-8. Encodings created by \fBTcl_CreateEncoding\fR are thereafter
visible in the database used by \fBTcl_GetEncoding\fR. Just as with the
\fBTcl_GetEncoding\fR procedure, the return value is a token that
represents the encoding and can be used in subsequent calls to other
encoding functions. \fBTcl_CreateEncoding\fR returns an encoding with a
reference count of 1. If an encoding with the specified \fIname\fR
already exists, then its entry in the database is replaced with the new
encoding; the token for the old encoding will remain valid and continue
to behave as before, but users of the new token will now call the new
encoding procedures.
.PP
The \fItypePtr\fR argument to \fBTcl_CreateEncoding\fR contains information
about the name of the encoding and the procedures that will be called to
convert between this encoding and UTF-8. It is defined as follows:
.PP
.CS
typedef struct Tcl_EncodingType {
CONST char *\fIencodingName\fR;
Tcl_EncodingConvertProc *\fItoUtfProc\fR;
Tcl_EncodingConvertProc *\fIfromUtfProc\fR;
Tcl_EncodingFreeProc *\fIfreeProc\fR;
ClientData \fIclientData\fR;
int \fInullSize\fR;
} Tcl_EncodingType;
.CE
.PP
The \fIencodingName\fR provides a string name for the encoding, by
which it can be referred in other procedures such as
\fBTcl_GetEncoding\fR. The \fItoUtfProc\fR refers to a callback
procedure to invoke to convert text from this encoding into UTF-8.
The \fIfromUtfProc\fR refers to a callback procedure to invoke to
convert text from UTF-8 into this encoding. The \fIfreeProc\fR refers
to a callback procedure to invoke when this encoding is deleted. The
\fIfreeProc\fR field may be NULL. The \fIclientData\fR contains an
arbitrary one-word value passed to \fItoUtfProc\fR, \fIfromUtfProc\fR,
and \fIfreeProc\fR whenever they are called. Typically, this is a
pointer to a data structure containing encoding-specific information
that can be used by the callback procedures. For instance, two very
similar encodings such as \fBascii\fR and \fBmacRoman\fR may use the
same callback procedure, but use different values of \fIclientData\fR
to control its behavior. The \fInullSize\fR specifies the number of
zero bytes that signify end-of-string in this encoding. It must be
\fB1\fR (for single-byte or multi-byte encodings like ASCII or
Shift-JIS) or \fB2\fR (for double-byte encodings like Unicode).
Constant-sized encodings with 3 or more bytes per character (such as
CNS11643) are not accepted.
.PP
The callback procedures \fItoUtfProc\fR and \fIfromUtfProc\fR should match the
type \fBTcl_EncodingConvertProc\fR:
.PP
.CS
typedef int Tcl_EncodingConvertProc(
ClientData \fIclientData\fR,
CONST char *\fIsrc\fR,
int \fIsrcLen\fR,
int \fIflags\fR,
Tcl_Encoding *\fIstatePtr\fR,
char *\fIdst\fR,
int \fIdstLen\fR,
int *\fIsrcReadPtr\fR,
int *\fIdstWrotePtr\fR,
int *\fIdstCharsPtr\fR);
.CE
.PP
The \fItoUtfProc\fR and \fIfromUtfProc\fR procedures are called by the
\fBTcl_ExternalToUtf\fR or \fBTcl_UtfToExternal\fR family of functions to
perform the actual conversion. The \fIclientData\fR parameter to these
procedures is the same as the \fIclientData\fR field specified to
\fBTcl_CreateEncoding\fR when the encoding was created. The remaining
arguments to the callback procedures are the same as the arguments,
documented at the top, to \fBTcl_ExternalToUtf\fR or
\fBTcl_UtfToExternal\fR, with the following exceptions. If the
\fIsrcLen\fR argument to one of those high-level functions is negative,
the value passed to the callback procedure will be the appropriate
encoding-specific string length of \fIsrc\fR. If any of the \fIsrcReadPtr\fR,
\fIdstWrotePtr\fR, or \fIdstCharsPtr\fR arguments to one of the high-level
functions is NULL, the corresponding value passed to the callback
procedure will be a non-NULL location.
.PP
The callback procedure \fIfreeProc\fR, if non-NULL, should match the type
\fBTcl_EncodingFreeProc\fR:
.CS
typedef void Tcl_EncodingFreeProc(
ClientData \fIclientData\fR);
.CE
.PP
This \fIfreeProc\fR function is called when the encoding is deleted. The
\fIclientData\fR parameter is the same as the \fIclientData\fR field
specified to \fBTcl_CreateEncoding\fR when the encoding was created.
.PP
\fBTcl_GetDefaultEncodingDir\fR and \fBTcl_SetDefaultEncodingDir\fR
access and set the directory to use when locating the default encoding
files. If this value is not NULL, the \fBTclpInitLibraryPath\fR routine
appends the path to the head of the search path, and uses this path as
the first place to look into when trying to locate the encoding file.
.SH "ENCODING FILES"
Space would prohibit precompiling into Tcl every possible encoding
algorithm, so many encodings are stored on disk as dynamically-loadable
encoding files. This behavior also allows the user to create additional
encoding files that can be loaded using the same mechanism. These
encoding files contain information about the tables and/or escape
sequences used to map between an external encoding and Unicode. The
external encoding may consist of single-byte, multi-byte, or double-byte
characters.
.PP
Each dynamically-loadable encoding is represented as a text file. The
initial line of the file, beginning with a ``#'' symbol, is a comment
that provides a human-readable description of the file. The next line
identifies the type of encoding file. It can be one of the following
letters:
.IP "[1] \fBS\fR"
A single-byte encoding, where one character is always one byte long in the
encoding. An example is \fBiso8859-1\fR, used by many European languages.
.IP "[2] \fBD\fR"
A double-byte encoding, where one character is always two bytes long in the
encoding. An example is \fBbig5\fR, used for Chinese text.
.IP "[3] \fBM\fR"
A multi-byte encoding, where one character may be either one or two bytes long.
Certain bytes are a lead bytes, indicating that another byte must follow
and that together the two bytes represent one character. Other bytes are not
lead bytes and represent themselves. An example is \fBshiftjis\fR, used by
many Japanese computers.
.IP "[4] \fBE\fR"
An escape-sequence encoding, specifying that certain sequences of bytes
do not represent characters, but commands that describe how following bytes
should be interpreted.
.PP
The rest of the lines in the file depend on the type.
.PP
Cases [1], [2], and [3] are collectively referred to as table-based encoding
files. The lines in a table-based encoding file are in the same
format as this example taken from the \fBshiftjis\fR encoding (this is not
the complete file):
.CS
# Encoding file: shiftjis, multi-byte
M
003F 0 40
00
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
0030003100320033003400350036003700380039003A003B003C003D003E003F
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D203E007F
0080000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F
FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F
FF80FF81FF82FF83FF84FF85FF86FF87FF88FF89FF8AFF8BFF8CFF8DFF8EFF8F
FF90FF91FF92FF93FF94FF95FF96FF97FF98FF99FF9AFF9BFF9CFF9DFF9EFF9F
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
81
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
300030013002FF0CFF0E30FBFF1AFF1BFF1FFF01309B309C00B4FF4000A8FF3E
FFE3FF3F30FD30FE309D309E30034EDD30053006300730FC20152010FF0F005C
301C2016FF5C2026202520182019201C201DFF08FF0930143015FF3BFF3DFF5B
FF5D30083009300A300B300C300D300E300F30103011FF0B221200B100D70000
00F7FF1D2260FF1CFF1E22662267221E22342642264000B0203220332103FFE5
FF0400A200A3FF05FF03FF06FF0AFF2000A72606260525CB25CF25CE25C725C6
25A125A025B325B225BD25BC203B301221922190219121933013000000000000
000000000000000000000000000000002208220B2286228722822283222A2229
000000000000000000000000000000002227222800AC21D221D4220022030000
0000000000000000000000000000000000000000222022A52312220222072261
2252226A226B221A223D221D2235222B222C0000000000000000000000000000
212B2030266F266D266A2020202100B6000000000000000025EF000000000000
.CE
.PP
The third line of the file is three numbers. The first number is the
fallback character (in base 16) to use when converting from UTF-8 to this
encoding. The second number is a \fB1\fR if this file represents the
encoding for a symbol font, or \fB0\fR otherwise. The last number (in base
10) is how many pages of data follow.
.PP
Subsequent lines in the example above are pages that describe how to map
from the encoding into 2-byte Unicode. The first line in a page identifies
the page number. Following it are 256 double-byte numbers, arranged as 16
rows of 16 numbers. Given a character in the encoding, the high byte of
that character is used to select which page, and the low byte of that
character is used as an index to select one of the double-byte numbers in
that page \- the value obtained being the corresponding Unicode character.
By examination of the example above, one can see that the characters 0x7E
and 0x8163 in \fBshiftjis\fR map to 203E and 2026 in Unicode, respectively.
.PP
Following the first page will be all the other pages, each in the same
format as the first: one number identifying the page followed by 256
double-byte Unicode characters. If a character in the encoding maps to the
Unicode character 0000, it means that the character doesn't actually exist.
If all characters on a page would map to 0000, that page can be omitted.
.PP
Case [4] is the escape-sequence encoding file. The lines in an this type of
file are in the same format as this example taken from the \fBiso2022-jp\fR
encoding:
.CS
.ta 1.5i
# Encoding file: iso2022-jp, escape-driven
E
init {}
final {}
iso8859-1 \\x1b(B
jis0201 \\x1b(J
jis0208 \\x1b$@
jis0208 \\x1b$B
jis0212 \\x1b$(D
gb2312 \\x1b$A
ksc5601 \\x1b$(C
.CE
.PP
In the file, the first column represents an option and the second column
is the associated value. \fBinit\fR is a string to emit or expect before
the first character is converted, while \fBfinal\fR is a string to emit
or expect after the last character. All other options are names of
table-based encodings; the associated value is the escape-sequence that
marks that encoding. Tcl syntax is used for the values; in the above
example, for instance, ``\fB{}\fR'' represents the empty string and
``\fB\\x1b\fR'' represents character 27.
.PP
When \fBTcl_GetEncoding\fR encounters an encoding \fIname\fR that has not
been loaded, it attempts to load an encoding file called \fIname\fB.enc\fR
from the \fBencoding\fR subdirectory of each directory specified in the
library path \fB$tcl_libPath\fR. If the encoding file exists, but is
malformed, an error message will be left in \fIinterp\fR.
.SH KEYWORDS
utf, encoding, convert
tcl8.4.20/doc/lappend.n 0000644 0036047 0045461 00000002740 11737050674 013271 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH lappend n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
lappend \- Append list elements onto a variable
.SH SYNOPSIS
\fBlappend \fIvarName \fR?\fIvalue value value ...\fR?
.BE
.SH DESCRIPTION
.PP
This command treats the variable given by \fIvarName\fR as a list
and appends each of the \fIvalue\fR arguments to that list as a separate
element, with spaces between elements.
If \fIvarName\fR doesn't exist, it is created as a list with elements
given by the \fIvalue\fR arguments.
\fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs
are appended as list elements rather than raw text.
This command provides a relatively efficient way to build up
large lists. For example, ``\fBlappend a $b\fR'' is much
more efficient than ``\fBset a [concat $a [list $b]]\fR'' when
\fB$a\fR is long.
.SH EXAMPLE
Using \fBlappend\fR to build up a list of numbers.
.CS
% set var 1
1
% \fBlappend\fR var 2
1 2
% \fBlappend\fR var 3 4 5
1 2 3 4 5
.CE
.SH "SEE ALSO"
list(n), lindex(n), linsert(n), llength(n),
.VS 8.4
lset(n)
.VE
lsort(n), lrange(n)
.SH KEYWORDS
append, element, list, variable
tcl8.4.20/doc/Async.3 0000644 0036047 0045461 00000015132 11737050674 012627 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady \- handle asynchronous events
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_AsyncHandler
\fBTcl_AsyncCreate\fR(\fIproc, clientData\fR)
.sp
\fBTcl_AsyncMark\fR(\fIasync\fR)
.sp
int
\fBTcl_AsyncInvoke\fR(\fIinterp, code\fR)
.sp
\fBTcl_AsyncDelete\fR(\fIasync\fR)
.sp
int
\fBTcl_AsyncReady\fR()
.SH ARGUMENTS
.AS Tcl_AsyncHandler clientData
.AP Tcl_AsyncProc *proc in
Procedure to invoke to handle an asynchronous event.
.AP ClientData clientData in
One-word value to pass to \fIproc\fR.
.AP Tcl_AsyncHandler async in
Token for asynchronous event handler.
.AP Tcl_Interp *interp in
Tcl interpreter in which command was being evaluated when handler was
invoked, or NULL if handler was invoked when there was no interpreter
active.
.AP int code in
Completion code from command that just completed in \fIinterp\fR,
or 0 if \fIinterp\fR is NULL.
.BE
.SH DESCRIPTION
.PP
These procedures provide a safe mechanism for dealing with
asynchronous events such as signals.
If an event such as a signal occurs while a Tcl script is being
evaluated then it isn't safe to take any substantive action to
process the event.
For example, it isn't safe to evaluate a Tcl script since the
interpreter may already be in the middle of evaluating a script;
it may not even be safe to allocate memory, since a memory
allocation could have been in progress when the event occurred.
The only safe approach is to set a flag indicating that the event
occurred, then handle the event later when the world has returned
to a clean state, such as after the current Tcl command completes.
.PP
\fBTcl_AsyncCreate\fR, \fBTcl_AsyncDelete\fR, and \fBTcl_AsyncReady\fR
are thread sensitive. They access and/or set a thread-specific data
structure in the event of a core built with \fI\-\-enable\-threads\fR. The token
created by \fBTcl_AsyncCreate\fR contains the needed thread information it
was called from so that calling \fBTcl_AsyncMark\fR(\fItoken\fR) will only yield
the origin thread into the asynchronous handler.
.PP
\fBTcl_AsyncCreate\fR creates an asynchronous handler and returns
a token for it.
The asynchronous handler must be created before
any occurrences of the asynchronous event that it is intended
to handle (it is not safe to create a handler at the time of
an event).
When an asynchronous event occurs the code that detects the event
(such as a signal handler) should call \fBTcl_AsyncMark\fR with the
token for the handler.
\fBTcl_AsyncMark\fR will mark the handler as ready to execute, but it
will not invoke the handler immediately.
Tcl will call the \fIproc\fR associated with the handler later, when
the world is in a safe state, and \fIproc\fR can then carry out
the actions associated with the asynchronous event.
\fIProc\fR should have arguments and result that match the
type \fBTcl_AsyncProc\fR:
.CS
typedef int Tcl_AsyncProc(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIcode\fR);
.CE
The \fIclientData\fR will be the same as the \fIclientData\fR
argument passed to \fBTcl_AsyncCreate\fR when the handler was
created.
If \fIproc\fR is invoked just after a command has completed
execution in an interpreter, then \fIinterp\fR will identify
the interpreter in which the command was evaluated and
\fIcode\fR will be the completion code returned by that
command.
The command's result will be present in the interpreter's result.
When \fIproc\fR returns, whatever it leaves in the interpreter's result
will be returned as the result of the command and the integer
value returned by \fIproc\fR will be used as the new completion
code for the command.
.PP
It is also possible for \fIproc\fR to be invoked when no interpreter
is active.
This can happen, for example, if an asynchronous event occurs while
the application is waiting for interactive input or an X event.
In this case \fIinterp\fR will be NULL and \fIcode\fR will be
0, and the return value from \fIproc\fR will be ignored.
.PP
The procedure \fBTcl_AsyncInvoke\fR is called to invoke all of the
handlers that are ready.
The procedure \fBTcl_AsyncReady\fR will return non-zero whenever any
asynchronous handlers are ready; it can be checked to avoid calls
to \fBTcl_AsyncInvoke\fR when there are no ready handlers.
Tcl calls \fBTcl_AsyncReady\fR after each command is evaluated
and calls \fBTcl_AsyncInvoke\fR if needed.
Applications may also call \fBTcl_AsyncInvoke\fR at interesting
times for that application.
For example, Tcl's event handler calls \fBTcl_AsyncReady\fR
after each event and calls \fBTcl_AsyncInvoke\fR if needed.
The \fIinterp\fR and \fIcode\fR arguments to \fBTcl_AsyncInvoke\fR
have the same meaning as for \fIproc\fR: they identify the active
interpreter, if any, and the completion code from the command
that just completed.
.PP
\fBTcl_AsyncDelete\fR removes an asynchronous handler so that
its \fIproc\fR will never be invoked again.
A handler can be deleted even when ready, and it will still
not be invoked.
.PP
If multiple handlers become active at the same time, the
handlers are invoked in the order they were created (oldest
handler first).
The \fIcode\fR and the interpreter's result for later handlers
reflect the values returned by earlier handlers, so that
the most recently created handler has last say about
the interpreter's result and completion code.
If new handlers become ready while handlers are executing,
\fBTcl_AsyncInvoke\fR will invoke them all; at each point it
invokes the highest-priority (oldest) ready handler, repeating
this over and over until there are no longer any ready handlers.
.SH WARNING
.PP
It is almost always a bad idea for an asynchronous event
handler to modify the interpreter's result or return a code different
from its \fIcode\fR argument.
This sort of behavior can disrupt the execution of scripts in
subtle ways and result in bugs that are extremely difficult
to track down.
If an asynchronous event handler needs to evaluate Tcl scripts
then it should first save the interpreter's result plus the values
of the variables \fBerrorInfo\fR and \fBerrorCode\fR (this can
be done, for example, by storing them in dynamic strings).
When the asynchronous handler is finished it should restore
the interpreter's result, \fBerrorInfo\fR, and \fBerrorCode\fR,
and return the \fIcode\fR argument.
.SH KEYWORDS
asynchronous event, handler, signal
tcl8.4.20/doc/lset.n 0000755 0036047 0045461 00000007442 11737050674 012624 0 ustar dgp 771div '\"
'\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH lset n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
lset \- Change an element in a list
.SH SYNOPSIS
\fBlset \fIvarName ?index...? newValue\fR
.BE
.SH DESCRIPTION
.PP
The \fBlset\fR command accepts a parameter, \fIvarName\fR, which
it interprets as the name of a variable containing a Tcl list.
It also accepts zero or more \fIindices\fR into
the list. The indices may be presented either consecutively on the
command line, or grouped in a
Tcl list and presented as a single argument.
Finally, it accepts a new value for an element of \fIvarName\fR.
.PP
If no indices are presented, the command takes the form:
.CS
lset varName newValue
.CE
or
.CS
lset varName {} newValue
.CE
In this case, \fInewValue\fR replaces the old value of the variable
\fIvarName\fR.
.PP
When presented with a single index, the \fBlset\fR command
treats the content of the \fIvarName\fR variable as a Tcl list.
It addresses the \fIindex\fR'th element in it
(0 refers to the first element of the list).
When interpreting the list, \fBlset\fR observes the same rules
concerning braces and quotes and backslashes as the Tcl command
interpreter; however, variable
substitution and command substitution do not occur.
The command constructs a new list in which the designated element is
replaced with \fInewValue\fR. This new list is stored in the
variable \fIvarName\fR, and is also the return value from the \fBlset\fR
command.
.PP
If \fIindex\fR is negative or greater than or equal to the number
of elements in \fI$varName\fR, then an error occurs.
.PP
If \fIindex\fR has the value \fBend\fR, it refers to the last element
in the list, and \fBend\-\fIinteger\fR refers to the last element in
the list minus the specified integer offset.
.PP
If additional \fIindex\fR arguments are supplied, then each argument is
used in turn to address an element within a sublist designated
by the previous indexing operation,
allowing the script to alter elements in sublists. The command,
.CS
lset a 1 2 newValue
.CE
or
.CS
lset a {1 2} newValue
.CE
replaces element 2 of sublist 1 with \fInewValue\fR.
.PP
The integer appearing in each \fIindex\fR argument must be greater
than or equal to zero. The integer appearing in each \fIindex\fR
argument must be strictly less than the length of the corresponding
list. In other words, the \fBlset\fR command cannot change the size
of a list. If an index is outside the permitted range, an error is reported.
.SH EXAMPLES
In each of these examples, the initial value of \fIx\fR is:
.CS
set x [list [list a b c] [list d e f] [list g h i]]
=> {a b c} {d e f} {g h i}
.CE
The indicated return value also becomes the new value of \fIx\fR
(except in the last case, which is an error which leaves the value of
\fIx\fR unchanged.)
.CS
lset x {j k l} => j k l
lset x {} {j k l} => j k l
lset x 0 j => j {d e f} {g h i}
lset x 2 j => {a b c} {d e f} j
lset x end j => {a b c} {d e f} j
lset x end-1 j => {a b c} j {g h i}
lset x 2 1 j => {a b c} {d e f} {g j i}
lset x {2 1} j => {a b c} {d e f} {g j i}
lset x {2 3} j => \fIlist index out of range\fR
.CE
In the following examples, the initial value of \fIx\fR is:
.CS
set x [list [list [list a b] [list c d]] \e
[list [list e f] [list g h]]]
=> {{a b} {c d}} {{e f} {g h}}
.CE
The indicated return value also becomes the new value of \fIx\fR.
.CS
lset x 1 1 0 j => {{a b} {c d}} {{e f} {j h}}
lset x {1 1 0} j => {{a b} {c d}} {{e f} {j h}}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lsort(n), lrange(n), lreplace(n)
.SH KEYWORDS
element, index, list, replace, set
tcl8.4.20/doc/lreplace.n 0000644 0036047 0045461 00000004574 11737050674 013444 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH lreplace n 7.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
lreplace \- Replace elements in a list with new elements
.SH SYNOPSIS
\fBlreplace \fIlist first last \fR?\fIelement element ...\fR?
.BE
.SH DESCRIPTION
.PP
\fBlreplace\fR returns a new list formed by replacing one or more elements of
\fIlist\fR with the \fIelement\fR arguments.
\fIfirst\fR and \fIlast\fR specify the first and last index of the
range of elements to replace. 0 refers to the first element of the
list, and \fBend\fR (or any abbreviation of it) may be used to refer
to the last element of the list. If \fIlist\fR is empty, then
\fIfirst\fR and \fIlast\fR are ignored.
If \fIfirst\fR is less than zero, it is considered to refer to the
first element of the list. For non-empty lists, the element indicated
by \fIfirst\fR must exist.
If \fIlast\fR is less than zero but greater than \fIfirst\fR, then any
specified elements will be prepended to the list. If \fIlast\fR is
less than \fIfirst\fR then no elements are deleted; the new elements
are simply inserted before \fIfirst\fR.
The \fIelement\fR arguments specify zero or more new arguments to
be added to the list in place of those that were deleted.
Each \fIelement\fR argument will become a separate element of
the list. If no \fIelement\fR arguments are specified, then the elements
between \fIfirst\fR and \fIlast\fR are simply deleted. If \fIlist\fR
is empty, any \fIelement\fR arguments are added to the end of the list.
.SH EXAMPLES
Replacing an element of a list with another:
.CS
% \fBlreplace\fR {a b c d e} 1 1 foo
a foo c d e
.CE
.PP
Replacing two elements of a list with three:
.CS
% \fBlreplace\fR {a b c d e} 1 2 three more elements
a three more elements d e
.CE
.PP
Deleting the last element from a list in a variable:
.CS
% set var {a b c d e}
a b c d e
% set var [\fBlreplace\fR $var end end]
a b c d
.CE
.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lset(n), lrange(n), lsort(n)
.VE
.SH KEYWORDS
element, list, replace
tcl8.4.20/doc/exit.n 0000644 0036047 0045461 00000002503 11737050674 012614 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH exit n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
exit \- End the application
.SH SYNOPSIS
\fBexit \fR?\fIreturnCode\fR?
.BE
.SH DESCRIPTION
.PP
Terminate the process, returning \fIreturnCode\fR to the
system as the exit status.
If \fIreturnCode\fR isn't specified then it defaults
to 0.
.SH EXAMPLE
Since non-zero exit codes are usually interpreted as error cases by
the calling process, the \fBexit\fR command is an important part of
signalling that something fatal has gone wrong. This code fragment is
useful in scripts to act as a general problem trap:
.CS
proc main {} {
# ... put the real main code in here ...
}
if {[catch {main} msg]} {
puts stderr "unexpected script error: $msg"
if {[info exist env(DEBUG)]} {
puts stderr "---- BEGIN TRACE ----"
puts stderr $errorInfo
puts stderr "---- END TRACE ----"
}
# Reserve code 1 for "expected" error exits...
\fBexit\fR 2
}
.CE
.SH "SEE ALSO"
exec(n), tclvars(n)
.SH KEYWORDS
exit, process
tcl8.4.20/doc/while.n 0000644 0036047 0045461 00000004240 11737050674 012753 0 ustar dgp 771div '\"
'\" Copyright (c) 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.
'\"
.so man.macros
.TH while n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
while \- Execute script repeatedly as long as a condition is met
.SH SYNOPSIS
\fBwhile \fItest body\fR
.BE
.SH DESCRIPTION
.PP
The \fBwhile\fR command evaluates \fItest\fR as an expression
(in the same way that \fBexpr\fR evaluates its argument).
The value of the expression must a proper boolean
value; if it is a true value
then \fIbody\fR is executed by passing it to the Tcl interpreter.
Once \fIbody\fR has been executed then \fItest\fR is evaluated
again, and the process repeats until eventually \fItest\fR
evaluates to a false boolean value. \fBContinue\fR
commands may be executed inside \fIbody\fR to terminate the current
iteration of the loop, and \fBbreak\fR
commands may be executed inside \fIbody\fR to cause immediate
termination of the \fBwhile\fR command. The \fBwhile\fR command
always returns an empty string.
.PP
Note: \fItest\fR should almost always be enclosed in braces. If not,
variable substitutions will be made before the \fBwhile\fR
command starts executing, which means that variable changes
made by the loop body will not be considered in the expression.
This is likely to result in an infinite loop. If \fItest\fR is
enclosed in braces, variable substitutions are delayed until the
expression is evaluated (before
each loop iteration), so changes in the variables will be visible.
For an example, try the following script with and without the braces
around \fB$x<10\fR:
.CS
set x 0
\fBwhile\fR {$x<10} {
puts "x is $x"
incr x
}
.CE
.SH EXAMPLE
Read lines from a channel until we get to the end of the stream, and
print them out with a line-number prepended:
.CS
set lineCount 0
\fBwhile\fR {[gets $chan line] >= 0} {
puts "[incr lineCount]: $line"
}
.CE
.SH "SEE ALSO"
break(n), continue(n), for(n), foreach(n)
.SH KEYWORDS
boolean value, loop, test, while
tcl8.4.20/doc/format.n 0000644 0036047 0045461 00000024211 11737050674 013133 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH format n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
format \- Format a string in the style of sprintf
.SH SYNOPSIS
\fBformat \fIformatString \fR?\fIarg arg ...\fR?
.BE
.SH INTRODUCTION
.PP
This command generates a formatted string in the same way as the
ANSI C \fBsprintf\fR procedure (it uses \fBsprintf\fR in its
implementation).
\fIFormatString\fR indicates how to format the result, using
\fB%\fR conversion specifiers as in \fBsprintf\fR, and the additional
arguments, if any, provide values to be substituted into the result.
The return value from \fBformat\fR is the formatted string.
.SH "DETAILS ON FORMATTING"
.PP
The command operates by scanning \fIformatString\fR from left to right.
Each character from the format string is appended to the result
string unless it is a percent sign.
If the character is a \fB%\fR then it is not copied to the result string.
Instead, the characters following the \fB%\fR character are treated as
a conversion specifier.
The conversion specifier controls the conversion of the next successive
\fIarg\fR to a particular format and the result is appended to
the result string in place of the conversion specifier.
If there are multiple conversion specifiers in the format string,
then each one controls the conversion of one additional \fIarg\fR.
The \fBformat\fR command must be given enough \fIarg\fRs to meet the needs
of all of the conversion specifiers in \fIformatString\fR.
.PP
Each conversion specifier may contain up to six different parts:
an XPG3 position specifier,
a set of flags, a minimum field width, a precision, a length modifier,
and a conversion character.
Any of these fields may be omitted except for the conversion character.
The fields that are present must appear in the order given above.
The paragraphs below discuss each of these fields in turn.
.PP
If the \fB%\fR is followed by a decimal number and a \fB$\fR, as in
``\fB%2$d\fR'', then the value to convert is not taken from the
next sequential argument.
Instead, it is taken from the argument indicated by the number,
where 1 corresponds to the first \fIarg\fR.
If the conversion specifier requires multiple arguments because
of \fB*\fR characters in the specifier then
successive arguments are used, starting with the argument
given by the number.
This follows the XPG3 conventions for positional specifiers.
If there are any positional specifiers in \fIformatString\fR
then all of the specifiers must be positional.
.PP
The second portion of a conversion specifier may contain any of the
following flag characters, in any order:
.TP 10
\fB\-\fR
Specifies that the converted argument should be left-justified
in its field (numbers are normally right-justified with leading
spaces if needed).
.TP 10
\fB+\fR
Specifies that a number should always be printed with a sign,
even if positive.
.TP 10
\fIspace\fR
Specifies that a space should be added to the beginning of the
number if the first character isn't a sign.
.TP 10
\fB0\fR
Specifies that the number should be padded on the left with
zeroes instead of spaces.
.TP 10
\fB#\fR
Requests an alternate output form. For \fBo\fR and \fBO\fR
conversions it guarantees that the first digit is always \fB0\fR.
For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively)
will be added to the beginning of the result unless it is zero.
For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR,
\fBg\fR, and \fBG\fR) it guarantees that the result always
has a decimal point.
For \fBg\fR and \fBG\fR conversions it specifies that
trailing zeroes should not be removed.
.PP
The third portion of a conversion specifier is a number giving a
minimum field width for this conversion.
It is typically used to make columns line up in tabular printouts.
If the converted argument contains fewer characters than the
minimum field width then it will be padded so that it is as wide
as the minimum field width.
Padding normally occurs by adding extra spaces on the left of the
converted argument, but the \fB0\fR and \fB\-\fR flags
may be used to specify padding with zeroes on the left or with
spaces on the right, respectively.
If the minimum field width is specified as \fB*\fR rather than
a number, then the next argument to the \fBformat\fR command
determines the minimum field width; it must be a numeric string.
.PP
The fourth portion of a conversion specifier is a precision,
which consists of a period followed by a number.
The number is used in different ways for different conversions.
For \fBe\fR, \fBE\fR, and \fBf\fR conversions it specifies the number
of digits to appear to the right of the decimal point.
For \fBg\fR and \fBG\fR conversions it specifies the total number
of digits to appear, including those on both sides of the decimal
point (however, trailing zeroes after the decimal point will still
be omitted unless the \fB#\fR flag has been specified).
For integer conversions, it specifies a minimum number of digits
to print (leading zeroes will be added if necessary).
For \fBs\fR conversions it specifies the maximum number of characters to be
printed; if the string is longer than this then the trailing characters will be dropped.
If the precision is specified with \fB*\fR rather than a number
then the next argument to the \fBformat\fR command determines the precision;
it must be a numeric string.
.PP
The fifth part of a conversion specifier is a length modifier,
which must be \fBh\fR or \fBl\fR.
If it is \fBh\fR it specifies that the numeric value should be
truncated to a 16-bit value before converting.
This option is rarely useful.
.VS 8.4
If it is \fBl\fR it specifies that the numeric value should be (at
least) a 64-bit value. If neither \fBh\fR nor \fBl\fR are present,
numeric values are interpreted as being values of the width of the
native machine word, as described by \fBtcl_platform(wordSize)\fR.
.VE
.PP
The last thing in a conversion specifier is an alphabetic character
that determines what kind of conversion to perform.
The following conversion characters are currently supported:
.TP 10
\fBd\fR
Convert integer to signed decimal string.
.TP 10
\fBu\fR
Convert integer to unsigned decimal string.
.TP 10
\fBi\fR
Convert integer to signed decimal string; the integer may either be
in decimal, in octal (with a leading \fB0\fR) or in hexadecimal
(with a leading \fB0x\fR).
.TP 10
\fBo\fR
Convert integer to unsigned octal string.
.TP 10
\fBx\fR or \fBX\fR
Convert integer to unsigned hexadecimal string, using digits
``0123456789abcdef'' for \fBx\fR and ``0123456789ABCDEF'' for \fBX\fR).
.VS
.TP 10
\fBc\fR
Convert integer to the Unicode character it represents.
.VE
.TP 10
\fBs\fR
No conversion; just insert string.
.TP 10
\fBf\fR
Convert floating-point number to signed decimal string of
the form \fIxx.yyy\fR, where the number of \fIy\fR's is determined by
the precision (default: 6).
If the precision is 0 then no decimal point is output.
.TP 10
\fBe\fR or \fBe\fR
Convert floating-point number to scientific notation in the
form \fIx.yyy\fBe\(+-\fIzz\fR, where the number of \fIy\fR's is determined
by the precision (default: 6).
If the precision is 0 then no decimal point is output.
If the \fBE\fR form is used then \fBE\fR is
printed instead of \fBe\fR.
.TP 10
\fBg\fR or \fBG\fR
If the exponent is less than \-4 or greater than or equal to the
precision, then convert floating-point number as for \fB%e\fR or
\fB%E\fR.
Otherwise convert as for \fB%f\fR.
Trailing zeroes and a trailing decimal point are omitted.
.TP 10
\fB%\fR
No conversion: just insert \fB%\fR.
.LP
For the numerical conversions the argument being converted must
be an integer or floating-point string; format converts the argument
to binary and then converts it back to a string according to
the conversion specifier.
.SH "DIFFERENCES FROM ANSI SPRINTF"
.PP
The behavior of the format command is the same as the
ANSI C \fBsprintf\fR procedure except for the following
differences:
.IP [1]
\fB%p\fR and \fB%n\fR specifiers are not currently supported.
.IP [2]
For \fB%c\fR conversions the argument must be a decimal string,
which will then be converted to the corresponding character value.
.IP [3]
The \fBl\fR modifier
.VS 8.4
is ignored for real values and on 64-bit platforms, which are always
converted as if the \fBl\fR modifier were present (i.e. the types
\fBdouble\fR and \fBlong\fR are used for the internal representation
of real and integer values, respectively).
.VE 8.4
If the \fBh\fR modifier is specified then integer values are truncated
to \fBshort\fR before conversion. Both \fBh\fR and \fBl\fR modifiers
are ignored on all other conversions.
.SH EXAMPLES
Convert the output of \fBtime\fR into seconds to an accuracy of
hundredths of a second:
.CS
set us [lindex [time $someTclCode] 0]
puts [\fBformat\fR "%.2f seconds to execute" [expr {$us / 1e6}]]
.CE
.PP
Create a packed X11 literal color specification:
.CS
# Each color-component should be in range (0..255)
set color [\fBformat\fR "#%02x%02x%02x" $r $g $b]
.CE
.PP
Use XPG3 format codes to allow reordering of fields (a technique that
is often used in localized message catalogs; see \fBmsgcat\fR) without
reordering the data values passed to \fBformat\fR:
.CS
set fmt1 "Today, %d shares in %s were bought at $%.2f each"
puts [\fBformat\fR $fmt1 123 "Global BigCorp" 19.37]
set fmt2 "Bought %2\\$s equity ($%3$.2f x %1\\$d) today"
puts [\fBformat\fR $fmt2 123 "Global BigCorp" 19.37]
.CE
.PP
Print a small table of powers of three:
.CS
# Set up the column widths
set w1 5
set w2 10
# Make a nice header (with separator) for the table first
set sep +-[string repeat - $w1]-+-[string repeat - $w2]-+
puts $sep
puts [\fBformat\fR "| %-*s | %-*s |" $w1 "Index" $w2 "Power"]
puts $sep
# Print the contents of the table
set p 1
for {set i 0} {$i<=20} {incr i} {
puts [\fBformat\fR "| %*d | %*ld |" $w1 $i $w2 $p]
set p [expr {wide($p) * 3}]
}
# Finish off by printing the separator again
puts $sep
.CE
.SH "SEE ALSO"
scan(n), sprintf(3), string(n)
.SH KEYWORDS
conversion specifier, format, sprintf, string, substitution
tcl8.4.20/doc/LinkVar.3 0000644 0036047 0045461 00000011141 11737050674 013114 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR)
.sp
\fBTcl_UnlinkVar\fR(\fIinterp, varName\fR)
.sp
\fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR)
.SH ARGUMENTS
.AS Tcl_Interp writable
.AP Tcl_Interp *interp in
Interpreter that contains \fIvarName\fR.
Also used by \fBTcl_LinkVar\fR to return error messages.
.AP "CONST char" *varName in
Name of global variable.
.AP char *addr in
Address of C variable that is to be linked to \fIvarName\fR.
.AP int type in
Type of C variable. Must be one of TCL_LINK_INT, TCL_LINK_DOUBLE,
.VS 8.4
TCL_LINK_WIDE_INT,
.VE 8.4
TCL_LINK_BOOLEAN, or TCL_LINK_STRING, optionally OR'ed with
TCL_LINK_READ_ONLY to make Tcl variable read-only.
.BE
.SH DESCRIPTION
.PP
\fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable
named by \fIvarName\fR in sync with the C variable at the address
given by \fIaddr\fR.
Whenever the Tcl variable is read the value of the C variable will
be returned, and whenever the Tcl variable is written the C
variable will be updated to have the same value.
\fBTcl_LinkVar\fR normally returns TCL_OK; if an error occurs
while setting up the link (e.g. because \fIvarName\fR is the
name of array) then TCL_ERROR is returned and the interpreter's result
contains an error message.
.PP
The \fItype\fR argument specifies the type of the C variable,
and must have one of the following values, optionally OR'ed with
TCL_LINK_READ_ONLY:
.TP
\fBTCL_LINK_INT\fR
The C variable is of type \fBint\fR.
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write
non-integer values into \fIvarName\fR will be rejected with
Tcl errors.
.TP
\fBTCL_LINK_DOUBLE\fR
The C variable is of type \fBdouble\fR.
Any value written into the Tcl variable must have a proper real
form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write
non-real values into \fIvarName\fR will be rejected with
Tcl errors.
.TP
\fBTCL_LINK_WIDE_INT\fR
.VS 8.4
The C variable is of type \fBTcl_WideInt\fR (which is an integer type
at least 64-bits wide on all platforms that can support it.)
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write
non-integer values into \fIvarName\fR will be rejected with
Tcl errors.
.VE 8.4
.TP
\fBTCL_LINK_BOOLEAN\fR
The C variable is of type \fBint\fR.
If its value is zero then it will read from Tcl as ``0'';
otherwise it will read from Tcl as ``1''.
Whenever \fIvarName\fR is
modified, the C variable will be set to a 0 or 1 value.
Any value written into the Tcl variable must have a proper boolean
form acceptable to \fBTcl_GetBooleanFromObj\fR; attempts to write
non-boolean values into \fIvarName\fR will be rejected with
Tcl errors.
.TP
\fBTCL_LINK_STRING\fR
The C variable is of type \fBchar *\fR.
.VS
If its value is not NULL then it must be a pointer to a string
allocated with \fBTcl_Alloc\fR or \fBckalloc\fR.
.VE
Whenever the Tcl variable is modified the current C string will be
freed and new memory will be allocated to hold a copy of the variable's
new value.
If the C variable contains a NULL pointer then the Tcl variable
will read as ``NULL''.
.PP
If the TCL_LINK_READ_ONLY flag is present in \fItype\fR then the
variable will be read-only from Tcl, so that its value can only be
changed by modifying the C variable.
Attempts to write the variable from Tcl will be rejected with errors.
.PP
\fBTcl_UnlinkVar\fR removes the link previously set up for the
variable given by \fIvarName\fR. If there does not exist a link
for \fIvarName\fR then the procedure has no effect.
.PP
\fBTcl_UpdateLinkedVar\fR may be invoked after the C variable has
changed to force the Tcl variable to be updated immediately.
In many cases this procedure is not needed, since any attempt to
read the Tcl variable will return the latest value of the C variable.
However, if a trace has been set on the Tcl variable (such as a
Tk widget that wishes to display the value of the variable), the
trace will not trigger when the C variable has changed.
\fBTcl_UpdateLinkedVar\fR ensures that any traces on the Tcl
variable are invoked.
.SH KEYWORDS
boolean, integer, link, read-only, real, string, traces, variable
tcl8.4.20/doc/SetVar.3 0000644 0036047 0045461 00000024127 11737050674 012762 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-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.
'\"
.so man.macros
.TH Tcl_SetVar 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetVar2Ex, Tcl_SetVar, Tcl_SetVar2, Tcl_ObjSetVar2, Tcl_GetVar2Ex, Tcl_GetVar, Tcl_GetVar2, Tcl_ObjGetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
.VS 8.1
Tcl_Obj *
\fBTcl_SetVar2Ex\fR(\fIinterp, name1, name2, newValuePtr, flags\fR)
.VE
.sp
CONST char *
\fBTcl_SetVar\fR(\fIinterp, varName, newValue, flags\fR)
.sp
CONST char *
\fBTcl_SetVar2\fR(\fIinterp, name1, name2, newValue, flags\fR)
.sp
Tcl_Obj *
\fBTcl_ObjSetVar2\fR(\fIinterp, part1Ptr, part2Ptr, newValuePtr, flags\fR)
.sp
.VS 8.1
Tcl_Obj *
\fBTcl_GetVar2Ex\fR(\fIinterp, name1, name2, flags\fR)
.VE
.sp
CONST char *
\fBTcl_GetVar\fR(\fIinterp, varName, flags\fR)
.sp
CONST char *
\fBTcl_GetVar2\fR(\fIinterp, name1, name2, flags\fR)
.sp
Tcl_Obj *
\fBTcl_ObjGetVar2\fR(\fIinterp, part1Ptr, part2Ptr, flags\fR)
.sp
int
\fBTcl_UnsetVar\fR(\fIinterp, varName, flags\fR)
.sp
int
\fBTcl_UnsetVar2\fR(\fIinterp, name1, name2, flags\fR)
.SH ARGUMENTS
.AS Tcl_Interp *newValuePtr
.AP Tcl_Interp *interp in
Interpreter containing variable.
.AP "CONST char" *name1 in
Contains the name of an array variable (if \fIname2\fR is non-NULL)
or (if \fIname2\fR is NULL) either the name of a scalar variable
or a complete name including both variable name and index.
May include \fB::\fR namespace qualifiers
to specify a variable in a particular namespace.
.AP "CONST char" *name2 in
If non-NULL, gives name of element within array; in this
case \fIname1\fR must refer to an array variable.
.AP Tcl_Obj *newValuePtr in
.VS 8.1
Points to a Tcl object containing the new value for the variable.
.VE
.AP int flags in
OR-ed combination of bits providing additional information. See below
for valid values.
.AP "CONST char" *varName in
Name of variable.
May include \fB::\fR namespace qualifiers
to specify a variable in a particular namespace.
May refer to a scalar variable or an element of
an array.
.AP "CONST char" *newValue in
New value for variable, specified as a null-terminated string.
A copy of this value is stored in the variable.
.AP Tcl_Obj *part1Ptr in
Points to a Tcl object containing the variable's name.
The name may include a series of \fB::\fR namespace qualifiers
to specify a variable in a particular namespace.
May refer to a scalar variable or an element of an array variable.
.AP Tcl_Obj *part2Ptr in
If non-NULL, points to an object containing the name of an element
within an array and \fIpart1Ptr\fR must refer to an array variable.
.BE
.SH DESCRIPTION
.PP
These procedures are used to create, modify, read, and delete
Tcl variables from C code.
.PP
.VS 8.1
\fBTcl_SetVar2Ex\fR, \fBTcl_SetVar\fR, \fBTcl_SetVar2\fR, and
\fBTcl_ObjSetVar2\fR
will create a new variable or modify an existing one.
These procedures set the given variable to the value
given by \fInewValuePtr\fR or \fInewValue\fR and return a
pointer to the variable's new value, which is stored in Tcl's
variable structure.
\fBTcl_SetVar2Ex\fR and \fBTcl_ObjSetVar2\fR take the new value as a
Tcl_Obj and return
a pointer to a Tcl_Obj. \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR
take the new value as a string and return a string; they are
usually less efficient than \fBTcl_ObjSetVar2\fR. Note that the
return value may be different than the \fInewValuePtr\fR or
.VE
\fInewValue\fR argument, due to modifications made by write traces.
If an error occurs in setting the variable (e.g. an array
variable is referenced without giving an index into the array)
NULL is returned and an error message is left in \fIinterp\fR's
result if the \fBTCL_LEAVE_ERR_MSG\fR \fIflag\fR bit is set.
.PP
.VS 8.1
\fBTcl_GetVar2Ex\fR, \fBTcl_GetVar\fR, \fBTcl_GetVar2\fR, and
\fBTcl_ObjGetVar2\fR
return the current value of a variable.
The arguments to these procedures are treated in the same way
as the arguments to the procedures described above.
Under normal circumstances, the return value is a pointer
to the variable's value. For \fBTcl_GetVar2Ex\fR and
\fBTcl_ObjGetVar2\fR the value is
returned as a pointer to a Tcl_Obj. For \fBTcl_GetVar\fR and
\fBTcl_GetVar2\fR the value is returned as a string; this is
usually less efficient, so \fBTcl_GetVar2Ex\fR or \fBTcl_ObjGetVar2\fR
are preferred.
.VE
If an error occurs while reading the variable (e.g. the variable
doesn't exist or an array element is specified for a scalar
variable), then NULL is returned and an error message is left
in \fIinterp\fR's result if the \fBTCL_LEAVE_ERR_MSG\fR \fIflag\fR
bit is set.
.PP
\fBTcl_UnsetVar\fR and \fBTcl_UnsetVar2\fR may be used to remove
a variable, so that future attempts to read the variable will return
an error.
The arguments to these procedures are treated in the same way
as the arguments to the procedures above.
If the variable is successfully removed then TCL_OK is returned.
If the variable cannot be removed because it doesn't exist then
TCL_ERROR is returned and an error message is left
in \fIinterp\fR's result if the \fBTCL_LEAVE_ERR_MSG\fR \fIflag\fR
bit is set.
If an array element is specified, the given element is removed
but the array remains.
If an array name is specified without an index, then the entire
array is removed.
.PP
The name of a variable may be specified to these procedures in
four ways:
.IP [1]
If \fBTcl_SetVar\fR, \fBTcl_GetVar\fR, or \fBTcl_UnsetVar\fR
is invoked, the variable name is given as
a single string, \fIvarName\fR.
If \fIvarName\fR contains an open parenthesis and ends with a
close parenthesis, then the value between the parentheses is
treated as an index (which can have any string value) and
the characters before the first open
parenthesis are treated as the name of an array variable.
If \fIvarName\fR doesn't have parentheses as described above, then
the entire string is treated as the name of a scalar variable.
.IP [2]
If the \fIname1\fR and \fIname2\fR arguments are provided and
\fIname2\fR is non-NULL, then an array element is specified and
the array name and index have
already been separated by the caller: \fIname1\fR contains the
name and \fIname2\fR contains the index.
.VS 8.1
An error is generated
if \fIname1\fR contains an open parenthesis and ends with a
close parenthesis (array element) and \fIname2\fR is non-NULL.
.IP [3]
If \fIname2\fR is NULL, \fIname1\fR is treated just like
\fIvarName\fR in case [1] above (it can be either a scalar or an array
element variable name).
.VE
.PP
The \fIflags\fR argument may be used to specify any of several
options to the procedures.
It consists of an OR-ed combination of the following bits.
.TP
\fBTCL_GLOBAL_ONLY\fR
Under normal circumstances the procedures look up variables as follows.
If a procedure call is active in \fIinterp\fR,
the variable is looked up at the current level of procedure call.
Otherwise, the variable is looked up first in the current namespace,
then in the global namespace.
However, if this bit is set in \fIflags\fR then the variable
is looked up only in the global namespace
even if there is a procedure call active.
If both \fBTCL_GLOBAL_ONLY\fR and \fBTCL_NAMESPACE_ONLY\fR are given,
\fBTCL_GLOBAL_ONLY\fR is ignored.
.TP
\fBTCL_NAMESPACE_ONLY\fR
If this bit is set in \fIflags\fR then the variable
is looked up only in the current namespace; if a procedure is active
its variables are ignored, and the global namespace is also ignored unless
it is the current namespace.
.TP
\fBTCL_LEAVE_ERR_MSG\fR
If an error is returned and this bit is set in \fIflags\fR, then
an error message will be left in the interpreter's result,
where it can be retrieved with \fBTcl_GetObjResult\fR
or \fBTcl_GetStringResult\fR.
If this flag bit isn't set then no error message is left
and the interpreter's result will not be modified.
.TP
\fBTCL_APPEND_VALUE\fR
If this bit is set then \fInewValuePtr\fR or \fInewValue\fR is
appended to the current value instead of replacing it.
If the variable is currently undefined, then the bit is ignored.
This bit is only used by the \fBTcl_Set*\fR procedures.
.TP
\fBTCL_LIST_ELEMENT\fR
If this bit is set, then \fInewValue\fR is converted to a valid
Tcl list element before setting (or appending to) the variable.
A separator space is appended before the new list element unless
the list element is going to be the first element in a list or
sublist (i.e. the variable's current value is empty, or contains
the single character ``{'', or ends in `` }'').
When appending, the original value of the variable must also be
a valid list, so that the operation is the appending of a new
list element onto a list.
.PP
\fBTcl_GetVar\fR and \fBTcl_GetVar2\fR
return the current value of a variable.
The arguments to these procedures are treated in the same way
as the arguments to \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR.
Under normal circumstances, the return value is a pointer
to the variable's value (which is stored in Tcl's variable
structure and will not change before the next call to \fBTcl_SetVar\fR
or \fBTcl_SetVar2\fR).
\fBTcl_GetVar\fR and \fBTcl_GetVar2\fR use the flag bits TCL_GLOBAL_ONLY
and TCL_LEAVE_ERR_MSG, both of
which have
the same meaning as for \fBTcl_SetVar\fR.
If an error occurs in reading the variable (e.g. the variable
doesn't exist or an array element is specified for a scalar
variable), then NULL is returned.
.PP
\fBTcl_UnsetVar\fR and \fBTcl_UnsetVar2\fR may be used to remove
a variable, so that future calls to \fBTcl_GetVar\fR or \fBTcl_GetVar2\fR
for the variable will return an error.
The arguments to these procedures are treated in the same way
as the arguments to \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR.
If the variable is successfully removed then TCL_OK is returned.
If the variable cannot be removed because it doesn't exist then
TCL_ERROR is returned.
If an array element is specified, the given element is removed
but the array remains.
If an array name is specified without an index, then the entire
array is removed.
.SH "SEE ALSO"
Tcl_GetObjResult, Tcl_GetStringResult, Tcl_TraceVar
.SH KEYWORDS
array, get variable, interpreter, object, scalar, set, unset, variable
tcl8.4.20/doc/error.n 0000644 0036047 0045461 00000004470 11737050674 013001 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH error n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
error \- Generate an error
.SH SYNOPSIS
\fBerror \fImessage\fR ?\fIinfo\fR? ?\fIcode\fR?
.BE
.SH DESCRIPTION
.PP
Returns a \fBTCL_ERROR\fR code, which causes command interpretation to be
unwound. \fIMessage\fR is a string that is returned to the application
to indicate what went wrong.
.PP
If the \fIinfo\fR argument is provided and is non-empty,
it is used to initialize the global variable \fBerrorInfo\fR.
\fBerrorInfo\fR is used to accumulate a stack trace of what
was in progress when an error occurred; as nested commands unwind,
the Tcl interpreter adds information to \fBerrorInfo\fR. If the
\fIinfo\fR argument is present, it is used to initialize
\fBerrorInfo\fR and the first increment of unwind information
will not be added by the Tcl interpreter. In other
words, the command containing the \fBerror\fR command will not appear
in \fBerrorInfo\fR; in its place will be \fIinfo\fR.
This feature is most useful in conjunction with the \fBcatch\fR command:
if a caught error cannot be handled successfully, \fIinfo\fR can be used
to return a stack trace reflecting the original point of occurrence
of the error:
.CS
\fBcatch {...} errMsg
set savedInfo $errorInfo
\&...
error $errMsg $savedInfo\fR
.CE
.PP
If the \fIcode\fR argument is present, then its value is stored
in the \fBerrorCode\fR global variable. This variable is intended
to hold a machine-readable description of the error in cases where
such information is available; see the \fBtclvars\fR manual
page for information on the proper format for the variable.
If the \fIcode\fR argument is not
present, then \fBerrorCode\fR is automatically reset to
``NONE'' by the Tcl interpreter as part of processing the
error generated by the command.
.SH EXAMPLE
Generate an error if a basic mathematical operation fails:
.CS
if {1+2 != 3} {
\fBerror\fR "something is very wrong with addition"
}
.CE
.SH "SEE ALSO"
catch(n), return(n), tclvars(n)
.SH KEYWORDS
error, errorCode, errorInfo
tcl8.4.20/doc/ListObj.3 0000644 0036047 0045461 00000024043 11737050674 013121 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl objects as lists
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_ListObjAppendList\fR(\fIinterp, listPtr, elemListPtr\fR)
.sp
int
\fBTcl_ListObjAppendElement\fR(\fIinterp, listPtr, objPtr\fR)
.sp
Tcl_Obj *
\fBTcl_NewListObj\fR(\fIobjc, objv\fR)
.sp
\fBTcl_SetListObj\fR(\fIobjPtr, objc, objv\fR)
.sp
int
\fBTcl_ListObjGetElements\fR(\fIinterp, listPtr, objcPtr, objvPtr\fR)
.sp
int
\fBTcl_ListObjLength\fR(\fIinterp, listPtr, intPtr\fR)
.sp
int
\fBTcl_ListObjIndex\fR(\fIinterp, listPtr, index, objPtrPtr\fR)
.sp
int
\fBTcl_ListObjReplace\fR(\fIinterp, listPtr, first, count, objc, objv\fR)
.SH ARGUMENTS
.AS Tcl_Interp "*CONST objv[]" out
.AP Tcl_Interp *interp in
If an error occurs while converting an object to be a list object,
an error message is left in the interpreter's result object
unless \fIinterp\fR is NULL.
.AP Tcl_Obj *listPtr in/out
Points to the list object to be manipulated.
If \fIlistPtr\fR does not already point to a list object,
an attempt will be made to convert it to one.
.AP Tcl_Obj *elemListPtr in/out
For \fBTcl_ListObjAppendList\fR, this points to a list object
containing elements to be appended onto \fIlistPtr\fR.
Each element of *\fIelemListPtr\fR will
become a new element of \fIlistPtr\fR.
If *\fIelemListPtr\fR is not NULL and
does not already point to a list object,
an attempt will be made to convert it to one.
.AP Tcl_Obj *objPtr in
For \fBTcl_ListObjAppendElement\fR,
points to the Tcl object that will be appended to \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
this points to the Tcl object that will be converted to a list object
containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR.
.AP int *objcPtr in
Points to location where \fBTcl_ListObjGetElements\fR
stores the number of element objects in \fIlistPtr\fR.
.AP Tcl_Obj ***objvPtr out
A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array
of pointers to the element objects of \fIlistPtr\fR.
.AP int objc in
The number of Tcl objects that \fBTcl_NewListObj\fR
will insert into a new list object,
and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
the number of Tcl objects to insert into \fIobjPtr\fR.
.VS
.AP Tcl_Obj "*CONST\ objv[]" in
An array of pointers to objects.
\fBTcl_NewListObj\fR will insert these objects into a new list object
and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR.
Each object will become a separate list element.
.VE
.AP int *intPtr out
Points to location where \fBTcl_ListObjLength\fR
stores the length of the list.
.AP int index in
Index of the list element that \fBTcl_ListObjIndex\fR
is to return.
The first element has index 0.
.AP Tcl_Obj **objPtrPtr out
Points to place where \fBTcl_ListObjIndex\fR is to store
a pointer to the resulting list element object.
.AP int first in
Index of the starting list element that \fBTcl_ListObjReplace\fR
is to replace.
The list's first element has index 0.
.AP int count in
The number of elements that \fBTcl_ListObjReplace\fR
is to replace.
.BE
.SH DESCRIPTION
.PP
Tcl list objects have an internal representation that supports
the efficient indexing and appending.
The procedures described in this man page are used to
create, modify, index, and append to Tcl list objects from C code.
.PP
\fBTcl_ListObjAppendList\fR and \fBTcl_ListObjAppendElement\fR
both add one or more objects
to the end of the list object referenced by \fIlistPtr\fR.
\fBTcl_ListObjAppendList\fR appends each element of the list object
referenced by \fIelemListPtr\fR while
\fBTcl_ListObjAppendElement\fR appends the single object
referenced by \fIobjPtr\fR.
Both procedures will convert the object referenced by \fIlistPtr\fR
to a list object if necessary.
If an error occurs during conversion,
both procedures return \fBTCL_ERROR\fR and leave an error message
in the interpreter's result object if \fIinterp\fR is not NULL.
Similarly, if \fIelemListPtr\fR does not already refer to a list object,
\fBTcl_ListObjAppendList\fR will attempt to convert it to one
and if an error occurs during conversion,
will return \fBTCL_ERROR\fR
and leave an error message in the interpreter's result object
if interp is not NULL.
Both procedures invalidate any old string representation of \fIlistPtr\fR
and, if it was converted to a list object,
free any old internal representation.
Similarly, \fBTcl_ListObjAppendList\fR frees any old internal representation
of \fIelemListPtr\fR if it converts it to a list object.
After appending each element in \fIelemListPtr\fR,
\fBTcl_ListObjAppendList\fR increments the element's reference count
since \fIlistPtr\fR now also refers to it.
For the same reason, \fBTcl_ListObjAppendElement\fR
increments \fIobjPtr\fR's reference count.
If no error occurs,
the two procedures return \fBTCL_OK\fR after appending the objects.
.PP
\fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR
create a new object or modify an existing object to hold
the \fIobjc\fR elements of the array referenced by \fIobjv\fR
where each element is a pointer to a Tcl object.
If \fIobjc\fR is less than or equal to zero,
they return an empty object.
The new object's string representation is left invalid.
The two procedures increment the reference counts
of the elements in \fIobjc\fR since the list object now refers to them.
The new list object returned by \fBTcl_NewListObj\fR
has reference count zero.
.PP
\fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of
the elements in a list object. It returns the count by storing it in the
address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing
it in the address \fIobjvPtr\fR.
The memory pointed to is managed by Tcl and should not be freed by the
caller.
If \fIlistPtr\fR is not already a list object, \fBTcl_ListObjGetElements\fR
will attempt to convert it to one; if the conversion fails, it returns
\fBTCL_ERROR\fR and leaves an error message in the interpreter's result
object if \fIinterp\fR is not NULL.
Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer.
.PP
\fBTcl_ListObjLength\fR returns the number of elements in the list object
referenced by \fIlistPtr\fR.
It returns this count by storing an integer in the address \fIintPtr\fR.
If the object is not already a list object,
\fBTcl_ListObjLength\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
if \fIinterp\fR is not NULL.
Otherwise it returns \fBTCL_OK\fR after storing the list's length.
.PP
The procedure \fBTcl_ListObjIndex\fR returns a pointer to the object
at element \fIindex\fR in the list referenced by \fIlistPtr\fR.
It returns this object by storing a pointer to it
in the address \fIobjPtrPtr\fR.
If \fIlistPtr\fR does not already refer to a list object,
\fBTcl_ListObjIndex\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
if \fIinterp\fR is not NULL.
If the index is out of range,
that is, \fIindex\fR is negative or
greater than or equal to the number of elements in the list,
\fBTcl_ListObjIndex\fR stores a NULL in \fIobjPtrPtr\fR
and returns \fBTCL_OK\fR.
Otherwise it returns \fBTCL_OK\fR after storing the element's
object pointer.
The reference count for the list element is not incremented;
the caller must do that if it needs to retain a pointer to the element.
.PP
\fBTcl_ListObjReplace\fR replaces zero or more elements
of the list referenced by \fIlistPtr\fR
with the \fIobjc\fR objects in the array referenced by \fIobjv\fR.
If \fIlistPtr\fR does not point to a list object,
\fBTcl_ListObjReplace\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
if \fIinterp\fR is not NULL.
Otherwise, it returns \fBTCL_OK\fR after replacing the objects.
If \fIobjv\fR is NULL, no new elements are added.
If the argument \fIfirst\fR is zero or negative,
it refers to the first element.
If \fIfirst\fR is greater than or equal to the
number of elements in the list, then no elements are deleted;
the new elements are appended to the list.
\fIcount\fR gives the number of elements to replace.
If \fIcount\fR is zero or negative then no elements are deleted;
the new elements are simply inserted before the one
designated by \fIfirst\fR.
\fBTcl_ListObjReplace\fR invalidates \fIlistPtr\fR's
old string representation.
The reference counts of any elements inserted from \fIobjv\fR
are incremented since the resulting list now refers to them.
Similarly, the reference counts for any replaced objects are decremented.
.PP
Because \fBTcl_ListObjReplace\fR combines
both element insertion and deletion,
it can be used to implement a number of list operations.
For example, the following code inserts the \fIobjc\fR objects
referenced by the array of object pointers \fIobjv\fR
just before the element \fIindex\fR of the list referenced by \fIlistPtr\fR:
.CS
result = Tcl_ListObjReplace(interp, listPtr, index, 0, objc, objv);
.CE
Similarly, the following code appends the \fIobjc\fR objects
referenced by the array \fIobjv\fR
to the end of the list \fIlistPtr\fR:
.CS
result = Tcl_ListObjLength(interp, listPtr, &length);
if (result == TCL_OK) {
result = Tcl_ListObjReplace(interp, listPtr, length, 0, objc, objv);
}
.CE
The \fIcount\fR list elements starting at \fIfirst\fR can be deleted
by simply calling \fBTcl_ListObjReplace\fR
with a NULL \fIobjvPtr\fR:
.CS
result = Tcl_ListObjReplace(interp, listPtr, first, count, 0, NULL);
.CE
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult
.SH KEYWORDS
append, index, insert, internal representation, length, list, list object, list type, object, object type, replace, string representation
tcl8.4.20/doc/vwait.n 0000644 0036047 0045461 00000004557 11737050674 013010 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH vwait n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
vwait \- Process events until a variable is written
.SH SYNOPSIS
\fBvwait\fR \fIvarName\fR
.BE
.SH DESCRIPTION
.PP
This command enters the Tcl event loop to process events, blocking
the application if no events are ready. It continues processing
events until some event handler sets the value of variable
\fIvarName\fR. Once \fIvarName\fR has been set, the \fBvwait\fR
command will return as soon as the event handler that modified
\fIvarName\fR completes. \fIvarName\fR must globally scoped
(either with a call to \fBglobal\fR for the \fIvarName\fR, or with
the full namespace path specification).
.PP
In some cases the \fBvwait\fR command may not return immediately
after \fIvarName\fR is set. This can happen if the event handler
that sets \fIvarName\fR does not complete immediately. For example,
if an event handler sets \fIvarName\fR and then itself calls
\fBvwait\fR to wait for a different variable, then it may not return
for a long time. During this time the top-level \fBvwait\fR is
blocked waiting for the event handler to complete, so it cannot
return either.
.SH EXAMPLES
Run the event-loop continually until some event calls \fBexit\fR.
(You can use any variable not mentioned elsewhere, but the name
\fIforever\fR reminds you at a glance of the intent.)
.CS
\fBvwait\fR forever
.CE
.PP
Wait five seconds for a connection to a server socket, otherwise
close the socket and continue running the script:
.CS
# Initialise the state
after 5000 set state timeout
set server [socket -server accept 12345]
proc accept {args} {
global state connectionInfo
set state accepted
set connectionInfo $args
}
# Wait for something to happen
\fBvwait\fR state
# Clean up events that could have happened
close $server
after cancel set state timeout
# Do something based on how the vwait finished...
switch $state {
timeout {
puts "no connection on port 12345"
}
accepted {
puts "connection: $connectionInfo"
puts [lindex $connectionInfo 0] "Hello there!"
}
}
.CE
.SH "SEE ALSO"
global(n), update(n)
.SH KEYWORDS
event, variable, wait
tcl8.4.20/doc/SplitList.3 0000644 0036047 0045461 00000015572 11737050674 013511 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_SplitList 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SplitList, Tcl_Merge, Tcl_ScanElement, Tcl_ConvertElement, Tcl_ScanCountedElement, Tcl_ConvertCountedElement \- manipulate Tcl lists
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR)
.sp
char *
\fBTcl_Merge\fR(\fIargc, argv\fR)
.sp
int
\fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR)
.sp
int
\fBTcl_ScanCountedElement\fR(\fIsrc, length, flagsPtr\fR)
.sp
int
\fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR)
.sp
int
\fBTcl_ConvertCountedElement\fR(\fIsrc, length, dst, flags\fR)
.SH ARGUMENTS
.AS "CONST char * CONST" ***argvPtr
.AP Tcl_Interp *interp out
Interpreter to use for error reporting. If NULL, then no error message
is left.
.AP char *list in
Pointer to a string with proper list structure.
.AP int *argcPtr out
Filled in with number of elements in \fIlist\fR.
.AP "CONST char" ***argvPtr out
\fI*argvPtr\fR will be filled in with the address of an array of
pointers to the strings that are the extracted elements of \fIlist\fR.
There will be \fI*argcPtr\fR valid entries in the array, followed by
a NULL entry.
.AP int argc in
Number of elements in \fIargv\fR.
.AP "CONST char * CONST" *argv in
Array of strings to merge together into a single list.
Each string will become a separate element of the list.
.AP "CONST char" *src in
String that is to become an element of a list.
.AP int *flagsPtr in
Pointer to word to fill in with information about \fIsrc\fR.
The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR.
.AP int length in
Number of bytes in string \fIsrc\fR.
.AP char *dst in
Place to copy converted list element. Must contain enough characters
to hold converted string.
.AP int flags in
Information about \fIsrc\fR. Must be value returned by previous
call to \fBTcl_ScanElement\fR, possibly OR-ed
with \fBTCL_DONT_USE_BRACES\fR.
.BE
.SH DESCRIPTION
.PP
These procedures may be used to disassemble and reassemble Tcl lists.
\fBTcl_SplitList\fR breaks a list up into its constituent elements,
returning an array of pointers to the elements using
\fIargcPtr\fR and \fIargvPtr\fR.
While extracting the arguments, \fBTcl_SplitList\fR obeys the usual
rules for backslash substitutions and braces. The area of
memory pointed to by \fI*argvPtr\fR is dynamically allocated; in
addition to the array of pointers, it
also holds copies of all the list elements. It is the caller's
responsibility to free up all of this storage.
For example, suppose that you have called \fBTcl_SplitList\fR with
the following code:
.CS
int argc, code;
char *string;
char **argv;
\&...
code = Tcl_SplitList(interp, string, &argc, &argv);
.CE
Then you should eventually free the storage with a call like the
following:
.CS
Tcl_Free((char *) argv);
.CE
.PP
\fBTcl_SplitList\fR normally returns \fBTCL_OK\fR, which means the list was
successfully parsed.
If there was a syntax error in \fIlist\fR, then \fBTCL_ERROR\fR is returned
and the interpreter's result will point to an error message describing the
problem (if \fIinterp\fR was not NULL).
If \fBTCL_ERROR\fR is returned then no memory is allocated and \fI*argvPtr\fR
is not modified.
.PP
\fBTcl_Merge\fR is the inverse of \fBTcl_SplitList\fR: it
takes a collection of strings given by \fIargc\fR
and \fIargv\fR and generates a result string
that has proper list structure.
This means that commands like \fBindex\fR may be used to
extract the original elements again.
In addition, if the result of \fBTcl_Merge\fR is passed to \fBTcl_Eval\fR,
it will be parsed into \fIargc\fR words whose values will
be the same as the \fIargv\fR strings passed to \fBTcl_Merge\fR.
\fBTcl_Merge\fR will modify the list elements with braces and/or
backslashes in order to produce proper Tcl list structure.
The result string is dynamically allocated
using \fBTcl_Alloc\fR; the caller must eventually release the space
using \fBTcl_Free\fR.
.PP
If the result of \fBTcl_Merge\fR is passed to \fBTcl_SplitList\fR,
the elements returned by \fBTcl_SplitList\fR will be identical to
those passed into \fBTcl_Merge\fR.
However, the converse is not true: if \fBTcl_SplitList\fR
is passed a given string, and the resulting \fIargc\fR and
\fIargv\fR are passed to \fBTcl_Merge\fR, the resulting string
may not be the same as the original string passed to \fBTcl_SplitList\fR.
This is because \fBTcl_Merge\fR may use backslashes and braces
differently than the original string.
.PP
\fBTcl_ScanElement\fR and \fBTcl_ConvertElement\fR are the
procedures that do all of the real work of \fBTcl_Merge\fR.
\fBTcl_ScanElement\fR scans its \fIsrc\fR argument
and determines how to use backslashes and braces
when converting it to a list element.
It returns an overestimate of the number of characters
required to represent \fIsrc\fR as a list element, and
it stores information in \fI*flagsPtr\fR that is needed
by \fBTcl_ConvertElement\fR.
.PP
\fBTcl_ConvertElement\fR is a companion procedure to \fBTcl_ScanElement\fR.
It does the actual work of converting a string to a list element.
Its \fIflags\fR argument must be the same as the value returned
by \fBTcl_ScanElement\fR.
\fBTcl_ConvertElement\fR writes a proper list element to memory
starting at *\fIdst\fR and returns a count of the total number
of characters written, which will be no more than the result
returned by \fBTcl_ScanElement\fR.
\fBTcl_ConvertElement\fR writes out only the actual list element
without any leading or trailing spaces: it is up to the caller to
include spaces between adjacent list elements.
.PP
\fBTcl_ConvertElement\fR uses one of two different approaches to
handle the special characters in \fIsrc\fR. Wherever possible, it
handles special characters by surrounding the string with braces.
This produces clean-looking output, but can't be used in some situations,
such as when \fIsrc\fR contains unmatched braces.
In these situations, \fBTcl_ConvertElement\fR handles special
characters by generating backslash sequences for them.
The caller may insist on the second approach by OR-ing the
flag value returned by \fBTcl_ScanElement\fR with
\fBTCL_DONT_USE_BRACES\fR.
Although this will produce an uglier result, it is useful in some
special situations, such as when \fBTcl_ConvertElement\fR is being
used to generate a portion of an argument for a Tcl command.
In this case, surrounding \fIsrc\fR with curly braces would cause
the command not to be parsed correctly.
.PP
\fBTcl_ScanCountedElement\fR and \fBTcl_ConvertCountedElement\fR are
the same as \fBTcl_ScanElement\fR and \fBTcl_ConvertElement\fR, except
the length of string \fIsrc\fR is specified by the \fIlength\fR
argument, and the string may contain embedded nulls.
.SH KEYWORDS
backslash, convert, element, list, merge, split, strings
tcl8.4.20/doc/lrange.n 0000644 0036047 0045461 00000004055 11737050674 013117 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH lrange n 7.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
lrange \- Return one or more adjacent elements from a list
.SH SYNOPSIS
\fBlrange \fIlist first last\fR
.BE
.SH DESCRIPTION
.PP
\fIList\fR must be a valid Tcl list. This command will
return a new list consisting of elements
\fIfirst\fR through \fIlast\fR, inclusive.
\fIFirst\fR or \fIlast\fR
may be \fBend\fR (or any abbreviation of it) to refer to the last
element of the list.
If \fIfirst\fR is less than zero, it is treated as if it were zero.
If \fIlast\fR is greater than or equal to the number of elements
in the list, then it is treated as if it were \fBend\fR.
If \fIfirst\fR is greater than \fIlast\fR then an empty string
is returned.
Note: ``\fBlrange \fIlist first first\fR'' does not always produce the
same result as ``\fBlindex \fIlist first\fR'' (although it often does
for simple fields that aren't enclosed in braces); it does, however,
produce exactly the same results as ``\fBlist [lindex \fIlist first\fB]\fR''
.SH EXAMPLES
Selecting the first two elements:
.CS
% \fBlrange\fR {a b c d e} 0 1
a b
.CE
.PP
Selecting the last three elements:
.CS
% \fBlrange\fR {a b c d e} end-2 end
c d e
.CE
.PP
Selecting everything except the first and last element:
.CS
% \fBlrange\fR {a b c d e} 1 end-1
b c d
.CE
.PP
Selecting a single element with \fBlrange\fR is not the same as doing
so with \fBlindex\fR:
.CS
% set var {some {elements to} select}
some {elements to} select
% lindex $var 1
elements to
% \fBlrange\fR $var 1 1
{elements to}
.CE
.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lset(n), lreplace(n), lsort(n)
.VE
.SH KEYWORDS
element, list, range, sublist
tcl8.4.20/doc/BoolObj.3 0000644 0036047 0045461 00000006433 11737050674 013104 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_BooleanObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- manipulate Tcl objects as boolean values
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Obj *
\fBTcl_NewBooleanObj\fR(\fIboolValue\fR)
.sp
\fBTcl_SetBooleanObj\fR(\fIobjPtr, boolValue\fR)
.sp
int
\fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, boolPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp
.AP int boolValue in
Integer value used to initialize or set a boolean object.
If the integer is nonzero, the boolean object is set to 1;
otherwise the boolean object is set to 0.
.AP Tcl_Obj *objPtr in/out
For \fBTcl_SetBooleanObj\fR, this points to the object to be converted
to boolean type.
For \fBTcl_GetBooleanFromObj\fR, this refers to the object
from which to get a boolean value;
if \fIobjPtr\fR does not already point to a boolean object,
an attempt will be made to convert it to one.
.AP Tcl_Interp *interp in/out
If an error occurs during conversion,
an error message is left in the interpreter's result object
unless \fIinterp\fR is NULL.
.AP int *boolPtr out
Points to place where \fBTcl_GetBooleanFromObj\fR
stores the boolean value (0 or 1) obtained from \fIobjPtr\fR.
.BE
.SH DESCRIPTION
.PP
These procedures are used to create, modify, and read
boolean Tcl objects from C code.
\fBTcl_NewBooleanObj\fR and \fBTcl_SetBooleanObj\fR
will create a new object of boolean type
or modify an existing object to have boolean type.
Both of these procedures set the object to have the
boolean value (0 or 1) specified by \fIboolValue\fR;
if \fIboolValue\fR is nonzero, the object is set to 1,
otherwise to 0.
\fBTcl_NewBooleanObj\fR returns a pointer to a newly created object
with reference count zero.
Both procedures set the object's type to be boolean
and assign the boolean value to the object's internal representation
\fIlongValue\fR member.
\fBTcl_SetBooleanObj\fR invalidates any old string representation
and, if the object is not already a boolean object,
frees any old internal representation.
.PP
\fBTcl_GetBooleanFromObj\fR attempts to return a boolean value
from the Tcl object \fIobjPtr\fR.
If the object is not already a boolean object,
it will attempt to convert it to one.
If an error occurs during conversion, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
unless \fIinterp\fR is NULL.
Otherwise, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR
and stores the boolean value in the address given by \fIboolPtr\fR.
If the object is not already a boolean object,
the conversion will free any old internal representation.
Objects having a string representation equal to any of \fB0\fR,
\fBfalse\fR, \fBno\fR, or \fBoff\fR have a boolean value 0; if the
string representation is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or
\fBon\fR the boolean value is 1.
Any of these string values may be abbreviated, and upper-case spellings
are also acceptable.
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult
.SH KEYWORDS
boolean, boolean object, boolean type, internal representation, object, object type, string representation
tcl8.4.20/doc/gets.n 0000644 0036047 0045461 00000004632 11737050674 012612 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH gets n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
gets \- Read a line from a channel
.SH SYNOPSIS
\fBgets \fIchannelId\fR ?\fIvarName\fR?
.BE
.SH DESCRIPTION
.PP
This command reads the next line from \fIchannelId\fR, returns everything
in the line up to (but not including) the end-of-line character(s), and
discards the end-of-line character(s).
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as the
Tcl standard input channel (\fBstdin\fR), the return value from an
invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel
creation command provided by a Tcl extension. The channel must have
been opened for input.
.VE
.PP
If \fIvarName\fR is omitted the line is returned as the result of the
command.
If \fIvarName\fR is specified then the line is placed in the variable by
that name and the return value is a count of the number of characters
returned.
.PP
If end of file occurs while scanning for an end of
line, the command returns whatever input is available up to the end of file.
If \fIchannelId\fR is in nonblocking mode and there is not a full
line of input available, the command returns an empty string and
does not consume any input.
If \fIvarName\fR is specified and an empty string is returned in
\fIvarName\fR because of end-of-file or because of insufficient
data in nonblocking mode, then the return count is -1.
Note that if \fIvarName\fR is not specified then the end-of-file
and no-full-line-available cases can
produce the same results as if there were an input line consisting
only of the end-of-line character(s).
The \fBeof\fR and \fBfblocked\fR commands can be used to distinguish
these three cases.
.SH "EXAMPLE"
This example reads a file one line at a time and prints it out with
the current line number attached to the start of each line.
.PP
.CS
set chan [open "some.file.txt"]
set lineNumber 0
while {[\fBgets\fR $chan line] >= 0} {
puts "[incr lineNumber]: $line"
}
close $chan
.CE
.SH "SEE ALSO"
file(n), eof(n), fblocked(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, channel, end of file, end of line, line, nonblocking, read
tcl8.4.20/doc/RecordEval.3 0000644 0036047 0045461 00000003755 11737050674 013610 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-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.
'\"
.so man.macros
.TH Tcl_RecordAndEval 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_RecordAndEval \- save command on history list before evaluating
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_RecordAndEval\fR(\fIinterp, cmd, flags\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp;
.AP Tcl_Interp *interp in
Tcl interpreter in which to evaluate command.
.AP "CONST char" *cmd in
Command (or sequence of commands) to execute.
.AP int flags in
An OR'ed combination of flag bits. TCL_NO_EVAL means record the
command but don't evaluate it. TCL_EVAL_GLOBAL means evaluate
the command at global level instead of the current stack level.
.BE
.SH DESCRIPTION
.PP
\fBTcl_RecordAndEval\fR is invoked to record a command as an event
on the history list and then execute it using \fBTcl_Eval\fR
(or \fBTcl_GlobalEval\fR if the TCL_EVAL_GLOBAL bit is set in \fIflags\fR).
It returns a completion code such as TCL_OK just like \fBTcl_Eval\fR
and it leaves information in the interpreter's result.
If you don't want the command recorded on the history list then
you should invoke \fBTcl_Eval\fR instead of \fBTcl_RecordAndEval\fR.
Normally \fBTcl_RecordAndEval\fR is only called with top-level
commands typed by the user, since the purpose of history is to
allow the user to re-issue recently-invoked commands.
If the \fIflags\fR argument contains the TCL_NO_EVAL bit then
the command is recorded without being evaluated.
.PP
Note that \fBTcl_RecordAndEval\fR has been largely replaced by the
object-based procedure \fBTcl_RecordAndEvalObj\fR.
That object-based procedure records and optionally executes
a command held in a Tcl object instead of a string.
.SH "SEE ALSO"
Tcl_RecordAndEvalObj
.SH KEYWORDS
command, event, execute, history, interpreter, record
tcl8.4.20/doc/binary.n 0000644 0036047 0045461 00000062221 11737050674 013132 0 ustar dgp 771div '\"
'\" Copyright (c) 1997 by Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH binary n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
binary \- Insert and extract fields from binary strings
.SH SYNOPSIS
\fBbinary format \fIformatString \fR?\fIarg arg ...\fR?
.br
\fBbinary scan \fIstring formatString \fR?\fIvarName varName ...\fR?
.BE
.SH DESCRIPTION
.PP
This command provides facilities for manipulating binary data. The
first form, \fBbinary format\fR, creates a binary string from normal
Tcl values. For example, given the values 16 and 22, on a 32 bit
architecture, it might produce an 8-byte binary string consisting of
two 4-byte integers, one for each of the numbers. The second form of
the command, \fBbinary scan\fR, does the opposite: it extracts data
from a binary string and returns it as ordinary Tcl string values.
.SH "BINARY FORMAT"
.PP
The \fBbinary format\fR command generates a binary string whose layout
is specified by the \fIformatString\fR and whose contents come from
the additional arguments. The resulting binary value is returned.
.PP
The \fIformatString\fR consists of a sequence of zero or more field
specifiers separated by zero or more spaces. Each field specifier is
a single type character followed by an optional numeric \fIcount\fR.
Most field specifiers consume one argument to obtain the value to be
formatted. The type character specifies how the value is to be
formatted. The \fIcount\fR typically indicates how many items of the
specified type are taken from the value. If present, the \fIcount\fR
is a non-negative decimal integer or \fB*\fR, which normally indicates
that all of the items in the value are to be used. If the number of
arguments does not match the number of fields in the format string
that consume arguments, then an error is generated.
.PP
Here is a small example to clarify the relation between the field
specifiers and the arguments:
.CS
\fBbinary format d3d {1.0 2.0 3.0 4.0} 0.1\fR
.CE
.PP
The first argument is a list of four numbers, but because of the count
of 3 for the associated field specifier, only the first three will be
used. The second argument is associated with the second field
specifier. The resulting binary string contains the four numbers 1.0,
2.0, 3.0 and 0.1.
.PP
Each type-count pair moves an imaginary cursor through the binary
data, storing bytes at the current position and advancing the cursor
to just after the last byte stored. The cursor is initially at
position 0 at the beginning of the data. The type may be any one of
the following characters:
.IP \fBa\fR 5
Stores a character string of length \fIcount\fR in the output string.
Every character is taken as modulo 256 (i.e. the low byte of every
character is used, and the high byte discarded) so when storing
character strings not wholly expressible using the characters \\u0000-\\u00ff,
the \fBencoding convertto\fR command should be used
first if this truncation is not desired (i.e. if the characters are
not part of the ISO 8859-1 character set.)
If \fIarg\fR has fewer than \fIcount\fR bytes, then additional zero
bytes are used to pad out the field. If \fIarg\fR is longer than the
specified length, the extra characters will be ignored. If
\fIcount\fR is \fB*\fR, then all of the bytes in \fIarg\fR will be
formatted. If \fIcount\fR is omitted, then one character will be
formatted. For example,
.RS
.CS
\fBbinary format a7a*a alpha bravo charlie\fR
.CE
will return a string equivalent to \fBalpha\\000\\000bravoc\fR.
.RE
.IP \fBA\fR 5
This form is the same as \fBa\fR except that spaces are used for
padding instead of nulls. For example,
.RS
.CS
\fBbinary format A6A*A alpha bravo charlie\fR
.CE
will return \fBalpha bravoc\fR.
.RE
.IP \fBb\fR 5
Stores a string of \fIcount\fR binary digits in low-to-high order
within each byte in the output string. \fIArg\fR must contain a
sequence of \fB1\fR and \fB0\fR characters. The resulting bytes are
emitted in first to last order with the bits being formatted in
low-to-high order within each byte. If \fIarg\fR has fewer than
\fIcount\fR digits, then zeros will be used for the remaining bits.
If \fIarg\fR has more than the specified number of digits, the extra
digits will be ignored. If \fIcount\fR is \fB*\fR, then all of the
digits in \fIarg\fR will be formatted. If \fIcount\fR is omitted,
then one digit will be formatted. If the number of bits formatted
does not end at a byte boundary, the remaining bits of the last byte
will be zeros. For example,
.RS
.CS
\fBbinary format b5b* 11100 111000011010\fR
.CE
will return a string equivalent to \fB\\x07\\x87\\x05\fR.
.RE
.IP \fBB\fR 5
This form is the same as \fBb\fR except that the bits are stored in
high-to-low order within each byte. For example,
.RS
.CS
\fBbinary format B5B* 11100 111000011010\fR
.CE
will return a string equivalent to \fB\\xe0\\xe1\\xa0\fR.
.RE
.IP \fBh\fR 5
Stores a string of \fIcount\fR hexadecimal digits in low-to-high
within each byte in the output string. \fIArg\fR must contain a
sequence of characters in the set ``0123456789abcdefABCDEF''. The
resulting bytes are emitted in first to last order with the hex digits
being formatted in low-to-high order within each byte. If \fIarg\fR
has fewer than \fIcount\fR digits, then zeros will be used for the
remaining digits. If \fIarg\fR has more than the specified number of
digits, the extra digits will be ignored. If \fIcount\fR is
\fB*\fR, then all of the digits in \fIarg\fR will be formatted. If
\fIcount\fR is omitted, then one digit will be formatted. If the
number of digits formatted does not end at a byte boundary, the
remaining bits of the last byte will be zeros. For example,
.RS
.CS
\fBbinary format h3h* AB def\fR
.CE
will return a string equivalent to \fB\\xba\\x00\\xed\\x0f\fR.
.RE
.IP \fBH\fR 5
This form is the same as \fBh\fR except that the digits are stored in
high-to-low order within each byte. For example,
.RS
.CS
\fBbinary format H3H* ab DEF\fR
.CE
will return a string equivalent to \fB\\xab\\x00\\xde\\xf0\fR.
.RE
.IP \fBc\fR 5
Stores one or more 8-bit integer values in the output string. If no
\fIcount\fR is specified, then \fIarg\fR must consist of an integer
value; otherwise \fIarg\fR must consist of a list containing at least
\fIcount\fR integer elements. The low-order 8 bits of each integer
are stored as a one-byte value at the cursor position. If \fIcount\fR
is \fB*\fR, then all of the integers in the list are formatted. If
the number of elements in the list is fewer than \fIcount\fR, then an
error is generated. If the number of elements in the list is greater
than \fIcount\fR, then the extra elements are ignored. For example,
.RS
.CS
\fBbinary format c3cc* {3 -3 128 1} 260 {2 5}\fR
.CE
will return a string equivalent to
\fB\\x03\\xfd\\x80\\x04\\x02\\x05\fR, whereas
.CS
\fBbinary format c {2 5}\fR
.CE
will generate an error.
.RE
.IP \fBs\fR 5
This form is the same as \fBc\fR except that it stores one or more
16-bit integers in little-endian byte order in the output string. The
low-order 16-bits of each integer are stored as a two-byte value at
the cursor position with the least significant byte stored first. For
example,
.RS
.CS
\fBbinary format s3 {3 -3 258 1}\fR
.CE
will return a string equivalent to
\fB\\x03\\x00\\xfd\\xff\\x02\\x01\fR.
.RE
.IP \fBS\fR 5
This form is the same as \fBs\fR except that it stores one or more
16-bit integers in big-endian byte order in the output string. For
example,
.RS
.CS
\fBbinary format S3 {3 -3 258 1}\fR
.CE
will return a string equivalent to
\fB\\x00\\x03\\xff\\xfd\\x01\\x02\fR.
.RE
.IP \fBi\fR 5
This form is the same as \fBc\fR except that it stores one or more
32-bit integers in little-endian byte order in the output string. The
low-order 32-bits of each integer are stored as a four-byte value at
the cursor position with the least significant byte stored first. For
example,
.RS
.CS
\fBbinary format i3 {3 -3 65536 1}\fR
.CE
will return a string equivalent to
\fB\\x03\\x00\\x00\\x00\\xfd\\xff\\xff\\xff\\x00\\x00\\x01\\x00\fR
.RE
.IP \fBI\fR 5
This form is the same as \fBi\fR except that it stores one or more one
or more 32-bit integers in big-endian byte order in the output string.
For example,
.RS
.CS
\fBbinary format I3 {3 -3 65536 1}\fR
.CE
will return a string equivalent to
\fB\\x00\\x00\\x00\\x03\\xff\\xff\\xff\\xfd\\x00\\x01\\x00\\x00\fR
.RE
.IP \fBw\fR 5
.VS 8.4
This form is the same as \fBc\fR except that it stores one or more
64-bit integers in little-endian byte order in the output string. The
low-order 64-bits of each integer are stored as an eight-byte value at
the cursor position with the least significant byte stored first. For
example,
.RS
.CS
\fBbinary format w 7810179016327718216\fR
.CE
will return the string \fBHelloTcl\fR
.RE
.IP \fBW\fR 5
This form is the same as \fBw\fR except that it stores one or more one
or more 64-bit integers in big-endian byte order in the output string.
For example,
.RS
.CS
\fBbinary format Wc 4785469626960341345 110\fR
.CE
will return the string \fBBigEndian\fR
.VE
.RE
.IP \fBf\fR 5
This form is the same as \fBc\fR except that it stores one or more one
or more single-precision floating in the machine's native
representation in the output string. This representation is not
portable across architectures, so it should not be used to communicate
floating point numbers across the network. The size of a floating
point number may vary across architectures, so the number of bytes
that are generated may vary. If the value overflows the
machine's native representation, then the value of FLT_MAX
as defined by the system will be used instead. Because Tcl uses
double-precision floating-point numbers internally, there may be some
loss of precision in the conversion to single-precision. For example,
on a Windows system running on an Intel Pentium processor,
.RS
.CS
\fBbinary format f2 {1.6 3.4}\fR
.CE
will return a string equivalent to
\fB\\xcd\\xcc\\xcc\\x3f\\x9a\\x99\\x59\\x40\fR.
.RE
.IP \fBd\fR 5
This form is the same as \fBf\fR except that it stores one or more one
or more double-precision floating in the machine's native
representation in the output string. For example, on a
Windows system running on an Intel Pentium processor,
.RS
.CS
\fBbinary format d1 {1.6}\fR
.CE
will return a string equivalent to
\fB\\x9a\\x99\\x99\\x99\\x99\\x99\\xf9\\x3f\fR.
.RE
.IP \fBx\fR 5
Stores \fIcount\fR null bytes in the output string. If \fIcount\fR is
not specified, stores one null byte. If \fIcount\fR is \fB*\fR,
generates an error. This type does not consume an argument. For
example,
.RS
.CS
\fBbinary format a3xa3x2a3 abc def ghi\fR
.CE
will return a string equivalent to \fBabc\\000def\\000\\000ghi\fR.
.RE
.IP \fBX\fR 5
Moves the cursor back \fIcount\fR bytes in the output string. If
\fIcount\fR is \fB*\fR or is larger than the current cursor position,
then the cursor is positioned at location 0 so that the next byte
stored will be the first byte in the result string. If \fIcount\fR is
omitted then the cursor is moved back one byte. This type does not
consume an argument. For example,
.RS
.CS
\fBbinary format a3X*a3X2a3 abc def ghi\fR
.CE
will return \fBdghi\fR.
.RE
.IP \fB@\fR 5
Moves the cursor to the absolute location in the output string
specified by \fIcount\fR. Position 0 refers to the first byte in the
output string. If \fIcount\fR refers to a position beyond the last
byte stored so far, then null bytes will be placed in the uninitialized
locations and the cursor will be placed at the specified location. If
\fIcount\fR is \fB*\fR, then the cursor is moved to the current end of
the output string. If \fIcount\fR is omitted, then an error will be
generated. This type does not consume an argument. For example,
.RS
.CS
\fBbinary format a5@2a1@*a3@10a1 abcde f ghi j\fR
.CE
will return \fBabfdeghi\\000\\000j\fR.
.RE
.SH "BINARY SCAN"
.PP
The \fBbinary scan\fR command parses fields from a binary string,
returning the number of conversions performed. \fIString\fR gives the
input to be parsed and \fIformatString\fR indicates how to parse it.
Each \fIvarName\fR gives the name of a variable; when a field is
scanned from \fIstring\fR the result is assigned to the corresponding
variable.
.PP
As with \fBbinary format\fR, the \fIformatString\fR consists of a
sequence of zero or more field specifiers separated by zero or more
spaces. Each field specifier is a single type character followed by
an optional numeric \fIcount\fR. Most field specifiers consume one
argument to obtain the variable into which the scanned values should
be placed. The type character specifies how the binary data is to be
interpreted. The \fIcount\fR typically indicates how many items of
the specified type are taken from the data. If present, the
\fIcount\fR is a non-negative decimal integer or \fB*\fR, which
normally indicates that all of the remaining items in the data are to
be used. If there are not enough bytes left after the current cursor
position to satisfy the current field specifier, then the
corresponding variable is left untouched and \fBbinary scan\fR returns
immediately with the number of variables that were set. If there are
not enough arguments for all of the fields in the format string that
consume arguments, then an error is generated.
.PP
A similar example as with \fBbinary format\fR should explain the
relation between field specifiers and arguments in case of the binary
scan subcommand:
.CS
\fBbinary scan $bytes s3s first second\fR
.CE
.PP
This command (provided the binary string in the variable \fIbytes\fR
is long enough) assigns a list of three integers to the variable
\fIfirst\fR and assigns a single value to the variable \fIsecond\fR.
If \fIbytes\fR contains fewer than 8 bytes (i.e. four 2-byte
integers), no assignment to \fIsecond\fR will be made, and if
\fIbytes\fR contains fewer than 6 bytes (i.e. three 2-byte integers),
no assignment to \fIfirst\fR will be made. Hence:
.CS
\fBputs [binary scan abcdefg s3s first second]\fR
\fBputs $first\fR
\fBputs $second\fR
.CE
will print (assuming neither variable is set previously):
.CS
\fB1\fR
\fB25185 25699 26213\fR
\fIcan't read "second": no such variable\fR
.CE
.PP
It is \fBimportant\fR to note that the \fBc\fR, \fBs\fR, and \fBS\fR
(and \fBi\fR and \fBI\fR on 64bit systems) will be scanned into
long data size values. In doing this, values that have their high
bit set (0x80 for chars, 0x8000 for shorts, 0x80000000 for ints),
will be sign extended. Thus the following will occur:
.CS
\fBset signShort [binary format s1 0x8000]\fR
\fBbinary scan $signShort s1 val; \fI# val == 0xFFFF8000\fR
.CE
If you want to produce an unsigned value, then you can mask the return
value to the desired size. For example, to produce an unsigned short
value:
.CS
\fBset val [expr {$val & 0xFFFF}]; \fI# val == 0x8000\fR
.CE
.PP
Each type-count pair moves an imaginary cursor through the binary data,
reading bytes from the current position. The cursor is initially
at position 0 at the beginning of the data. The type may be any one of
the following characters:
.IP \fBa\fR 5
The data is a character string of length \fIcount\fR. If \fIcount\fR
is \fB*\fR, then all of the remaining bytes in \fIstring\fR will be
scanned into the variable. If \fIcount\fR is omitted, then one
character will be scanned.
All characters scanned will be interpreted as being in the
range \\u0000-\\u00ff so the \fBencoding convertfrom\fR command might be
needed if the string is not an ISO 8859\-1 string.
For example,
.RS
.CS
\fBbinary scan abcde\\000fghi a6a10 var1 var2\fR
.CE
will return \fB1\fR with the string equivalent to \fBabcde\\000\fR
stored in \fBvar1\fR and \fBvar2\fR left unmodified.
.RE
.IP \fBA\fR 5
This form is the same as \fBa\fR, except trailing blanks and nulls are stripped from
the scanned value before it is stored in the variable. For example,
.RS
.CS
\fBbinary scan "abc efghi \\000" A* var1\fR
.CE
will return \fB1\fR with \fBabc efghi\fR stored in \fBvar1\fR.
.RE
.IP \fBb\fR 5
The data is turned into a string of \fIcount\fR binary digits in
low-to-high order represented as a sequence of ``1'' and ``0''
characters. The data bytes are scanned in first to last order with
the bits being taken in low-to-high order within each byte. Any extra
bits in the last byte are ignored. If \fIcount\fR is \fB*\fR, then
all of the remaining bits in \fBstring\fR will be scanned. If
\fIcount\fR is omitted, then one bit will be scanned. For example,
.RS
.CS
\fBbinary scan \\x07\\x87\\x05 b5b* var1 var2\fR
.CE
will return \fB2\fR with \fB11100\fR stored in \fBvar1\fR and
\fB1110000110100000\fR stored in \fBvar2\fR.
.RE
.IP \fBB\fR 5
This form is the same as \fBb\fR, except the bits are taken in
high-to-low order within each byte. For example,
.RS
.CS
\fBbinary scan \\x70\\x87\\x05 B5B* var1 var2\fR
.CE
will return \fB2\fR with \fB01110\fR stored in \fBvar1\fR and
\fB1000011100000101\fR stored in \fBvar2\fR.
.RE
.IP \fBh\fR 5
The data is turned into a string of \fIcount\fR hexadecimal digits in
low-to-high order represented as a sequence of characters in the set
``0123456789abcdef''. The data bytes are scanned in first to last
order with the hex digits being taken in low-to-high order within each
byte. Any extra bits in the last byte are ignored. If \fIcount\fR
is \fB*\fR, then all of the remaining hex digits in \fBstring\fR will be
scanned. If \fIcount\fR is omitted, then one hex digit will be
scanned. For example,
.RS
.CS
\fBbinary scan \\x07\\x86\\x05 h3h* var1 var2\fR
.CE
will return \fB2\fR with \fB706\fR stored in \fBvar1\fR and
\fB50\fR stored in \fBvar2\fR.
.RE
.IP \fBH\fR 5
This form is the same as \fBh\fR, except the digits are taken in
high-to-low order within each byte. For example,
.RS
.CS
\fBbinary scan \\x07\\x86\\x05 H3H* var1 var2\fR
.CE
will return \fB2\fR with \fB078\fR stored in \fBvar1\fR and
\fB05\fR stored in \fBvar2\fR.
.RE
.IP \fBc\fR 5
The data is turned into \fIcount\fR 8-bit signed integers and stored
in the corresponding variable as a list. If \fIcount\fR is \fB*\fR,
then all of the remaining bytes in \fBstring\fR will be scanned. If
\fIcount\fR is omitted, then one 8-bit integer will be scanned. For
example,
.RS
.CS
\fBbinary scan \\x07\\x86\\x05 c2c* var1 var2\fR
.CE
will return \fB2\fR with \fB7 -122\fR stored in \fBvar1\fR and \fB5\fR
stored in \fBvar2\fR. Note that the integers returned are signed, but
they can be converted to unsigned 8-bit quantities using an expression
like:
.CS
\fBexpr { $num & 0xff }\fR
.CE
.RE
.IP \fBs\fR 5
The data is interpreted as \fIcount\fR 16-bit signed integers
represented in little-endian byte order. The integers are stored in
the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then
all of the remaining bytes in \fBstring\fR will be scanned. If
\fIcount\fR is omitted, then one 16-bit integer will be scanned. For
example,
.RS
.CS
\fBbinary scan \\x05\\x00\\x07\\x00\\xf0\\xff s2s* var1 var2\fR
.CE
will return \fB2\fR with \fB5 7\fR stored in \fBvar1\fR and \fB-16\fR
stored in \fBvar2\fR. Note that the integers returned are signed, but
they can be converted to unsigned 16-bit quantities using an expression
like:
.CS
\fBexpr { $num & 0xffff }\fR
.CE
.RE
.IP \fBS\fR 5
This form is the same as \fBs\fR except that the data is interpreted
as \fIcount\fR 16-bit signed integers represented in big-endian byte
order. For example,
.RS
.CS
\fBbinary scan \\x00\\x05\\x00\\x07\\xff\\xf0 S2S* var1 var2\fR
.CE
will return \fB2\fR with \fB5 7\fR stored in \fBvar1\fR and \fB-16\fR
stored in \fBvar2\fR.
.RE
.IP \fBi\fR 5
The data is interpreted as \fIcount\fR 32-bit signed integers
represented in little-endian byte order. The integers are stored in
the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then
all of the remaining bytes in \fBstring\fR will be scanned. If
\fIcount\fR is omitted, then one 32-bit integer will be scanned. For
example,
.RS
.CS
\fBbinary scan \\x05\\x00\\x00\\x00\\x07\\x00\\x00\\x00\\xf0\\xff\\xff\\xff i2i* var1 var2\fR
.CE
will return \fB2\fR with \fB5 7\fR stored in \fBvar1\fR and \fB-16\fR
stored in \fBvar2\fR. Note that the integers returned are signed, but
they can be converted to unsigned 32-bit quantities using an expression
like:
.CS
\fBexpr { $num & 0xffffffff }\fR
.CE
.RE
.IP \fBI\fR 5
This form is the same as \fBI\fR except that the data is interpreted
as \fIcount\fR 32-bit signed integers represented in big-endian byte
order. For example,
.RS
.CS
\fBbinary scan \\x00\\x00\\x00\\x05\\x00\\x00\\x00\\x07\\xff\\xff\\xff\\xf0 I2I* var1 var2\fR
.CE
will return \fB2\fR with \fB5 7\fR stored in \fBvar1\fR and \fB-16\fR
stored in \fBvar2\fR.
.RE
.IP \fBw\fR 5
.VS 8.4
The data is interpreted as \fIcount\fR 64-bit signed integers
represented in little-endian byte order. The integers are stored in
the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then
all of the remaining bytes in \fBstring\fR will be scanned. If
\fIcount\fR is omitted, then one 64-bit integer will be scanned. For
example,
.RS
.CS
\fBbinary scan \\x05\\x00\\x00\\x00\\x07\\x00\\x00\\x00\\xf0\\xff\\xff\\xff wi* var1 var2\fR
.CE
will return \fB2\fR with \fB30064771077\fR stored in \fBvar1\fR and
\fB-16\fR stored in \fBvar2\fR. Note that the integers returned are
signed and cannot be represented by Tcl as unsigned values.
.RE
.IP \fBW\fR 5
This form is the same as \fBw\fR except that the data is interpreted
as \fIcount\fR 64-bit signed integers represented in big-endian byte
order. For example,
.RS
.CS
\fBbinary scan \\x00\\x00\\x00\\x05\\x00\\x00\\x00\\x07\\xff\\xff\\xff\\xf0 WI* var1 var2\fR
.CE
will return \fB2\fR with \fB21474836487\fR stored in \fBvar1\fR and \fB-16\fR
stored in \fBvar2\fR.
.VE
.RE
.IP \fBf\fR 5
The data is interpreted as \fIcount\fR single-precision floating point
numbers in the machine's native representation. The floating point
numbers are stored in the corresponding variable as a list. If
\fIcount\fR is \fB*\fR, then all of the remaining bytes in
\fBstring\fR will be scanned. If \fIcount\fR is omitted, then one
single-precision floating point number will be scanned. The size of a
floating point number may vary across architectures, so the number of
bytes that are scanned may vary. If the data does not represent a
valid floating point number, the resulting value is undefined and
compiler dependent. For example, on a Windows system running on an
Intel Pentium processor,
.RS
.CS
\fBbinary scan \\x3f\\xcc\\xcc\\xcd f var1\fR
.CE
will return \fB1\fR with \fB1.6000000238418579\fR stored in
\fBvar1\fR.
.RE
.IP \fBd\fR 5
This form is the same as \fBf\fR except that the data is interpreted
as \fIcount\fR double-precision floating point numbers in the
machine's native representation. For example, on a Windows system
running on an Intel Pentium processor,
.RS
.CS
\fBbinary scan \\x9a\\x99\\x99\\x99\\x99\\x99\\xf9\\x3f d var1\fR
.CE
will return \fB1\fR with \fB1.6000000000000001\fR
stored in \fBvar1\fR.
.RE
.IP \fBx\fR 5
Moves the cursor forward \fIcount\fR bytes in \fIstring\fR. If
\fIcount\fR is \fB*\fR or is larger than the number of bytes after the
current cursor cursor position, then the cursor is positioned after
the last byte in \fIstring\fR. If \fIcount\fR is omitted, then the
cursor is moved forward one byte. Note that this type does not
consume an argument. For example,
.RS
.CS
\fBbinary scan \\x01\\x02\\x03\\x04 x2H* var1\fR
.CE
will return \fB1\fR with \fB0304\fR stored in \fBvar1\fR.
.RE
.IP \fBX\fR 5
Moves the cursor back \fIcount\fR bytes in \fIstring\fR. If
\fIcount\fR is \fB*\fR or is larger than the current cursor position,
then the cursor is positioned at location 0 so that the next byte
scanned will be the first byte in \fIstring\fR. If \fIcount\fR
is omitted then the cursor is moved back one byte. Note that this
type does not consume an argument. For example,
.RS
.CS
\fBbinary scan \\x01\\x02\\x03\\x04 c2XH* var1 var2\fR
.CE
will return \fB2\fR with \fB1 2\fR stored in \fBvar1\fR and \fB020304\fR
stored in \fBvar2\fR.
.RE
.IP \fB@\fR 5
Moves the cursor to the absolute location in the data string specified
by \fIcount\fR. Note that position 0 refers to the first byte in
\fIstring\fR. If \fIcount\fR refers to a position beyond the end of
\fIstring\fR, then the cursor is positioned after the last byte. If
\fIcount\fR is omitted, then an error will be generated. For example,
.RS
.CS
\fBbinary scan \\x01\\x02\\x03\\x04 c2@1H* var1 var2\fR
.CE
will return \fB2\fR with \fB1 2\fR stored in \fBvar1\fR and \fB020304\fR
stored in \fBvar2\fR.
.RE
.SH "PLATFORM ISSUES"
Sometimes it is desirable to format or scan integer values in the
native byte order for the machine. Refer to the \fBbyteOrder\fR
element of the \fBtcl_platform\fR array to decide which type character
to use when formatting or scanning integers.
.SH EXAMPLES
This is a procedure to write a Tcl string to a binary-encoded channel as
UTF-8 data preceded by a length word:
.CS
proc writeString {channel string} {
set data [encoding convertto utf-8 $string]
puts -nonewline [\fBbinary format\fR Ia* \e
[string length $data] $data]
}
.CE
.PP
This procedure reads a string from a channel that was written by the
previously presented \fBwriteString\fR procedure:
.CS
proc readString {channel} {
if {![\fBbinary scan\fR [read $channel 4] I length]} {
error "missing length"
}
set data [read $channel $length]
return [encoding convertfrom utf-8 $data]
}
.CE
.SH "SEE ALSO"
format(n), scan(n), tclvars(n)
.SH KEYWORDS
binary, format, scan
tcl8.4.20/doc/Tcl_Main.3 0000644 0036047 0045461 00000014637 11737050674 013251 0 ustar dgp 771div '\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Main, Tcl_SetMainLoop \- main program and event loop definition for Tcl-based applications
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_Main\fR(\fIargc, argv, appInitProc\fR)
.sp
\fBTcl_SetMainLoop\fR(\fImainLoopProc\fR)
.SH ARGUMENTS
.AS Tcl_AppInitProc *appInitProc
.AP int argc in
Number of elements in \fIargv\fR.
.AP char *argv[] in
Array of strings containing command-line arguments.
.AP Tcl_AppInitProc *appInitProc in
Address of an application-specific initialization procedure.
The value for this argument is usually \fBTcl_AppInit\fR.
.AP Tcl_MainLoopProc *mainLoopProc in
Address of an application-specific event loop procedure.
.BE
.SH DESCRIPTION
.PP
\fBTcl_Main\fR can serve as the main program for Tcl-based shell
applications. A ``shell application'' is a program
like tclsh or wish that supports both interactive interpretation
of Tcl and evaluation of a script contained in a file given as
a command line argument. \fBTcl_Main\fR is offered as a convenience
to developers of shell applications, so they do not have to
reproduce all of the code for proper initialization of the Tcl
library and interactive shell operation. Other styles of embedding
Tcl in an application are not supported by \fBTcl_Main\fR. Those
must be achieved by calling lower level functions in the Tcl library
directly.
The \fBTcl_Main\fR function has been offered by the Tcl library
since release Tcl 7.4. In older releases of Tcl, the Tcl library
itself defined a function \fBmain\fR, but that lacks flexibility
of embedding style and having a function \fBmain\fR in a library
(particularly a shared library) causes problems on many systems.
Having \fBmain\fR in the Tcl library would also make it hard to use
Tcl in C++ programs, since C++ programs must have special C++
\fBmain\fR functions.
.PP
Normally each shell application contains a small \fBmain\fR function
that does nothing but invoke \fBTcl_Main\fR.
\fBTcl_Main\fR then does all the work of creating and running a
\fBtclsh\fR-like application.
.PP
\fBTcl_Main\fR is not provided by the public interface of Tcl's
stub library. Programs that call \fBTcl_Main\fR must be linked
against the standard Tcl library. Extensions (stub-enabled or
not) are not intended to call \fBTcl_Main\fR.
.PP
\fBTcl_Main\fR is not thread-safe. It should only be called by
a single master thread of a multi-threaded application. This
restriction is not a problem with normal use described above.
.PP
\fBTcl_Main\fR and therefore all applications based upon it, like
\fBtclsh\fR, use \fBTcl_GetStdChannel\fR to initialize the standard
channels to their default values. See \fBTcl_StandardChannels\fR for
more information.
.PP
\fBTcl_Main\fR supports two modes of operation, depending on the
values of \fIargc\fR and \fIargv\fR. If \fIargv[1]\fR exists and
does not begin with the character \fI-\fR, it is taken to be the
name of a file containing a \fIstartup script\fR, which \fBTcl_Main\fR
will attempt to evaluate. Otherwise, \fBTcl_Main\fR will enter an
interactive mode.
.PP
In either mode, \fBTcl_Main\fR will define in its master interpreter
the Tcl variables \fIargc\fR, \fIargv\fR, \fIargv0\fR, and
\fItcl_interactive\fR, as described in the documentation for \fBtclsh\fR.
.PP
When it has finished its own initialization, but before it processes
commands, \fBTcl_Main\fR calls the procedure given by the
\fIappInitProc\fR argument. This procedure provides a ``hook'' for
the application to perform its own initialization of the interpreter
created by \fBTcl_Main\fR, such as defining application-specific
commands. The procedure must have an interface that matches the
type \fBTcl_AppInitProc\fR:
.CS
typedef int Tcl_AppInitProc(Tcl_Interp *\fIinterp\fR);
.CE
\fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR; for more
details on this procedure, see the documentation for \fBTcl_AppInit\fR.
.PP
When the \fIappInitProc\fR is finished, \fBTcl_Main\fR enters one
of its two modes. If a startup script has been provided, \fBTcl_Main\fR
attempts to evaluate it. Otherwise, interactive mode begins with
examination of the variable \fItcl_rcFileName\fR in the master
interpreter. If that variable exists and holds the name of a readable
file, the contents of that file are evaluated in the master interpreter.
Then interactive operations begin,
with prompts and command evaluation results written to the standard
output channel, and commands read from the standard input channel
and then evaluated. The prompts written to the standard output
channel may be customized by defining the Tcl variables \fItcl_prompt1\fR
and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR.
The prompts and command evaluation results are written to the standard
output channel only if the Tcl variable \fItcl_interactive\fR in the
master interpreter holds a non-zero integer value.
.PP
.VS 8.4
\fBTcl_SetMainLoop\fR allows setting an event loop procedure to be run.
This allows, for example, Tk to be dynamically loaded and set its event
loop. The event loop will run following the startup script. If you
are in interactive mode, setting the main loop procedure will cause the
prompt to become fileevent based and then the loop procedure is called.
When the loop procedure returns in interactive mode, interactive operation
will continue.
The main loop procedure must have an interface that matches the type
\fBTcl_MainLoopProc\fR:
.CS
typedef void Tcl_MainLoopProc(void);
.CE
.VE 8.4
.PP
\fBTcl_Main\fR does not return. Normally a program based on
\fBTcl_Main\fR will terminate when the \fBexit\fR command is
evaluated. In interactive mode, if an EOF or channel error
is encountered on the standard input channel, then \fBTcl_Main\fR
itself will evaluate the \fBexit\fR command after the main loop
procedure (if any) returns. In non-interactive mode, after
\fBTcl_Main\fR evaluates the startup script, and the main loop
procedure (if any) returns, \fBTcl_Main\fR will also evaluate
the \fBexit\fR command.
.SH "SEE ALSO"
tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3),
exit(n)
.SH KEYWORDS
application-specific initialization, command-line arguments, main program
tcl8.4.20/doc/ChnlStack.3 0000644 0036047 0045461 00000007462 11737050674 013433 0 ustar dgp 771div '\"
'\" Copyright (c) 1999-2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.so man.macros
.TH Tcl_StackChannel 3 8.3 Tcl "Tcl Library Procedures"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_StackChannel, Tcl_UnstackChannel, Tcl_GetStackedChannel, Tcl_GetTopChannel \- stack an I/O channel on top of another, and undo it
.SH SYNOPSIS
.nf
.nf
\fB#include \fR
.sp
Tcl_Channel
\fBTcl_StackChannel\fR(\fIinterp, typePtr, clientData, mask, channel\fR)
.sp
int
\fBTcl_UnstackChannel\fR(\fIinterp, channel\fR)
.sp
Tcl_Channel
\fBTcl_GetStackedChannel\fR(\fIchannel\fR)
.sp
Tcl_Channel
\fBTcl_GetTopChannel\fR(\fIchannel\fR)
.sp
.SH ARGUMENTS
.AS Tcl_ChannelType
.AP Tcl_Interp *interp in
Interpreter for error reporting.
.AP Tcl_ChannelType *typePtr in
The new channel I/O procedures to use for \fIchannel\fP.
.AP ClientData clientData in
Arbitrary one-word value to pass to channel I/O procedures.
.AP int mask in
Conditions under which \fIchannel\fR will be used: OR-ed combination of
\fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR.
This can be a subset of the operations currently allowed on \fIchannel\fP.
.AP Tcl_Channel channel in
An existing Tcl channel such as returned by \fBTcl_CreateChannel\fR.
.BE
.SH DESCRIPTION
.PP
These functions are for use by extensions that add processing layers to Tcl
I/O channels. Examples include compression and encryption modules. These
functions transparently stack and unstack a new channel on top of an
existing one. Any number of channels can be stacked together.
.PP
The implementation of the Tcl channel code was rewritten in 8.3.2 to
correct some problems with the previous implementation with regard to
stacked channels. Anyone using stacked channels or creating stacked
channel drivers should update to the new \fBTCL_CHANNEL_VERSION_2\fR
\fBTcl_ChannelType\fR structure. See \fBTcl_CreateChannel\fR for details.
.PP
\fBTcl_StackChannel\fR stacks a new \fIchannel\fP on an existing channel
with the same name that was registered for \fIchannel\fP by
\fBTcl_RegisterChannel\fP.
.PP
\fBTcl_StackChannel\fR works by creating a new channel structure and
placing itself on top of the channel stack. EOL translation, encoding and
buffering options are shared between all channels in the stack. The hidden
channel does no buffering, newline translations, or character set encoding.
Instead, the buffering, newline translations, and encoding functions all
remain at the top of the channel stack. A pointer to the new top channel
structure is returned. If an error occurs when stacking the channel, NULL
is returned instead.
.PP
The \fImask\fP parameter specifies the operations that are allowed on the
new channel. These can be a subset of the operations allowed on the
original channel. For example, a read-write channel may become read-only
after the \fBTcl_StackChannel\fR call.
.PP
Closing a channel closes the channels stacked below it. The close of
stacked channels is executed in a way that allows buffered data to be
properly flushed.
.PP
\fBTcl_UnstackChannel\fP reverses the process. The old channel is
associated with the channel name, and the processing module added by
\fBTcl_StackChannel\fR is destroyed. If there is no old channel, then
\fBTcl_UnstackChannel\fP is equivalent to \fBTcl_Close\fP. If an error
occurs unstacking the channel, \fBTCL_ERROR\fR is returned, otherwise
\fBTCL_OK\fR is returned.
.PP
\fBTcl_GetTopChannel\fR returns the top channel in the stack of
channels the supplied channel is part of.
.PP
\fBTcl_GetStackedChannel\fR returns the channel in the stack of
channels which is just below the supplied channel.
.SH "SEE ALSO"
Notifier(3), Tcl_CreateChannel(3), Tcl_OpenFileChannel(3), vwait(n).
.SH KEYWORDS
channel, compression
tcl8.4.20/doc/Translate.3 0000644 0036047 0045461 00000004446 11737050674 013515 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-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.
'\"
.so man.macros
.TH Tcl_TranslateFileName 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_TranslateFileName \- convert file name to native form and replace tilde with home directory
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
char *
\fBTcl_TranslateFileName\fR(\fIinterp\fR, \fIname\fR, \fIbufferPtr\fR)
.SH ARGUMENTS
.AS Tcl_DString *bufferPtr
.AP Tcl_Interp *interp in
Interpreter in which to report an error, if any.
.AP "CONST char" *name in
File name, which may start with a ``~''.
.AP Tcl_DString *bufferPtr in/out
If needed, this dynamic string is used to store the new file name.
At the time of the call it should be uninitialized or free. The
caller must eventually call \fBTcl_DStringFree\fR to free up
anything stored here.
.BE
.SH DESCRIPTION
.PP
This utility procedure translates a file name to a form suitable for
passing to the local operating system. It converts network names into
native form and does tilde substitution.
.PP
If
\fBTcl_TranslateFileName\fR has to do tilde substitution or translate
the name then it uses
the dynamic string at \fI*bufferPtr\fR to hold the new string it
generates.
After \fBTcl_TranslateFileName\fR returns a non-NULL result, the caller must
eventually invoke \fBTcl_DStringFree\fR to free any information
placed in \fI*bufferPtr\fR. The caller need not know whether or
not \fBTcl_TranslateFileName\fR actually used the string; \fBTcl_TranslateFileName\fR
initializes \fI*bufferPtr\fR even if it doesn't use it, so the call to
\fBTcl_DStringFree\fR will be safe in either case.
.PP
If an error occurs (e.g. because there was no user by the given
name) then NULL is returned and an error message will be left
in the interpreter's result.
When an error occurs, \fBTcl_TranslateFileName\fR
frees the dynamic string itself so that the caller need not call
\fBTcl_DStringFree\fR.
.PP
The caller is responsible for making sure that the interpreter's result
has its default empty value when \fBTcl_TranslateFileName\fR is invoked.
.SH "SEE ALSO"
filename
.SH KEYWORDS
file name, home directory, tilde, translate, user
tcl8.4.20/doc/TraceVar.3 0000644 0036047 0045461 00000040423 11737050674 013262 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_TraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR
.sp
int
\fBTcl_TraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR
.sp
\fBTcl_UntraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR
.sp
\fBTcl_UntraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR
.sp
ClientData
\fBTcl_VarTraceInfo(\fIinterp, varName, flags, proc, prevClientData\fB)\fR
.sp
ClientData
\fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR
.SH ARGUMENTS
.AS Tcl_VarTraceProc prevClientData
.AP Tcl_Interp *interp in
Interpreter containing variable.
.AP "CONST char" *varName in
Name of variable. May refer to a scalar variable, to
an array variable with no index, or to an array variable
with a parenthesized index.
.AP int flags in
OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES,
TCL_TRACE_UNSETS, TCL_TRACE_ARRAY, TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
TCL_TRACE_RESULT_DYNAMIC and TCL_TRACE_RESULT_OBJECT.
Not all flags are used by all
procedures. See below for more information.
.AP Tcl_VarTraceProc *proc in
Procedure to invoke whenever one of the traced operations occurs.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.AP "CONST char" *name1 in
Name of scalar or array variable (without array index).
.AP "CONST char" *name2 in
For a trace on an element of an array, gives the index of the
element. For traces on scalar variables or on whole arrays,
is NULL.
.AP ClientData prevClientData in
If non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or
\fBTcl_VarTraceInfo2\fR, so this call will return information about
next trace. If NULL, this call will return information about first
trace.
.BE
.SH DESCRIPTION
.PP
\fBTcl_TraceVar\fR allows a C procedure to monitor and control
access to a Tcl variable, so that the C procedure is invoked
whenever the variable is read or written or unset.
If the trace is created successfully then \fBTcl_TraceVar\fR returns
TCL_OK. If an error occurred (e.g. \fIvarName\fR specifies an element
of an array, but the actual variable isn't an array) then TCL_ERROR
is returned and an error message is left in the interpreter's result.
.PP
The \fIflags\fR argument to \fBTcl_TraceVar\fR indicates when the
trace procedure is to be invoked and provides information
for setting up the trace. It consists of an OR-ed combination
of any of the following values:
.TP
\fBTCL_GLOBAL_ONLY\fR
Normally, the variable will be looked up at the current level of
procedure call; if this bit is set then the variable will be looked
up at global level, ignoring any active procedures.
.TP
\fBTCL_NAMESPACE_ONLY\fR
Normally, the variable will be looked up at the current level of
procedure call; if this bit is set then the variable will be looked
up in the current namespace, ignoring any active procedures.
.TP
\fBTCL_TRACE_READS\fR
Invoke \fIproc\fR whenever an attempt is made to read the variable.
.TP
\fBTCL_TRACE_WRITES\fR
Invoke \fIproc\fR whenever an attempt is made to modify the variable.
.TP
\fBTCL_TRACE_UNSETS\fR
Invoke \fIproc\fR whenever the variable is unset.
A variable may be unset either explicitly by an \fBunset\fR command,
or implicitly when a procedure returns (its local variables are
automatically unset) or when the interpreter is deleted (all
variables are automatically unset).
.TP
\fBTCL_TRACE_ARRAY\fR
Invoke \fIproc\fR whenever the array command is invoked.
This gives the trace procedure a chance to update the array before
array names or array get is called. Note that this is called
before an array set, but that will trigger write traces.
.VS 8.4
.TP
\fBTCL_TRACE_RESULT_DYNAMIC\fR
The result of invoking the \fIproc\fR is a dynamically allocated
string that will be released by the Tcl library via a call to
\fBckfree\fR. Must not be specified at the same time as
TCL_TRACE_RESULT_OBJECT.
.TP
\fBTCL_TRACE_RESULT_OBJECT\fR
The result of invoking the \fIproc\fR is a Tcl_Obj* (cast to a char*)
with a reference count of at least one. The ownership of that
reference will be transferred to the Tcl core for release (when the
core has finished with it) via a call to \fBTcl_DecrRefCount\fR. Must
not be specified at the same time as TCL_TRACE_RESULT_DYNAMIC.
.VE 8.4
.PP
Whenever one of the specified operations occurs on the variable,
\fIproc\fR will be invoked.
It should have arguments and result that match the type
\fBTcl_VarTraceProc\fR:
.CS
typedef char *Tcl_VarTraceProc(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
char *\fIname1\fR,
char *\fIname2\fR,
int \fIflags\fR);
.CE
The \fIclientData\fR and \fIinterp\fR parameters will
have the same values as those passed to \fBTcl_TraceVar\fR when the
trace was created.
\fIClientData\fR typically points to an application-specific
data structure that describes what to do when \fIproc\fR
is invoked.
\fIName1\fR and \fIname2\fR give the name of the traced variable
in the normal two-part form (see the description of \fBTcl_TraceVar2\fR
below for details).
\fIFlags\fR is an OR-ed combination of bits providing several
pieces of information.
One of the bits TCL_TRACE_READS, TCL_TRACE_WRITES, TCL_TRACE_ARRAY,
or TCL_TRACE_UNSETS
will be set in \fIflags\fR to indicate which operation is being performed
on the variable.
The bit TCL_GLOBAL_ONLY will be set whenever the variable being
accessed is a global one not accessible from the current level of
procedure call: the trace procedure will need to pass this flag
back to variable-related procedures like \fBTcl_GetVar\fR if it
attempts to access the variable.
The bit TCL_NAMESPACE_ONLY will be set whenever the variable being
accessed is a namespace one not accessible from the current level of
procedure call: the trace procedure will need to pass this flag
back to variable-related procedures like \fBTcl_GetVar\fR if it
attempts to access the variable.
The bit TCL_TRACE_DESTROYED will be set in \fIflags\fR if the trace is
about to be destroyed; this information may be useful to \fIproc\fR
so that it can clean up its own internal data structures (see
the section TCL_TRACE_DESTROYED below for more details).
Lastly, the bit TCL_INTERP_DESTROYED will be set if the entire
interpreter is being destroyed.
When this bit is set, \fIproc\fR must be especially careful in
the things it does (see the section TCL_INTERP_DESTROYED below).
The trace procedure's return value should normally be NULL; see
ERROR RETURNS below for information on other possibilities.
.PP
\fBTcl_UntraceVar\fR may be used to remove a trace.
If the variable specified by \fIinterp\fR, \fIvarName\fR, and \fIflags\fR
has a trace set with \fIflags\fR, \fIproc\fR, and
\fIclientData\fR, then the corresponding trace is removed.
If no such trace exists, then the call to \fBTcl_UntraceVar\fR
has no effect.
The same bits are valid for \fIflags\fR as for calls to \fBTcl_TraceVar\fR.
.PP
\fBTcl_VarTraceInfo\fR may be used to retrieve information about
traces set on a given variable.
The return value from \fBTcl_VarTraceInfo\fR is the \fIclientData\fR
associated with a particular trace.
The trace must be on the variable specified by the \fIinterp\fR,
\fIvarName\fR, and \fIflags\fR arguments (only the TCL_GLOBAL_ONLY and
TCL_NAMESPACE_ONLY bits from \fIflags\fR is used; other bits are
ignored) and its trace procedure must the same as the \fIproc\fR
argument.
If the \fIprevClientData\fR argument is NULL then the return
value corresponds to the first (most recently created) matching
trace, or NULL if there are no matching traces.
If the \fIprevClientData\fR argument isn't NULL, then it should
be the return value from a previous call to \fBTcl_VarTraceInfo\fR.
In this case, the new return value will correspond to the next
matching trace after the one whose \fIclientData\fR matches
\fIprevClientData\fR, or NULL if no trace matches \fIprevClientData\fR
or if there are no more matching traces after it.
This mechanism makes it possible to step through all of the
traces for a given variable that have the same \fIproc\fR.
.SH "TWO-PART NAMES"
.PP
The procedures \fBTcl_TraceVar2\fR, \fBTcl_UntraceVar2\fR, and
\fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR,
\fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively,
except that the name of the variable consists of two parts.
\fIName1\fR gives the name of a scalar variable or array,
and \fIname2\fR gives the name of an element within an array.
.VS 8.1
When \fIname2\fR is NULL,
\fIname1\fR may contain both an array and an element name:
if the name contains an open parenthesis and ends with a
close parenthesis, then the value between the parentheses is
treated as an element name (which can have any string value) and
the characters before the first open
parenthesis are treated as the name of an array variable.
If \fIname2\fR is NULL and \fIname1\fR does not refer
to an array element
.VE
it means that either the variable is
a scalar or the trace is to be set on the entire array rather
than an individual element (see WHOLE-ARRAY TRACES below for
more information).
.SH "ACCESSING VARIABLES DURING TRACES"
.PP
During read, write, and array traces, the
trace procedure can read, write, or unset the traced
variable using \fBTcl_GetVar2\fR, \fBTcl_SetVar2\fR, and
other procedures.
While \fIproc\fR is executing, traces are temporarily disabled
for the variable, so that calls to \fBTcl_GetVar2\fR and
\fBTcl_SetVar2\fR will not cause \fIproc\fR or other trace procedures
to be invoked again.
Disabling only occurs for the variable whose trace procedure
is active; accesses to other variables will still be traced.
However, if a variable is unset during a read or write trace then unset
traces will be invoked.
.PP
During unset traces the variable has already been completely
expunged.
It is possible for the trace procedure to read or write the
variable, but this will be a new version of the variable.
Traces are not disabled during unset traces as they are for
read and write traces, but existing traces have been removed
from the variable before any trace procedures are invoked.
If new traces are set by unset trace procedures, these traces
will be invoked on accesses to the variable by the trace
procedures.
.SH "CALLBACK TIMING"
.PP
When read tracing has been specified for a variable, the trace
procedure will be invoked whenever the variable's value is
read. This includes \fBset\fR Tcl commands, \fB$\fR-notation
in Tcl commands, and invocations of the \fBTcl_GetVar\fR
and \fBTcl_GetVar2\fR procedures.
\fIProc\fR is invoked just before the variable's value is
returned.
It may modify the value of the variable to affect what
is returned by the traced access.
If it unsets the variable then the access will return an error
just as if the variable never existed.
.PP
When write tracing has been specified for a variable, the
trace procedure will be invoked whenever the variable's value
is modified. This includes \fBset\fR commands,
commands that modify variables as side effects (such as
\fBcatch\fR and \fBscan\fR), and calls to the \fBTcl_SetVar\fR
and \fBTcl_SetVar2\fR procedures).
\fIProc\fR will be invoked after the variable's value has been
modified, but before the new value of the variable has been
returned.
It may modify the value of the variable to override the change
and to determine the value actually returned by the traced
access.
If it deletes the variable then the traced access will return
an empty string.
.PP
When array tracing has been specified, the trace procedure
will be invoked at the beginning of the array command implementation,
before any of the operations like get, set, or names have been invoked.
The trace procedure can modify the array elements with \fBTcl_SetVar\fR
and \fBTcl_SetVar2\fR.
.PP
When unset tracing has been specified, the trace procedure
will be invoked whenever the variable is destroyed.
The traces will be called after the variable has been
completely unset.
.SH "WHOLE-ARRAY TRACES"
.PP
If a call to \fBTcl_TraceVar\fR or \fBTcl_TraceVar2\fR specifies
the name of an array variable without an index into the array,
then the trace will be set on the array as a whole.
This means that \fIproc\fR will be invoked whenever any
element of the array is accessed in the ways specified by
\fIflags\fR.
When an array is unset, a whole-array trace will be invoked
just once, with \fIname1\fR equal to the name of the array
and \fIname2\fR NULL; it will not be invoked once for each
element.
.SH "MULTIPLE TRACES"
.PP
It is possible for multiple traces to exist on the same variable.
When this happens, all of the trace procedures will be invoked on each
access, in order from most-recently-created to least-recently-created.
When there exist whole-array traces for an array as well as
traces on individual elements, the whole-array traces are invoked
before the individual-element traces.
If a read or write trace unsets the variable then all of the unset
traces will be invoked but the remainder of the read and write traces
will be skipped.
.SH "ERROR RETURNS"
.PP
Under normal conditions trace procedures should return NULL, indicating
successful completion.
If \fIproc\fR returns a non-NULL value it signifies that an
error occurred.
The return value must be a pointer to a static character string
containing an error message,
.VS 8.4
unless (\fIexactly\fR one of) the TCL_TRACE_RESULT_DYNAMIC and
TCL_TRACE_RESULT_OBJECT flags is set, which specify that the result is
either a dynamic string (to be released with \fBckfree\fR) or a
Tcl_Obj* (cast to char* and to be released with
\fBTcl_DecrRefCount\fR) containing the error message.
.VE 8.4
If a trace procedure returns an error, no further traces are
invoked for the access and the traced access aborts with the
given message.
Trace procedures can use this facility to make variables
read-only, for example (but note that the value of the variable
will already have been modified before the trace procedure is
called, so the trace procedure will have to restore the correct
value).
.PP
The return value from \fIproc\fR is only used during read and
write tracing.
During unset traces, the return value is ignored and all relevant
trace procedures will always be invoked.
.SH "RESTRICTIONS"
.PP
A trace procedure can be called at any time, even when there
is a partially-formed result in the interpreter's result area. If
the trace procedure does anything that could damage this result (such
as calling \fBTcl_Eval\fR) then it must save the original values of
the interpreter's \fBresult\fR and \fBfreeProc\fR fields and restore
them before it returns.
.SH "UNDEFINED VARIABLES"
.PP
It is legal to set a trace on an undefined variable.
The variable will still appear to be undefined until the
first time its value is set.
If an undefined variable is traced and then unset, the unset will fail
with an error (``no such variable''), but the trace
procedure will still be invoked.
.SH "TCL_TRACE_DESTROYED FLAG"
.PP
In an unset callback to \fIproc\fR, the TCL_TRACE_DESTROYED bit
is set in \fIflags\fR if the trace is being removed as part
of the deletion.
Traces on a variable are always removed whenever the variable
is deleted; the only time TCL_TRACE_DESTROYED isn't set is for
a whole-array trace invoked when only a single element of an
array is unset.
.SH "TCL_INTERP_DESTROYED"
.PP
When an interpreter is destroyed, unset traces are called for
all of its variables.
The TCL_INTERP_DESTROYED bit will be set in the \fIflags\fR
argument passed to the trace procedures.
Trace procedures must be extremely careful in what they do if
the TCL_INTERP_DESTROYED bit is set.
It is not safe for the procedures to invoke any Tcl procedures
on the interpreter, since its state is partially deleted.
All that trace procedures should do under these circumstances is
to clean up and free their own internal data structures.
.SH BUGS
.PP
Tcl doesn't do any error checking to prevent trace procedures
from misusing the interpreter during traces with TCL_INTERP_DESTROYED
set.
.PP
Array traces are not yet integrated with the Tcl "info exists" command,
nor is there Tcl-level access to array traces.
.SH KEYWORDS
clientData, trace, variable
tcl8.4.20/doc/glob.n 0000644 0036047 0045461 00000017637 12052456743 012602 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH glob n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
glob \- Return names of files that match patterns
.SH SYNOPSIS
\fBglob \fR?\fIswitches\fR? \fIpattern \fR?\fIpattern ...\fR?
.BE
.SH DESCRIPTION
.PP
This command performs file name ``globbing'' in a fashion similar to
the csh shell. It returns a list of the files whose names match any
of the \fIpattern\fR arguments.
.LP
If the initial arguments to \fBglob\fR start with \fB\-\fR then
they are treated as switches. The following switches are
currently supported:
.VS 8.3
.TP
\fB\-directory\fR \fIdirectory\fR
Search for files which match the given patterns starting in the given
\fIdirectory\fR. This allows searching of directories whose name
contains glob-sensitive characters without the need to quote such
characters explicitly. This option may not be used in conjunction with
\fB\-path\fR, which is used to allow searching for complete file paths
whose names may contain glob-sensitive characters.
.TP
\fB\-join\fR
The remaining pattern arguments are treated as a single pattern
obtained by joining the arguments with directory separators.
.VE 8.3
.TP
\fB\-nocomplain\fR
Allows an empty list to be returned without error; without this
switch an error is returned if the result list would be empty.
.VS 8.3
.TP
\fB\-path\fR \fIpathPrefix\fR
Search for files with the given \fIpathPrefix\fR where the rest of the name
matches the given patterns. This allows searching for files with names
similar to a given file (as opposed to a directory) even when the names
contain glob-sensitive
characters. This option may not be used in conjunction with
\fB\-directory\fR. For example, to find all files with the same root name
as $path, but differing extensions, you should use \fBglob
-path [file rootname $path] .*\fR which will work even if $path contains
numerous glob-sensitive characters.
.TP
\fB\-tails\fR
Only return the part of each file found which follows the last directory
named in any \fB\-directory\fR or \fB\-path\fR path specification.
Thus \fBglob -tails -directory $dir *\fR is equivalent to
\fBset pwd [pwd] ; cd $dir ; glob *; cd $pwd\fR. For
\fB\-path\fR specifications, the returned names will include the last
path segment, so \fBglob -tails -path [file rootname ~/foo.tex] .*\fR
will return paths like \fBfoo.aux foo.bib foo.tex\fR etc.
.TP
\fB\-types\fR \fItypeList\fR
Only list files or directories which match \fItypeList\fR, where the items
in the list have two forms. The first form is like the \-type option of
the Unix find command:
\fIb\fR (block special file),
\fIc\fR (character special file),
\fId\fR (directory),
\fIf\fR (plain file),
\fIl\fR (symbolic link),
\fIp\fR (named pipe),
or \fIs\fR (socket), where multiple types may be specified in the list.
\fBGlob\fR will return all files which match at least one of the types given.
Note that symbolic links will be returned both if \fB\-types l\fR is given,
or if the target of a link matches the requested type. So, a link to
a directory will be returned if \fB\-types d\fR was specified.
.RS
.PP
The second form specifies types where all the types given must match.
These are \fIr\fR, \fIw\fR, \fIx\fR as file permissions, and
\fIreadonly\fR, \fIhidden\fR as special permission cases.
.PP
The two forms may be mixed, so \fB\-types {d f r w}\fR will find all
regular files OR directories that have both read AND write permissions.
The following are equivalent:
.RS
.CS
\fBglob \-type d *\fR
\fBglob */\fR
.CE
.RE
except that the first case doesn't return the trailing ``/'' and
is more platform independent.
.RE
.VE 8.3
.TP
\fB\-\|\-\fR
Marks the end of switches. The argument following this one will
be treated as a \fIpattern\fR even if it starts with a \fB\-\fR.
.PP
The \fIpattern\fR arguments may contain any of the following
special characters:
.TP 10
\fB?\fR
Matches any single character.
.TP 10
\fB*\fR
Matches any sequence of zero or more characters.
.TP 10
\fB[\fIchars\fB]\fR
Matches any single character in \fIchars\fR. If \fIchars\fR
contains a sequence of the form \fIa\fB\-\fIb\fR then any
character between \fIa\fR and \fIb\fR (inclusive) will match.
.TP 10
\fB\e\fIx\fR
Matches the character \fIx\fR.
.TP 10
\fB{\fIa\fB,\fIb\fB,\fI...\fR}
Matches any of the strings \fIa\fR, \fIb\fR, etc.
.LP
On Unix, as with csh, a ``.'' at the beginning of a file's name or just
after a ``/'' must be matched explicitly or with a {} construct,
unless the ``-types hidden'' flag is given (since ``.'' at the beginning
of a file's name indicates that it is hidden). On other platforms,
files beginning with a ``.'' are handled no differently to any others,
except the special directories ``.'' and ``..'' which must be matched
explicitly (this is to avoid a recursive pattern like ``glob -join * *
* *'' from recursing up the directory hierarchy as well as down).
In addition, all ``/'' characters must be matched explicitly.
.LP
If the first character in a \fIpattern\fR is ``~'' then it refers
to the home directory for the user whose name follows the ``~''.
If the ``~'' is followed immediately by ``/'' then the value of
the HOME environment variable is used.
.LP
The \fBglob\fR command differs from csh globbing in two ways.
First, it does not sort its result list (use the \fBlsort\fR
command if you want the list sorted).
Second, \fBglob\fR only returns the names of files that actually
exist; in csh no check for existence is made unless a pattern
contains a ?, *, or [] construct.
.LP
When the \fBglob\fR command returns relative paths whose filenames
start with a tilde ``~'' (for example through \fBglob *\fR or
\fBglob -tails\fR, the returned list will not quote the tilde with
``./''. This means care must be taken if those names are later to
be used with \fBfile join\fR, to avoid them being interpreted as
absolute paths pointing to a given user's home directory.
.SH "PORTABILITY ISSUES"
.PP
Unlike other Tcl commands that will accept both network and native
style names (see the \fBfilename\fR manual entry for details on how
native and network names are specified), the \fBglob\fR command only
accepts native names.
.TP
\fBWindows\fR
.
For Windows UNC names, the servername and sharename components of the path
may not contain ?, *, or [] constructs. On Windows NT, if \fIpattern\fR is
of the form ``\fB~\fIusername\fB@\fIdomain\fR'' it refers to the home
directory of the user whose account information resides on the specified NT
domain server. Otherwise, user account information is obtained from
the local computer. On Windows 95 and 98, \fBglob\fR accepts patterns
like ``.../'' and ``..../'' for successively higher up parent directories.
.
Since the backslash character has a special meaning to the glob
command, glob patterns containing Windows style path separators need
special care. The pattern \fIC:\e\efoo\e\e*\fR is interpreted as
\fIC:\efoo\e*\fR where \fI\ef\fR will match the single character \fIf\fR
and \fI\e*\fR will match the single character \fI*\fR and will not be
interpreted as a wildcard character. One solution to this problem is
to use the Unix style forward slash as a path separator. Windows style
paths can be converted to Unix style paths with the command \fBfile
join $path\fR (or \fBfile normalize $path\fR in Tcl 8.4).
.SH EXAMPLES
Find all the Tcl files in the current directory:
.CS
\fBglob\fR *.tcl
.CE
.PP
Find all the Tcl files in the user's home directory, irrespective of
what the current directory is:
.CS
\fBglob\fR \-directory ~ *.tcl
.CE
.PP
Find all subdirectories of the current directory:
.CS
\fBglob\fR \-type d *
.CE
.PP
Find all files whose name contains an "a", a "b" or the sequence "cde":
.CS
\fBglob\fR \-type f *{a,b,cde}*
.CE
.SH "SEE ALSO"
file(n)
.SH KEYWORDS
exist, file, glob, pattern
tcl8.4.20/doc/TraceCmd.3 0000644 0036047 0045461 00000015750 11737050674 013242 0 ustar dgp 771div '\"
'\" Copyright (c) 2002 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_TraceCommand 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
ClientData
\fBTcl_CommandTraceInfo(\fIinterp, cmdName, flags, proc, prevClientData\fB)\fR
.sp
int
\fBTcl_TraceCommand(\fIinterp, cmdName, flags, proc, clientData\fB)\fR
.sp
void
\fBTcl_UntraceCommand(\fIinterp, cmdName, flags, proc, clientData\fB)\fR
.SH ARGUMENTS
.AS Tcl_CommandTraceProc prevClientData
.AP Tcl_Interp *interp in
Interpreter containing the command.
.AP "CONST char" *cmdName in
Name of command.
.AP int flags in
OR-ed collection of the value TCL_TRACE_RENAME and TCL_TRACE_DELETE.
.AP Tcl_CommandTraceProc *proc in
Procedure to call when specified operations occur to \fIcmdName\fR.
.AP ClientData clientData in
Arbitrary argument to pass to \fIproc\fR.
.AP ClientData prevClientData in
If non-NULL, gives last value returned by \fBTcl_CommandTraceInfo\fR,
so this call will return information about next trace. If NULL, this
call will return information about first trace.
.BE
.SH DESCRIPTION
.PP
\fBTcl_TraceCommand\fR allows a C procedure to monitor operations
performed on a Tcl command, so that the C procedure is invoked
whenever the command is renamed or deleted. If the trace is created
successfully then \fBTcl_TraceCommand\fR returns TCL_OK. If an error
occurred (e.g. \fIcmdName\fR specifies a non-existent command) then
TCL_ERROR is returned and an error message is left in the
interpreter's result.
.PP
The \fIflags\fR argument to \fBTcl_TraceCommand\fR indicates when the
trace procedure is to be invoked. It consists of an OR-ed combination
of any of the following values:
.TP
\fBTCL_TRACE_RENAME\fR
Invoke \fIproc\fR whenever the command is renamed.
.TP
\fBTCL_TRACE_DELETE\fR
Invoke \fIproc\fR when the command is deleted.
.PP
Whenever one of the specified operations occurs to the command,
\fIproc\fR will be invoked. It should have arguments and result that
match the type \fBTcl_CommandTraceProc\fR:
.CS
typedef void Tcl_CommandTraceProc(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
CONST char *\fIoldName\fR,
CONST char *\fInewName\fR,
int \fIflags\fR);
.CE
The \fIclientData\fR and \fIinterp\fR parameters will have the same
values as those passed to \fBTcl_TraceCommand\fR when the trace was
created. \fIClientData\fR typically points to an application-specific
data structure that describes what to do when \fIproc\fR is invoked.
\fIOldName\fR gives the name of the command being renamed, and
\fInewName\fR gives the name that the command is being renamed to (or
an empty string or NULL when the command is being deleted.)
\fIFlags\fR is an OR-ed combination of bits potentially providing
several pieces of information. One of the bits TCL_TRACE_RENAME and
TCL_TRACE_DELETE will be set in \fIflags\fR to indicate which
operation is being performed on the command. The bit
TCL_TRACE_DESTROYED will be set in \fIflags\fR if the trace is about
to be destroyed; this information may be useful to \fIproc\fR so that
it can clean up its own internal data structures (see the section
TCL_TRACE_DESTROYED below for more details). Lastly, the bit
TCL_INTERP_DESTROYED will be set if the entire interpreter is being
destroyed. When this bit is set, \fIproc\fR must be especially
careful in the things it does (see the section TCL_INTERP_DESTROYED
below).
.PP
\fBTcl_UntraceCommand\fR may be used to remove a trace. If the
command specified by \fIinterp\fR, \fIcmdName\fR, and \fIflags\fR has
a trace set with \fIflags\fR, \fIproc\fR, and \fIclientData\fR, then
the corresponding trace is removed. If no such trace exists, then the
call to \fBTcl_UntraceCommand\fR has no effect. The same bits are
valid for \fIflags\fR as for calls to \fBTcl_TraceCommand\fR.
.PP
\fBTcl_CommandTraceInfo\fR may be used to retrieve information about
traces set on a given command.
The return value from \fBTcl_CommandTraceInfo\fR is the \fIclientData\fR
associated with a particular trace.
The trace must be on the command specified by the \fIinterp\fR,
\fIcmdName\fR, and \fIflags\fR arguments (note that currently the
flags are ignored; \fIflags\fR should be set to 0 for future
compatibility) and its trace procedure must the same as the \fIproc\fR
argument.
If the \fIprevClientData\fR argument is NULL then the return
value corresponds to the first (most recently created) matching
trace, or NULL if there are no matching traces.
If the \fIprevClientData\fR argument isn't NULL, then it should
be the return value from a previous call to \fBTcl_CommandTraceInfo\fR.
In this case, the new return value will correspond to the next
matching trace after the one whose \fIclientData\fR matches
\fIprevClientData\fR, or NULL if no trace matches \fIprevClientData\fR
or if there are no more matching traces after it.
This mechanism makes it possible to step through all of the
traces for a given command that have the same \fIproc\fR.
.SH "CALLING COMMANDS DURING TRACES"
.PP
During rename traces, the command being renamed is visible with both
names simultaneously, and the command still exists during delete
traces (if TCL_INTERP_DESTROYED is not set). However, there is no
mechanism for signaling that an error occurred in a trace procedure,
so great care should be taken that errors do not get silently lost.
.SH "MULTIPLE TRACES"
.PP
It is possible for multiple traces to exist on the same command.
When this happens, all of the trace procedures will be invoked on each
access, in order from most-recently-created to least-recently-created.
Attempts to delete the command during a delete trace will fail
silently, since the command is already scheduled for deletion anyway.
If the command being renamed is renamed by one of its rename traces,
that renaming takes precedence over the one that triggered the trace
and the collection of traces will not be reexecuted; if several traces
rename the command, the last renaming takes precedence.
.SH "TCL_TRACE_DESTROYED FLAG"
.PP
In a delete callback to \fIproc\fR, the TCL_TRACE_DESTROYED bit
is set in \fIflags\fR.
'\" Perhaps need some more comments here? - DKF
.SH "TCL_INTERP_DESTROYED"
.PP
When an interpreter is destroyed, unset traces are called for
all of its commands.
The TCL_INTERP_DESTROYED bit will be set in the \fIflags\fR
argument passed to the trace procedures.
Trace procedures must be extremely careful in what they do if
the TCL_INTERP_DESTROYED bit is set.
It is not safe for the procedures to invoke any Tcl procedures
on the interpreter, since its state is partially deleted.
All that trace procedures should do under these circumstances is
to clean up and free their own internal data structures.
.SH BUGS
.PP
Tcl doesn't do any error checking to prevent trace procedures
from misusing the interpreter during traces with TCL_INTERP_DESTROYED
set.
.SH KEYWORDS
clientData, trace, command
tcl8.4.20/doc/OpenTcp.3 0000644 0036047 0045461 00000016430 12052456743 013122 0 ustar dgp 771div '\"
'\" Copyright (c) 1996-7 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_OpenTcpClient 3 8.0 Tcl "Tcl Library Procedures"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer \- procedures to open channels using TCP sockets
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Channel
\fBTcl_OpenTcpClient\fR(\fIinterp, port, host, myaddr, myport, async\fR)
.sp
Tcl_Channel
\fBTcl_MakeTcpClientChannel\fR(\fIsock\fR)
.sp
Tcl_Channel
\fBTcl_OpenTcpServer\fR(\fIinterp, port, myaddr, proc, clientData\fR)
.sp
.SH ARGUMENTS
.AS Tcl_ChannelType newClientProcPtr in
.AP Tcl_Interp *interp in
Tcl interpreter to use for error reporting. If non-NULL and an
error occurs, an error message is left in the interpreter's result.
.AP int port in
A port number to connect to as a client or to listen on as a server.
.AP "CONST char" *host in
A string specifying a host name or address for the remote end of the connection.
.AP int myport in
A port number for the client's end of the socket. If 0, a port number
is allocated at random.
.AP "CONST char" *myaddr in
A string specifying the host name or address for network interface to use
for the local end of the connection. If NULL, a default interface is
chosen.
.AP int async in
If nonzero, the client socket is connected asynchronously to the server.
.AP ClientData sock in
Platform-specific handle for client TCP socket.
.AP Tcl_TcpAcceptProc *proc in
Pointer to a procedure to invoke each time a new connection is
accepted via the socket.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE
.SH DESCRIPTION
.PP
These functions are convenience procedures for creating
channels that communicate over TCP sockets.
The operations on a channel
are described in the manual entry for \fBTcl_OpenFileChannel\fR.
.SH TCL_OPENTCPCLIENT
.PP
\fBTcl_OpenTcpClient\fR opens a client TCP socket connected to a \fIport\fR
on a specific \fIhost\fR, and returns a channel that can be used to
communicate with the server. The host to connect to can be specified either
as a domain name style name (e.g. \fBwww.sunlabs.com\fR), or as a string
containing the alphanumeric representation of its four-byte address (e.g.
\fB127.0.0.1\fR). Use the string \fBlocalhost\fR to connect to a TCP socket on
the host on which the function is invoked.
.PP
The \fImyaddr\fR and \fImyport\fR arguments allow a client to specify an
address for the local end of the connection. If \fImyaddr\fR is NULL, then
an interface is chosen automatically by the operating system.
If \fImyport\fR is 0, then a port number is chosen at random by
the operating system.
.PP
If \fIasync\fR is zero, the call to \fBTcl_OpenTcpClient\fR returns only
after the client socket has either successfully connected to the server, or
the attempted connection has failed.
If \fIasync\fR is nonzero the socket is connected asynchronously and the
returned channel may not yet be connected to the server when the call to
\fBTcl_OpenTcpClient\fR returns. If the channel is in blocking mode and an
input or output operation is done on the channel before the connection is
completed or fails, that operation will wait until the connection either
completes successfully or fails. If the channel is in nonblocking mode, the
input or output operation will return immediately and a subsequent call to
\fBTcl_InputBlocked\fR on the channel will return nonzero.
.PP
The returned channel is opened for reading and writing.
If an error occurs in opening the socket, \fBTcl_OpenTcpClient\fR returns
NULL and records a POSIX error code that can be retrieved
with \fBTcl_GetErrno\fR.
In addition, if \fIinterp\fR is non-NULL, an error message
is left in the interpreter's result.
.PP
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR.
If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.
.SH TCL_MAKETCPCLIENTCHANNEL
.PP
\fBTcl_MakeTcpClientChannel\fR creates a \fBTcl_Channel\fR around an
existing, platform specific, handle for a client TCP socket.
.PP
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR.
If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.
.SH TCL_OPENTCPSERVER
.PP
\fBTcl_OpenTcpServer\fR opens a TCP socket on the local host on a specified
\fIport\fR and uses the Tcl event mechanism to accept requests from clients
to connect to it. The \fImyaddr\fP argument specifies the network interface.
If \fImyaddr\fP is NULL the special address INADDR_ANY should be used to
allow connections from any network interface.
Each time a client connects to this socket, Tcl creates a channel
for the new connection and invokes \fIproc\fR with information about
the channel. \fIProc\fR must match the following prototype:
.CS
typedef void Tcl_TcpAcceptProc(
ClientData \fIclientData\fR,
Tcl_Channel \fIchannel\fR,
char *\fIhostName\fR,
int \fIport\fP);
.CE
.PP
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument to \fBTcl_OpenTcpServer\fR, \fIchannel\fR will be the handle
for the new channel, \fIhostName\fR points to a string containing
the name of the client host making the connection, and \fIport\fP
will contain the client's port number.
The new channel
is opened for both input and output.
If \fIproc\fR raises an error, the connection is closed automatically.
\fIProc\fR has no return value, but if it wishes to reject the
connection it can close \fIchannel\fR.
.PP
\fBTcl_OpenTcpServer\fR normally returns a pointer to a channel
representing the server socket.
If an error occurs, \fBTcl_OpenTcpServer\fR returns NULL and
records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR.
In addition, if the interpreter is non-NULL, an error message
is left in the interpreter's result.
.PP
The channel returned by \fBTcl_OpenTcpServer\fR cannot be used for
either input or output.
It is simply a handle for the socket used to accept connections.
The caller can close the channel to shut down the server and disallow
further connections from new clients.
.PP
TCP server channels operate correctly only in applications that dispatch
events through \fBTcl_DoOneEvent\fR or through Tcl commands such as
\fBvwait\fR; otherwise Tcl will never notice that a connection request from
a remote client is pending.
.PP
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR.
If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.
.VS
.SH "PLATFORM ISSUES"
.PP
On Unix platforms, the socket handle is a Unix file descriptor as
returned by the \fBsocket\fR system call. On the Windows platform, the
socket handle is a \fBSOCKET\fR as defined in the WinSock API.
.VE
.SH "SEE ALSO"
Tcl_OpenFileChannel(3), Tcl_RegisterChannel(3), vwait(n)
.SH KEYWORDS
client, server, TCP
tcl8.4.20/doc/ObjectType.3 0000644 0036047 0045461 00000017712 11737050674 013630 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType \- manipulate Tcl object types
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_RegisterObjType\fR(\fItypePtr\fR)
.sp
Tcl_ObjType *
\fBTcl_GetObjType\fR(\fItypeName\fR)
.sp
int
\fBTcl_AppendAllObjTypes\fR(\fIinterp, objPtr\fR)
.sp
int
\fBTcl_ConvertToType\fR(\fIinterp, objPtr, typePtr\fR)
.SH ARGUMENTS
.AS Tcl_ObjType *typeName in
.AP Tcl_ObjType *typePtr in
Points to the structure containing information about the Tcl object type.
This storage must live forever,
typically by being statically allocated.
.AP "CONST char" *typeName in
The name of a Tcl object type that \fBTcl_GetObjType\fR should look up.
.AP Tcl_Interp *interp in
Interpreter to use for error reporting.
.AP Tcl_Obj *objPtr in
For \fBTcl_AppendAllObjTypes\fR, this points to the object onto which
it appends the name of each object type as a list element.
For \fBTcl_ConvertToType\fR, this points to an object that
must have been the result of a previous call to \fBTcl_NewObj\fR.
.BE
.SH DESCRIPTION
.PP
The procedures in this man page manage Tcl object types.
The are used to register new object types,
look up types,
and force conversions from one type to another.
.PP
\fBTcl_RegisterObjType\fR registers a new Tcl object type
in the table of all object types supported by Tcl.
The argument \fItypePtr\fR points to a Tcl_ObjType structure that
describes the new type by giving its name
and by supplying pointers to four procedures
that implement the type.
If the type table already contains a type
with the same name as in \fItypePtr\fR,
it is replaced with the new type.
The Tcl_ObjType structure is described
in the section \fBTHE TCL_OBJTYPE STRUCTURE\fR below.
.PP
\fBTcl_GetObjType\fR returns a pointer to the Tcl_ObjType
with name \fItypeName\fR.
It returns NULL if no type with that name is registered.
.PP
\fBTcl_AppendAllObjTypes\fR appends the name of each object type
as a list element onto the Tcl object referenced by \fIobjPtr\fR.
The return value is \fBTCL_OK\fR unless there was an error
converting \fIobjPtr\fR to a list object;
in that case \fBTCL_ERROR\fR is returned.
.PP
\fBTcl_ConvertToType\fR converts an object from one type to another
if possible.
It creates a new internal representation for \fIobjPtr\fR
appropriate for the target type \fItypePtr\fR
and sets its \fItypePtr\fR member to that type.
Any internal representation for \fIobjPtr\fR's old type is freed.
If an error occurs during conversion, it returns \fBTCL_ERROR\fR
and leaves an error message in the result object for \fIinterp\fR
unless \fIinterp\fR is NULL.
Otherwise, it returns \fBTCL_OK\fR.
Passing a NULL \fIinterp\fR allows this procedure to be used
as a test whether the conversion can be done (and in fact was done).
.SH "THE TCL_OBJTYPE STRUCTURE"
.PP
Extension writers can define new object types by defining four
procedures,
initializing a Tcl_ObjType structure to describe the type,
and calling \fBTcl_RegisterObjType\fR.
The \fBTcl_ObjType\fR structure is defined as follows:
.CS
typedef struct Tcl_ObjType {
char *\fIname\fR;
Tcl_FreeInternalRepProc *\fIfreeIntRepProc\fR;
Tcl_DupInternalRepProc *\fIdupIntRepProc\fR;
Tcl_UpdateStringProc *\fIupdateStringProc\fR;
Tcl_SetFromAnyProc *\fIsetFromAnyProc\fR;
} Tcl_ObjType;
.CE
.PP
The \fIname\fR member describes the name of the type, e.g. \fBint\fR.
Extension writers can look up an object type using its name
with the \fBTcl_GetObjType\fR procedure.
The remaining four members are pointers to procedures
called by the generic Tcl object code:
.PP
The \fIsetFromAnyProc\fR member contains the address of a function
called to create a valid internal representation
from an object's string representation.
.CS
typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *\fIinterp\fR, Tcl_Obj *\fIobjPtr\fR);
.CE
If an internal representation can't be created from the string,
it returns \fBTCL_ERROR\fR and puts a message
describing the error in the result object for \fIinterp\fR
unless \fIinterp\fR is NULL.
If \fIsetFromAnyProc\fR is successful,
it stores the new internal representation,
sets \fIobjPtr\fR's \fItypePtr\fR member to point to
\fIsetFromAnyProc\fR's \fBTcl_ObjType\fR, and returns \fBTCL_OK\fR.
Before setting the new internal representation,
the \fIsetFromAnyProc\fR must free any internal representation
of \fIobjPtr\fR's old type;
it does this by calling the old type's \fIfreeIntRepProc\fR
if it is not NULL.
As an example, the \fIsetFromAnyProc\fR for the builtin Tcl integer type
gets an up-to-date string representation for \fIobjPtr\fR
by calling \fBTcl_GetStringFromObj\fR.
It parses the string to obtain an integer and,
if this succeeds,
stores the integer in \fIobjPtr\fR's internal representation
and sets \fIobjPtr\fR's \fItypePtr\fR member to point to the integer type's
Tcl_ObjType structure.
Do not release \fIobjPtr\fR's old internal representation unless you
replace it with a new one or reset the \fItypePtr\fR member to NULL.
.PP
The \fIupdateStringProc\fR member contains the address of a function
called to create a valid string representation
from an object's internal representation.
.CS
typedef void (Tcl_UpdateStringProc) (Tcl_Obj *\fIobjPtr\fR);
.CE
\fIobjPtr\fR's \fIbytes\fR member is always NULL when it is called.
It must always set \fIbytes\fR non-NULL before returning.
We require the string representation's byte array
to have a null after the last byte, at offset \fIlength\fR;
this allows string representations that do not contain null bytes
to be treated as conventional null character-terminated C strings.
Storage for the byte array must be allocated in the heap by \fBTcl_Alloc\fR
or \fBckalloc\fR. Note that \fIupdateStringProc\fRs must allocate
enough storage for the string's bytes and the terminating null byte.
The \fIupdateStringProc\fR for Tcl's builtin list type, for example,
builds an array of strings for each element object
and then calls \fBTcl_Merge\fR
to construct a string with proper Tcl list structure.
It stores this string as the list object's string representation.
.PP
The \fIdupIntRepProc\fR member contains the address of a function
called to copy an internal representation from one object to another.
.CS
typedef void (Tcl_DupInternalRepProc) (Tcl_Obj *\fIsrcPtr\fR, Tcl_Obj *\fIdupPtr\fR);
.CE
\fIdupPtr\fR's internal representation is made a copy of \fIsrcPtr\fR's
internal representation.
Before the call,
\fIsrcPtr\fR's internal representation is valid and \fIdupPtr\fR's is not.
\fIsrcPtr\fR's object type determines what
copying its internal representation means.
For example, the \fIdupIntRepProc\fR for the Tcl integer type
simply copies an integer.
The builtin list type's \fIdupIntRepProc\fR
allocates a new array that points at the original element objects;
the elements are shared between the two lists
(and their reference counts are incremented to reflect the new references).
.PP
The \fIfreeIntRepProc\fR member contains the address of a function
that is called when an object is freed.
.CS
typedef void (Tcl_FreeInternalRepProc) (Tcl_Obj *\fIobjPtr\fR);
.CE
The \fIfreeIntRepProc\fR function can deallocate the storage
for the object's internal representation
and do other type-specific processing necessary when an object is freed.
For example, Tcl list objects have an \fIinternalRep.otherValuePtr\fR
that points to an array of pointers to each element in the list.
The list type's \fIfreeIntRepProc\fR decrements
the reference count for each element object
(since the list will no longer refer to those objects),
then deallocates the storage for the array of pointers.
The \fIfreeIntRepProc\fR member can be set to NULL
to indicate that the internal representation does not require freeing.
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount
.SH KEYWORDS
internal representation, object, object type, string representation, type conversion
tcl8.4.20/doc/source.n 0000644 0036047 0045461 00000003717 12052456743 013151 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH source n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
source \- Evaluate a file or resource as a Tcl script
.SH SYNOPSIS
\fBsource \fIfileName\fR
.sp
\fBsource\fR \fB\-rsrc \fIresourceName \fR?\fIfileName\fR?
.sp
\fBsource\fR \fB\-rsrcid \fIresourceId \fR?\fIfileName\fR?
.BE
.SH DESCRIPTION
.PP
This command takes the contents of the specified file or resource
and passes it to the Tcl interpreter as a text script. The return
value from \fBsource\fR is the return value of the last command
executed in the script. If an error occurs in evaluating the contents
of the script then the \fBsource\fR command will return that error.
If a \fBreturn\fR command is invoked from within the script then the
remainder of the file will be skipped and the \fBsource\fR command
will return normally with the result from the \fBreturn\fR command.
.PP
.VS 8.4
The end-of-file character for files is '\\32' (^Z) for all platforms.
The source command will read files up to this character. This
restriction does not exist for the \fBread\fR or \fBgets\fR commands,
allowing for files containing code and data segments (scripted documents).
If you require a ``^Z'' in code for string comparison, you can use
``\\032'' or ``\\u001a'', which will be safely substituted by the Tcl
interpreter into ``^Z''.
.VE 8.4
.SH EXAMPLE
Run the script in the file \fBfoo.tcl\fR and then the script in the
file \fBbar.tcl\fR:
.CS
\fBsource\fR foo.tcl
\fBsource\fR bar.tcl
.CE
Alternatively:
.CS
foreach scriptFile {foo.tcl bar.tcl} {
\fBsource\fR $scriptFile
}
.CE
.SH "SEE ALSO"
file(n), cd(n), info(n)
.SH KEYWORDS
file, script
tcl8.4.20/doc/Object.3 0000644 0036047 0045461 00000033001 11737050674 012753 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_Obj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl objects
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Obj *
\fBTcl_NewObj\fR()
.sp
Tcl_Obj *
\fBTcl_DuplicateObj\fR(\fIobjPtr\fR)
.sp
\fBTcl_IncrRefCount\fR(\fIobjPtr\fR)
.sp
\fBTcl_DecrRefCount\fR(\fIobjPtr\fR)
.sp
int
\fBTcl_IsShared\fR(\fIobjPtr\fR)
.sp
\fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR)
.SH ARGUMENTS
.AS Tcl_Obj *objPtr in
.AP Tcl_Obj *objPtr in
Points to an object;
must have been the result of a previous call to \fBTcl_NewObj\fR.
.BE
.SH INTRODUCTION
.PP
This man page presents an overview of Tcl objects and how they are used.
It also describes generic procedures for managing Tcl objects.
These procedures are used to create and copy objects,
and increment and decrement the count of references (pointers) to objects.
The procedures are used in conjunction with ones
that operate on specific types of objects such as
\fBTcl_GetIntFromObj\fR and \fBTcl_ListObjAppendElement\fR.
The individual procedures are described along with the data structures
they manipulate.
.PP
Tcl's \fIdual-ported\fR objects provide a general-purpose mechanism
for storing and exchanging Tcl values.
They largely replace the use of strings in Tcl.
For example, they are used to store variable values,
command arguments, command results, and scripts.
Tcl objects behave like strings but also hold an internal representation
that can be manipulated more efficiently.
For example, a Tcl list is now represented as an object
that holds the list's string representation
as well as an array of pointers to the objects for each list element.
Dual-ported objects avoid most runtime type conversions.
They also improve the speed of many operations
since an appropriate representation is immediately available.
The compiler itself uses Tcl objects to
cache the instruction bytecodes resulting from compiling scripts.
.PP
The two representations are a cache of each other and are computed lazily.
That is, each representation is only computed when necessary,
it is computed from the other representation,
and, once computed, it is saved.
In addition, a change in one representation invalidates the other one.
As an example, a Tcl program doing integer calculations can
operate directly on a variable's internal machine integer
representation without having to constantly convert
between integers and strings.
Only when it needs a string representing the variable's value,
say to print it,
will the program regenerate the string representation from the integer.
Although objects contain an internal representation,
their semantics are defined in terms of strings:
an up-to-date string can always be obtained,
and any change to the object will be reflected in that string
when the object's string representation is fetched.
Because of this representation invalidation and regeneration,
it is dangerous for extension writers to access
\fBTcl_Obj\fR fields directly.
It is better to access Tcl_Obj information using
procedures like \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR.
.PP
Objects are allocated on the heap
and are referenced using a pointer to their \fBTcl_Obj\fR structure.
Objects are shared as much as possible.
This significantly reduces storage requirements
because some objects such as long lists are very large.
Also, most Tcl values are only read and never modified.
This is especially true for procedure arguments,
which can be shared between the caller and the called procedure.
Assignment and argument binding is done by
simply assigning a pointer to the value.
Reference counting is used to determine when it is safe to
reclaim an object's storage.
.PP
Tcl objects are typed.
An object's internal representation is controlled by its type.
Seven types are predefined in the Tcl core
including integer, double, list, and bytecode.
Extension writers can extend the set of types
by using the procedure \fBTcl_RegisterObjType\fR .
.SH "THE TCL_OBJ STRUCTURE"
.PP
Each Tcl object is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.CS
typedef struct Tcl_Obj {
int \fIrefCount\fR;
char *\fIbytes\fR;
int \fIlength\fR;
Tcl_ObjType *\fItypePtr\fR;
union {
long \fIlongValue\fR;
double \fIdoubleValue\fR;
VOID *\fIotherValuePtr\fR;
struct {
VOID *\fIptr1\fR;
VOID *\fIptr2\fR;
} \fItwoPtrValue\fR;
} \fIinternalRep\fR;
} Tcl_Obj;
.CE
The \fIbytes\fR and the \fIlength\fR members together hold
.VS 8.1
an object's UTF-8 string representation,
which is a \fIcounted string\fR not containing null bytes (UTF-8 null
characters should be encoded as a two byte sequence: 192, 128.)
\fIbytes\fR points to the first byte of the string representation.
The \fIlength\fR member gives the number of bytes.
The byte array must always have a null byte after the last data byte,
at offset \fIlength\fR;
this allows string representations
to be treated as conventional null-terminated C strings.
.VE 8.1
C programs use \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR to get
an object's string representation.
If \fIbytes\fR is NULL,
the string representation is invalid.
.PP
An object's type manages its internal representation.
The member \fItypePtr\fR points to the Tcl_ObjType structure
that describes the type.
If \fItypePtr\fR is NULL,
the internal representation is invalid.
.PP
The \fIinternalRep\fR union member holds
an object's internal representation.
This is either a (long) integer, a double-precision floating point number,
a pointer to a value containing additional information
needed by the object's type to represent the object,
or two arbitrary pointers.
.PP
The \fIrefCount\fR member is used to tell when it is safe to free
an object's storage.
It holds the count of active references to the object.
Maintaining the correct reference count is a key responsibility
of extension writers.
Reference counting is discussed below
in the section \fBSTORAGE MANAGEMENT OF OBJECTS\fR.
.PP
Although extension writers can directly access
the members of a Tcl_Obj structure,
it is much better to use the appropriate procedures and macros.
For example, extension writers should never
read or update \fIrefCount\fR directly;
they should use macros such as
\fBTcl_IncrRefCount\fR and \fBTcl_IsShared\fR instead.
.PP
A key property of Tcl objects is that they hold two representations.
An object typically starts out containing only a string representation:
it is untyped and has a NULL \fItypePtr\fR.
An object containing an empty string or a copy of a specified string
is created using \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR respectively.
An object's string value is gotten with
\fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR
and changed with \fBTcl_SetStringObj\fR.
If the object is later passed to a procedure like \fBTcl_GetIntFromObj\fR
that requires a specific internal representation,
the procedure will create one and set the object's \fItypePtr\fR.
The internal representation is computed from the string representation.
An object's two representations are duals of each other:
changes made to one are reflected in the other.
For example, \fBTcl_ListObjReplace\fR will modify an object's
internal representation and the next call to \fBTcl_GetStringFromObj\fR
or \fBTcl_GetString\fR will reflect that change.
.PP
Representations are recomputed lazily for efficiency.
A change to one representation made by a procedure
such as \fBTcl_ListObjReplace\fR is not reflected immediately
in the other representation.
Instead, the other representation is marked invalid
so that it is only regenerated if it is needed later.
Most C programmers never have to be concerned with how this is done
and simply use procedures such as \fBTcl_GetBooleanFromObj\fR or
\fBTcl_ListObjIndex\fR.
Programmers that implement their own object types
must check for invalid representations
and mark representations invalid when necessary.
The procedure \fBTcl_InvalidateStringRep\fR is used
to mark an object's string representation invalid and to
free any storage associated with the old string representation.
.PP
Objects usually remain one type over their life,
but occasionally an object must be converted from one type to another.
For example, a C program might build up a string in an object
with repeated calls to \fBTcl_AppendToObj\fR,
and then call \fBTcl_ListObjIndex\fR to extract a list element from
the object.
The same object holding the same string value
can have several different internal representations
at different times.
Extension writers can also force an object to be converted from one type
to another using the \fBTcl_ConvertToType\fR procedure.
Only programmers that create new object types need to be concerned
about how this is done.
A procedure defined as part of the object type's implementation
creates a new internal representation for an object
and changes its \fItypePtr\fR.
See the man page for \fBTcl_RegisterObjType\fR
to see how to create a new object type.
.SH "EXAMPLE OF THE LIFETIME OF AN OBJECT"
.PP
As an example of the lifetime of an object,
consider the following sequence of commands:
.CS
\fBset x 123\fR
.CE
This assigns to \fIx\fR an untyped object whose
\fIbytes\fR member points to \fB123\fR and \fIlength\fR member contains 3.
The object's \fItypePtr\fR member is NULL.
.CS
\fBputs "x is $x"\fR
.CE
\fIx\fR's string representation is valid (since \fIbytes\fR is non-NULL)
and is fetched for the command.
.CS
\fBincr x\fR
.CE
The \fBincr\fR command first gets an integer from \fIx\fR's object
by calling \fBTcl_GetIntFromObj\fR.
This procedure checks whether the object is already an integer object.
Since it is not, it converts the object
by setting the object's \fIinternalRep.longValue\fR member
to the integer \fB123\fR
and setting the object's \fItypePtr\fR
to point to the integer Tcl_ObjType structure.
Both representations are now valid.
\fBincr\fR increments the object's integer internal representation
then invalidates its string representation
(by calling \fBTcl_InvalidateStringRep\fR)
since the string representation
no longer corresponds to the internal representation.
.CS
\fBputs "x is now $x"\fR
.CE
The string representation of \fIx\fR's object is needed
and is recomputed.
The string representation is now \fB124\fR.
and both representations are again valid.
.SH "STORAGE MANAGEMENT OF OBJECTS"
.PP
Tcl objects are allocated on the heap and are shared as much as possible
to reduce storage requirements.
Reference counting is used to determine when an object is
no longer needed and can safely be freed.
An object just created by \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR
has \fIrefCount\fR 0.
The macro \fBTcl_IncrRefCount\fR increments the reference count
when a new reference to the object is created.
The macro \fBTcl_DecrRefCount\fR decrements the count
when a reference is no longer needed and,
if the object's reference count drops to zero, frees its storage.
An object shared by different code or data structures has
\fIrefCount\fR greater than 1.
Incrementing an object's reference count ensures that
it won't be freed too early or have its value change accidently.
.PP
As an example, the bytecode interpreter shares argument objects
between calling and called Tcl procedures to avoid having to copy objects.
It assigns the call's argument objects to the procedure's
formal parameter variables.
In doing so, it calls \fBTcl_IncrRefCount\fR to increment
the reference count of each argument since there is now a new
reference to it from the formal parameter.
When the called procedure returns,
the interpreter calls \fBTcl_DecrRefCount\fR to decrement
each argument's reference count.
When an object's reference count drops less than or equal to zero,
\fBTcl_DecrRefCount\fR reclaims its storage.
Most command procedures do not have to be concerned about
reference counting since they use an object's value immediately
and don't retain a pointer to the object after they return.
However, if they do retain a pointer to an object in a data structure,
they must be careful to increment its reference count
since the retained pointer is a new reference.
.PP
Command procedures that directly modify objects
such as those for \fBlappend\fR and \fBlinsert\fR must be careful to
copy a shared object before changing it.
They must first check whether the object is shared
by calling \fBTcl_IsShared\fR.
If the object is shared they must copy the object
by using \fBTcl_DuplicateObj\fR;
this returns a new duplicate of the original object
that has \fIrefCount\fR 0.
If the object is not shared,
the command procedure "owns" the object and can safely modify it directly.
For example, the following code appears in the command procedure
that implements \fBlinsert\fR.
This procedure modifies the list object passed to it in \fIobjv[1]\fR
by inserting \fIobjc-3\fR new elements before \fIindex\fR.
.CS
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
listPtr = Tcl_DuplicateObj(listPtr);
}
result = Tcl_ListObjReplace(interp, listPtr, index, 0, (objc-3), &(objv[3]));
.CE
As another example, \fBincr\fR's command procedure
must check whether the variable's object is shared before
incrementing the integer in its internal representation.
If it is shared, it needs to duplicate the object
in order to avoid accidently changing values in other data structures.
.SH "SEE ALSO"
Tcl_ConvertToType, Tcl_GetIntFromObj, Tcl_ListObjAppendElement, Tcl_ListObjIndex, Tcl_ListObjReplace, Tcl_RegisterObjType
.SH KEYWORDS
internal representation, object, object creation, object type, reference counting, string representation, type conversion
tcl8.4.20/doc/TCL_MEM_DEBUG.3 0000644 0036047 0045461 00000007025 12052456743 013600 0 ustar dgp 771div '\"
'\" Copyright (c) 1992-1999 Karl Lehenbauer and Mark Diekhans.
'\" Copyright (c) 2000 by Scriptics Corporation.
'\" All rights reserved.
'\"
.so man.macros
.TH TCL_MEM_DEBUG 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
TCL_MEM_DEBUG \- Compile-time flag to enable Tcl memory debugging.
.BE
.SH DESCRIPTION
When Tcl is compiled with \fBTCL_MEM_DEBUG\fR defined, a powerful set
of memory debugging aids are included in the compiled binary. This
includes C and Tcl functions which can aid with debugging
memory leaks, memory allocation overruns, and other memory related
errors.
.SH "ENABLING MEMORY DEBUGGING"
.PP
To enable memory debugging, Tcl should be recompiled from scratch with
\fBTCL_MEM_DEBUG\fR defined. This will also compile in a non-stub
version of \fBTcl_InitMemory\fR to add the \fBmemory\fR command to Tcl.
.PP
\fBTCL_MEM_DEBUG\fR must be either left defined for all modules or undefined
for all modules that are going to be linked together. If they are not, link
errors will occur, with either \fBTclDbCkfree\fR and \fBTcl_DbCkalloc\fR or
\fBTcl_Alloc\fR and \fBTcl_Free\fR being undefined.
.PP
Once memory debugging support has been compiled into Tcl, the C
functions \fBTcl_ValidateAllMemory\fR, and \fBTcl_DumpActiveMemory\fR,
and the Tcl \fBmemory\fR command can be used to validate and examine
memory usage.
.SH "GUARD ZONES"
.PP
When memory debugging is enabled, whenever a call to \fBckalloc\fR is
made, slightly more memory than requested is allocated so the memory debugging
code can keep track of the allocated memory, and eight-byte ``guard
zones'' are placed in front of and behind the space that will be
returned to the caller. (The sizes of the guard zones are defined by the
C #define \fBLOW_GUARD_SIZE\fR and #define \fBHIGH_GUARD_SIZE\fR
in the file \fIgeneric/tclCkalloc.c\fR -- it can
be extended if you suspect large overwrite problems, at some cost in
performance.) A known pattern is written into the guard zones and, on
a call to \fBckfree\fR, the guard zones of the space being freed are
checked to see if either zone has been modified in any way. If one
has been, the guard bytes and their new contents are identified, and a
``low guard failed'' or ``high guard failed'' message is issued. The
``guard failed'' message includes the address of the memory packet and
the file name and line number of the code that called \fBckfree\fR.
This allows you to detect the common sorts of one-off problems, where
not enough space was allocated to contain the data written, for
example.
.SH "DEBUGGING DIFFICULT MEMORY CORRUPTION PROBLEMS"
.PP
Normally, Tcl compiled with memory debugging enabled will make it easy
to isolate a corruption problem. Turning on memory validation with
the memory command can help isolate difficult problems. If you
suspect (or know) that corruption is occurring before the Tcl
interpreter comes up far enough for you to issue commands, you can set
\fBMEM_VALIDATE\fR define, recompile tclCkalloc.c and rebuild Tcl.
This will enable memory validation from the first call to
\fBckalloc\fR, again, at a large performance impact.
.PP
If you are desperate and validating memory on every call to
\fBckalloc\fR and \fBckfree\fR isn't enough, you can explicitly call
\fBTcl_ValidateAllMemory\fR directly at any point. It takes a \fIchar
*\fR and an \fIint\fR which are normally the filename and line number
of the caller, but they can actually be anything you want. Remember
to remove the calls after you find the problem.
.SH "SEE ALSO"
ckalloc, memory, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory
.SH KEYWORDS
memory, debug
tcl8.4.20/doc/OpenFileChnl.3 0000644 0036047 0045461 00000074437 12052456743 014073 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_OpenFileChannel 3 8.3 Tcl "Tcl Library Procedures"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Channel
\fBTcl_OpenFileChannel\fR(\fIinterp, fileName, mode, permissions\fR)
.sp
Tcl_Channel
\fBTcl_OpenCommandChannel\fR(\fIinterp, argc, argv, flags\fR)
.sp
Tcl_Channel
\fBTcl_MakeFileChannel\fR(\fIhandle, readOrWrite\fR)
.sp
Tcl_Channel
\fBTcl_GetChannel\fR(\fIinterp, channelName, modePtr\fR)
.VS 8.3
.sp
int
\fBTcl_GetChannelNames\fR(\fIinterp\fR)
.sp
int
\fBTcl_GetChannelNamesEx\fR(\fIinterp, pattern\fR)
.VE
.sp
void
\fBTcl_RegisterChannel\fR(\fIinterp, channel\fR)
.sp
int
\fBTcl_UnregisterChannel\fR(\fIinterp, channel\fR)
.sp
int
\fBTcl_DetachChannel\fR(\fIinterp, channel\fR)
.sp
int
\fBTcl_IsStandardChannel\fR(\fIchannel\fR)
.sp
int
\fBTcl_Close\fR(\fIinterp, channel\fR)
.sp
.VS 8.1
int
\fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR)
.sp
int
\fBTcl_Read\fR(\fIchannel, readBuf, bytesToRead\fR)
.sp
int
\fBTcl_GetsObj\fR(\fIchannel, lineObjPtr\fR)
.sp
int
\fBTcl_Gets\fR(\fIchannel, lineRead\fR)
.sp
int
\fBTcl_Ungets\fR(\fIchannel, input, inputLen, addAtEnd\fR)
.sp
int
\fBTcl_WriteObj\fR(\fIchannel, writeObjPtr\fR)
.sp
int
\fBTcl_WriteChars\fR(\fIchannel, charBuf, bytesToWrite\fR)
.sp
int
\fBTcl_Write\fR(\fIchannel, byteBuf, bytesToWrite\fR)
.VE
.VS 8.3.2
.sp
int
\fBTcl_ReadRaw\fR(\fIchannel, readBuf, bytesToRead\fR)
.sp
int
\fBTcl_WriteRaw\fR(\fIchannel, byteBuf, bytesToWrite\fR)
.VE
.sp
int
\fBTcl_Eof\fR(\fIchannel\fR)
.sp
int
\fBTcl_Flush\fR(\fIchannel\fR)
.sp
int
\fBTcl_InputBlocked\fR(\fIchannel\fR)
.sp
int
\fBTcl_InputBuffered\fR(\fIchannel\fR)
.VS 8.4
.sp
int
\fBTcl_OutputBuffered\fR(\fIchannel\fR)
.VE
.sp
.VS 8.4
Tcl_WideInt
\fBTcl_Seek\fR(\fIchannel, offset, seekMode\fR)
.sp
Tcl_WideInt
\fBTcl_Tell\fR(\fIchannel\fR)
.VE 8.4
.sp
int
\fBTcl_GetChannelOption\fR(\fIinterp, channel, optionName, optionValue\fR)
.sp
int
\fBTcl_SetChannelOption\fR(\fIinterp, channel, optionName, newValue\fR)
.sp
.SH ARGUMENTS
.AS Tcl_ChannelType newClientProcPtr in
.AP Tcl_Interp *interp in
Used for error reporting and to look up a channel registered in it.
.AP "CONST char" *fileName in
The name of a local or network file.
.AP "CONST char" *mode in
Specifies how the file is to be accessed. May have any of the values
allowed for the \fImode\fR argument to the Tcl \fBopen\fR command.
.AP int permissions in
POSIX-style permission flags such as 0644. If a new file is created, these
permissions will be set on the created file.
.AP int argc in
The number of elements in \fIargv\fR.
.AP "CONST char" **argv in
Arguments for constructing a command pipeline. These values have the same
meaning as the non-switch arguments to the Tcl \fBexec\fR command.
.AP int flags in
Specifies the disposition of the stdio handles in pipeline: OR-ed
combination of \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, \fBTCL_STDERR\fR, and
\fBTCL_ENFORCE_MODE\fR. If \fBTCL_STDIN\fR is set, stdin for the first child
in the pipe is the pipe channel, otherwise it is the same as the standard
input of the invoking process; likewise for \fBTCL_STDOUT\fR and
\fBTCL_STDERR\fR. If \fBTCL_ENFORCE_MODE\fR is not set, then the pipe can
redirect stdio handles to override the stdio handles for which
\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR have been set. If it
is set, then such redirections cause an error.
.AP ClientData handle in
Operating system specific handle for I/O to a file. For Unix this is a
file descriptor, for Windows it is a HANDLE.
.AP int readOrWrite in
OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate
what operations are valid on \fIhandle\fR.
.AP "CONST char" *channelName in
The name of the channel.
.AP int *modePtr out
Points at an integer variable that will receive an OR-ed combination of
\fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR denoting whether the channel is
open for reading and writing.
.VS 8.3
.AP "CONST char" *pattern in
The pattern to match on, passed to Tcl_StringMatch, or NULL.
.VE
.AP Tcl_Channel channel in
A Tcl channel for input or output. Must have been the return value
from a procedure such as \fBTcl_OpenFileChannel\fR.
.VS 8.1 br
.AP Tcl_Obj *readObjPtr in/out
A pointer to a Tcl Object in which to store the characters read from the
channel.
.AP int charsToRead in
The number of characters to read from the channel. If the channel's encoding
is \fBbinary\fR, this is equivalent to the number of bytes to read from the
channel.
.AP int appendFlag in
If non-zero, data read from the channel will be appended to the object.
Otherwise, the data will replace the existing contents of the object.
.AP char *readBuf out
A buffer in which to store the bytes read from the channel.
.AP int bytesToRead in
The number of bytes to read from the channel. The buffer \fIreadBuf\fR must
be large enough to hold this many bytes.
.AP Tcl_Obj *lineObjPtr in/out
A pointer to a Tcl object in which to store the line read from the
channel. The line read will be appended to the current value of the
object.
.AP Tcl_DString *lineRead in/out
A pointer to a Tcl dynamic string in which to store the line read from the
channel. Must have been initialized by the caller. The line read will be
appended to any data already in the dynamic string.
.VS 8.3
.AP "CONST char" *input in
The input to add to a channel buffer.
.AP int inputLen in
Length of the input
.AP int addAtEnd in
Flag indicating whether the input should be added to the end or
beginning of the channel buffer.
.VE
.AP Tcl_Obj *writeObjPtr in
A pointer to a Tcl Object whose contents will be output to the channel.
.AP "CONST char" *charBuf in
A buffer containing the characters to output to the channel.
.AP "CONST char" *byteBuf in
A buffer containing the bytes to output to the channel.
.AP int bytesToWrite in
The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and
output to the channel.
.VE
.AP Tcl_WideInt offset in
How far to move the access point in the channel at which the next input or
output operation will be applied, measured in bytes from the position
given by \fIseekMode\fR. May be either positive or negative.
.AP int seekMode in
Relative to which point to seek; used with \fIoffset\fR to calculate the new
access point for the channel. Legal values are \fBSEEK_SET\fR,
\fBSEEK_CUR\fR, and \fBSEEK_END\fR.
.AP "CONST char" *optionName in
The name of an option applicable to this channel, such as \fB\-blocking\fR.
May have any of the values accepted by the \fBfconfigure\fR command.
.AP Tcl_DString *optionValue in
Where to store the value of an option or a list of all options and their
values. Must have been initialized by the caller.
.AP "CONST char" *newValue in
New value for the option given by \fIoptionName\fR.
.BE
.SH DESCRIPTION
.PP
The Tcl channel mechanism provides a device-independent and
platform-independent mechanism for performing buffered input
and output operations on a variety of file, socket, and device
types.
The channel mechanism is extensible to new channel types, by
providing a low level channel driver for the new type; the channel driver
interface is described in the manual entry for \fBTcl_CreateChannel\fR. The
channel mechanism provides a buffering scheme modeled after
Unix's standard I/O, and it also allows for nonblocking I/O on
channels.
.PP
The procedures described in this manual entry comprise the C APIs of the
generic layer of the channel architecture. For a description of the channel
driver architecture and how to implement channel drivers for new types of
channels, see the manual entry for \fBTcl_CreateChannel\fR.
.SH TCL_OPENFILECHANNEL
.PP
\fBTcl_OpenFileChannel\fR opens a file specified by \fIfileName\fR and
returns a channel handle that can be used to perform input and output on
the file. This API is modeled after the \fBfopen\fR procedure of
the Unix standard I/O library.
The syntax and meaning of all arguments is similar to those
given in the Tcl \fBopen\fR command when opening a file.
If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR
returns NULL and records a POSIX error code that can be
retrieved with \fBTcl_GetErrno\fR.
In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR
leaves an error message in \fIinterp\fR's result after any error.
As of Tcl 8.4, the object-based API \fBTcl_FSOpenFileChannel\fR should
be used in preference to \fBTcl_OpenFileChannel\fR wherever possible.
.PP
.PP
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR, described below.
If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.
.SH TCL_OPENCOMMANDCHANNEL
.PP
\fBTcl_OpenCommandChannel\fR provides a C-level interface to the
functions of the \fBexec\fR and \fBopen\fR commands.
It creates a sequence of subprocesses specified
by the \fIargv\fR and \fIargc\fR arguments and returns a channel that can
be used to communicate with these subprocesses.
The \fIflags\fR argument indicates what sort of communication will
exist with the command pipeline.
.PP
If the \fBTCL_STDIN\fR flag is set then the standard input for the
first subprocess will be tied to the channel: writing to the channel
will provide input to the subprocess. If \fBTCL_STDIN\fR is not set,
then standard input for the first subprocess will be the same as this
application's standard input. If \fBTCL_STDOUT\fR is set then
standard output from the last subprocess can be read from the channel;
otherwise it goes to this application's standard output. If
\fBTCL_STDERR\fR is set, standard error output for all subprocesses is
returned to the channel and results in an error when the channel is
closed; otherwise it goes to this application's standard error. If
\fBTCL_ENFORCE_MODE\fR is not set, then \fIargc\fR and \fIargv\fR can
redirect the stdio handles to override \fBTCL_STDIN\fR,
\fBTCL_STDOUT\fR, and \fBTCL_STDERR\fR; if it is set, then it is an
error for argc and argv to override stdio channels for which
\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, and \fBTCL_STDERR\fR have been set.
.PP
If an error occurs while opening the channel, \fBTcl_OpenCommandChannel\fR
returns NULL and records a POSIX error code that can be retrieved with
\fBTcl_GetErrno\fR.
In addition, \fBTcl_OpenCommandChannel\fR leaves an error message in
the interpreter's result if \fIinterp\fR is not NULL.
.PP
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR, described below.
If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.
.SH TCL_MAKEFILECHANNEL
.PP
\fBTcl_MakeFileChannel\fR makes a \fBTcl_Channel\fR from an existing,
platform-specific, file handle.
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR, described below.
If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.
.SH TCL_GETCHANNEL
.PP
\fBTcl_GetChannel\fR returns a channel given the \fIchannelName\fR used to
create it with \fBTcl_CreateChannel\fR and a pointer to a Tcl interpreter in
\fIinterp\fR. If a channel by that name is not registered in that interpreter,
the procedure returns NULL. If the \fImodePtr\fR argument is not NULL, it
points at an integer variable that will receive an OR-ed combination of
\fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR describing whether the channel is
open for reading and writing.
.PP
\fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the
names of the registered channels to the interpreter's result as a
list object. \fBTcl_GetChannelNamesEx\fR will filter these names
according to the \fIpattern\fR. If \fIpattern\fR is NULL, then it
will not do any filtering. The return value is \fBTCL_OK\fR if no
errors occurred writing to the result, otherwise it is \fBTCL_ERROR\fR,
and the error message is left in the interpreter's result.
.SH TCL_REGISTERCHANNEL
.PP
\fBTcl_RegisterChannel\fR adds a channel to the set of channels accessible
in \fIinterp\fR. After this call, Tcl programs executing in that
interpreter can refer to the channel in input or output operations using
the name given in the call to \fBTcl_CreateChannel\fR. After this call,
the channel becomes the property of the interpreter, and the caller should
not call \fBTcl_Close\fR for the channel; the channel will be closed
automatically when it is unregistered from the interpreter.
.PP
Code executing outside of any Tcl interpreter can call
\fBTcl_RegisterChannel\fR with \fIinterp\fR as NULL, to indicate that it
wishes to hold a reference to this channel. Subsequently, the channel can
be registered in a Tcl interpreter and it will only be closed when the
matching number of calls to \fBTcl_UnregisterChannel\fR have been made.
This allows code executing outside of any interpreter to safely hold a
reference to a channel that is also registered in a Tcl interpreter.
.PP
This procedure interacts with the code managing the standard
channels. If no standard channels were initialized before the first
call to \fBTcl_RegisterChannel\fR they will get initialized by that
call. See \fBTcl_StandardChannels\fR for a general treatise about
standard channels and the behaviour of the Tcl library with regard to
them.
.SH TCL_UNREGISTERCHANNEL
.PP
\fBTcl_UnregisterChannel\fR removes a channel from the set of channels
accessible in \fIinterp\fR. After this call, Tcl programs will no longer be
able to use the channel's name to refer to the channel in that interpreter.
If this operation removed the last registration of the channel in any
interpreter, the channel is also closed and destroyed.
.PP
Code not associated with a Tcl interpreter can call
\fBTcl_UnregisterChannel\fR with \fIinterp\fR as NULL, to indicate to Tcl
that it no longer holds a reference to that channel. If this is the last
reference to the channel, it will now be closed. \fBTcl_UnregisterChannel\fR
is very similar to \fBTcl_DetachChannel\fR except that it will also
close the channel if no further references to it exist.
.SH TCL_DETACHCHANNEL
.PP
\fBTcl_DetachChannel\fR removes a channel from the set of channels
accessible in \fIinterp\fR. After this call, Tcl programs will no longer be
able to use the channel's name to refer to the channel in that interpreter.
Beyond that, this command has no further effect. It cannot be used on
the standard channels (stdout, stderr, stdin), and will return
TCL_ERROR if passed one of those channels.
.PP
Code not associated with a Tcl interpreter can call
\fBTcl_DetachChannel\fR with \fIinterp\fR as NULL, to indicate to Tcl
that it no longer holds a reference to that channel. If this is the last
reference to the channel, unlike \fBTcl_UnregisterChannel\fR,
it will not be closed.
.SH TCL_ISSTANDARDCHANNEL
.PP
\fBTcl_IsStandardChannel\fR tests whether a channel is one of the
three standard channels, stdin, stdout or stderr. If so, it returns
1, otherwise 0.
.PP
No attempt is made to check whether the given channel or the standard
channels are initialized or otherwise valid.
.SH TCL_CLOSE
.PP
\fBTcl_Close\fR destroys the channel \fIchannel\fR, which must denote a
currently open channel. The channel should not be registered in any
interpreter when \fBTcl_Close\fR is called. Buffered output is flushed to
the channel's output device prior to destroying the channel, and any
buffered input is discarded. If this is a blocking channel, the call does
not return until all buffered data is successfully sent to the channel's
output device. If this is a nonblocking channel and there is buffered
output that cannot be written without blocking, the call returns
immediately; output is flushed in the background and the channel will be
closed once all of the buffered data has been output. In this case errors
during flushing are not reported.
.PP
If the channel was closed successfully, \fBTcl_Close\fR returns \fBTCL_OK\fR.
If an error occurs, \fBTcl_Close\fR returns \fBTCL_ERROR\fR and records a
POSIX error code that can be retrieved with \fBTcl_GetErrno\fR.
If the channel is being closed synchronously and an error occurs during
closing of the channel and \fIinterp\fR is not NULL, an error message is
left in the interpreter's result.
.PP
Note: it is not safe to call \fBTcl_Close\fR on a channel that has been
registered using \fBTcl_RegisterChannel\fR; see the documentation for
\fBTcl_RegisterChannel\fR, above, for details. If the channel has ever
been given as the \fBchan\fR argument in a call to
\fBTcl_RegisterChannel\fR, you should instead use
\fBTcl_UnregisterChannel\fR, which will internally call \fBTcl_Close\fR
when all calls to \fBTcl_RegisterChannel\fR have been matched by
corresponding calls to \fBTcl_UnregisterChannel\fR.
.VS 8.1 br
.SH "TCL_READCHARS AND TCL_READ"
.PP
\fBTcl_ReadChars\fR consumes bytes from \fIchannel\fR, converting the bytes
to UTF-8 based on the channel's encoding and storing the produced data in
\fIreadObjPtr\fR's string representation. The return value of
\fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR,
that were stored in \fIreadObjPtr\fR. If an error occurs while reading, the
return value is \-1 and \fBTcl_ReadChars\fR records a POSIX error code that
can be retrieved with \fBTcl_GetErrno\fR.
.PP
Setting \fIcharsToRead\fR to \fB-1\fR will cause the command to read
all characters currently available (non-blocking) or everything until
eof (blocking mode).
.PP
The return value may be smaller than the value to read, indicating that less
data than requested was available. This is called a \fIshort read\fR. In
blocking mode, this can only happen on an end-of-file. In nonblocking mode,
a short read can also occur if there is not enough input currently
available: \fBTcl_ReadChars\fR returns a short count rather than waiting
for more data.
.PP
If the channel is in blocking mode, a return value of zero indicates an
end-of-file condition. If the channel is in nonblocking mode, a return
value of zero indicates either that no input is currently available or an
end-of-file condition. Use \fBTcl_Eof\fR and \fBTcl_InputBlocked\fR to tell
which of these conditions actually occurred.
.PP
\fBTcl_ReadChars\fR translates the various end-of-line representations into
the canonical \fB\en\fR internal representation according to the current
end-of-line recognition mode. End-of-line recognition and the various
platform-specific modes are described in the manual entry for the Tcl
\fBfconfigure\fR command.
.PP
As a performance optimization, when reading from a channel with the encoding
\fBbinary\fR, the bytes are not converted to UTF-8 as they are read.
Instead, they are stored in \fIreadObjPtr\fR's internal representation as a
byte-array object. The string representation of this object will only be
constructed if it is needed (e.g., because of a call to
\fBTcl_GetStringFromObj\fR). In this way, byte-oriented data can be read
from a channel, manipulated by calling \fBTcl_GetByteArrayFromObj\fR and
related functions, and then written to a channel without the expense of ever
converting to or from UTF-8.
.PP
\fBTcl_Read\fR is similar to \fBTcl_ReadChars\fR, except that it doesn't do
encoding conversions, regardless of the channel's encoding. It is deprecated
and exists for backwards compatibility with non-internationalized Tcl
extensions. It consumes bytes from \fIchannel\fR and stores them in
\fIreadBuf\fR, performing end-of-line translations on the way. The return value
of \fBTcl_Read\fR is the number of bytes, up to \fIbytesToRead\fR, written in
\fIreadBuf\fR. The buffer produced by \fBTcl_Read\fR is not null-terminated.
Its contents are valid from the zeroth position up to and excluding the
position indicated by the return value.
.PP
\fBTcl_ReadRaw\fR is the same as \fBTcl_Read\fR but does not
compensate for stacking. While \fBTcl_Read\fR (and the other functions
in the API) always get their data from the topmost channel in the
stack the supplied channel is part of, \fBTcl_ReadRaw\fR does
not. Thus this function is \fBonly\fR usable for transformational
channel drivers, i.e. drivers used in the middle of a stack of
channels, to move data from the channel below into the transformation.
.SH "TCL_GETSOBJ AND TCL_GETS"
.PP
\fBTcl_GetsObj\fR consumes bytes from \fIchannel\fR, converting the bytes to
UTF-8 based on the channel's encoding, until a full line of input has been
seen. If the channel's encoding is \fBbinary\fR, each byte read from the
channel is treated as an individual Unicode character. All of the
characters of the line except for the terminating end-of-line character(s)
are appended to \fIlineObjPtr\fR's string representation. The end-of-line
character(s) are read and discarded.
.PP
If a line was successfully read, the return value is greater than or equal
to zero and indicates the number of bytes stored in \fIlineObjPtr\fR. If an
error occurs, \fBTcl_GetsObj\fR returns \-1 and records a POSIX error code
that can be retrieved with \fBTcl_GetErrno\fR. \fBTcl_GetsObj\fR also
returns \-1 if the end of the file is reached; the \fBTcl_Eof\fR procedure
can be used to distinguish an error from an end-of-file condition.
.PP
If the channel is in nonblocking mode, the return value can also be \-1 if
no data was available or the data that was available did not contain an
end-of-line character. When \-1 is returned, the \fBTcl_InputBlocked\fR
procedure may be invoked to determine if the channel is blocked because
of input unavailability.
.PP
\fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting
characters are appended to the dynamic string given by
\fIlineRead\fR rather than a Tcl object.
.SH "TCL_UNGETS"
.PP
\fBTcl_Ungets\fR is used to add data to the input queue of a channel,
at either the head or tail of the queue. The pointer \fIinput\fR points
to the data that is to be added. The length of the input to add is given
by \fIinputLen\fR. A non-zero value of \fIaddAtEnd\fR indicates that the
data is to be added at the end of queue; otherwise it will be added at the
head of the queue. If \fIchannel\fR has a "sticky" EOF set, no data will be
added to the input queue. \fBTcl_Ungets\fR returns \fIinputLen\fR or
-1 if an error occurs.
.SH "TCL_WRITECHARS, TCL_WRITEOBJ, AND TCL_WRITE"
.PP
\fBTcl_WriteChars\fR accepts \fIbytesToWrite\fR bytes of character data at
\fIcharBuf\fR. The UTF-8 characters in the buffer are converted to the
channel's encoding and queued for output to \fIchannel\fR. If
\fIbytesToWrite\fR is negative, \fBTcl_WriteChars\fR expects \fIcharBuf\fR
to be null-terminated and it outputs everything up to the null.
.PP
Data queued for output may not appear on the output device immediately, due
to internal buffering. If the data should appear immediately, call
\fBTcl_Flush\fR after the call to \fBTcl_WriteChars\fR, or set the
\fB\-buffering\fR option on the channel to \fBnone\fR. If you wish the data
to appear as soon as a complete line is accepted for output, set the
\fB\-buffering\fR option on the channel to \fBline\fR mode.
.PP
The return value of \fBTcl_WriteChars\fR is a count of how many bytes were
accepted for output to the channel. This is either greater than zero to
indicate success or \-1 to indicate that an error occurred. If an error
occurs, \fBTcl_WriteChars\fR records a POSIX error code that may be
retrieved with \fBTcl_GetErrno\fR.
.PP
Newline characters in the output data are translated to platform-specific
end-of-line sequences according to the \fB\-translation\fR option for the
channel. This is done even if the channel has no encoding.
.PP
\fBTcl_WriteObj\fR is similar to \fBTcl_WriteChars\fR except it
accepts a Tcl object whose contents will be output to the channel. The
UTF-8 characters in \fIwriteObjPtr\fR's string representation are converted
to the channel's encoding and queued for output to \fIchannel\fR.
As a performance optimization, when writing to a channel with the encoding
\fBbinary\fR, UTF-8 characters are not converted as they are written.
Instead, the bytes in \fIwriteObjPtr\fR's internal representation as a
byte-array object are written to the channel. The byte-array representation
of the object will be constructed if it is needed. In this way,
byte-oriented data can be read from a channel, manipulated by calling
\fBTcl_GetByteArrayFromObj\fR and related functions, and then written to a
channel without the expense of ever converting to or from UTF-8.
.PP
\fBTcl_Write\fR is similar to \fBTcl_WriteChars\fR except that it doesn't do
encoding conversions, regardless of the channel's encoding. It is
deprecated and exists for backwards compatibility with non-internationalized
Tcl extensions. It accepts \fIbytesToWrite\fR bytes of data at
\fIbyteBuf\fR and queues them for output to \fIchannel\fR. If
\fIbytesToWrite\fR is negative, \fBTcl_Write\fR expects \fIbyteBuf\fR to be
null-terminated and it outputs everything up to the null.
.PP
\fBTcl_WriteRaw\fR is the same as \fBTcl_Write\fR but does not
compensate for stacking. While \fBTcl_Write\fR (and the other
functions in the API) always feed their input to the topmost channel
in the stack the supplied channel is part of, \fBTcl_WriteRaw\fR does
not. Thus this function is \fBonly\fR usable for transformational
channel drivers, i.e. drivers used in the middle of a stack of
channels, to move data from the transformation into the channel below
it.
.VE
.SH TCL_FLUSH
.PP
\fBTcl_Flush\fR causes all of the buffered output data for \fIchannel\fR
to be written to its underlying file or device as soon as possible.
If the channel is in blocking mode, the call does not return until
all the buffered data has been sent to the channel or some error occurred.
The call returns immediately if the channel is nonblocking; it starts
a background flush that will write the buffered data to the channel
eventually, as fast as the channel is able to absorb it.
.PP
The return value is normally \fBTCL_OK\fR.
If an error occurs, \fBTcl_Flush\fR returns \fBTCL_ERROR\fR and
records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR.
.SH TCL_SEEK
.PP
\fBTcl_Seek\fR moves the access point in \fIchannel\fR where subsequent
data will be read or written. Buffered output is flushed to the channel and
buffered input is discarded, prior to the seek operation.
.PP
\fBTcl_Seek\fR normally returns the new access point.
If an error occurs, \fBTcl_Seek\fR returns \-1 and records a POSIX error
code that can be retrieved with \fBTcl_GetErrno\fR.
After an error, the access point may or may not have been moved.
.SH TCL_TELL
.PP
\fBTcl_Tell\fR returns the current access point for a channel. The returned
value is \-1 if the channel does not support seeking.
.SH TCL_GETCHANNELOPTION
.PP
\fBTcl_GetChannelOption\fR retrieves, in \fIoptionValue\fR, the value of one of
the options currently in effect for a channel, or a list of all options and
their values. The \fIchannel\fR argument identifies the channel for which
to query an option or retrieve all options and their values.
If \fIoptionName\fR is not NULL, it is the name of the
option to query; the option's value is copied to the Tcl dynamic string
denoted by \fIoptionValue\fR. If
\fIoptionName\fR is NULL, the function stores an alternating list of option
names and their values in \fIoptionValue\fR, using a series of calls to
\fBTcl_DStringAppendElement\fR. The various preexisting options and
their possible values are described in the manual entry for the Tcl
\fBfconfigure\fR command. Other options can be added by each channel type.
These channel type specific options are described in the manual entry for
the Tcl command that creates a channel of that type; for example, the
additional options for TCP based channels are described in the manual entry
for the Tcl \fBsocket\fR command.
The procedure normally returns \fBTCL_OK\fR. If an error occurs, it returns
\fBTCL_ERROR\fR and calls \fBTcl_SetErrno\fR to store an appropriate POSIX
error code.
.SH TCL_SETCHANNELOPTION
.PP
\fBTcl_SetChannelOption\fR sets a new value \fInewValue\fR
for an option \fIoptionName\fR on \fIchannel\fR.
The procedure normally returns \fBTCL_OK\fR. If an error occurs,
it returns \fBTCL_ERROR\fR; in addition, if \fIinterp\fR is non-NULL,
\fBTcl_SetChannelOption\fR leaves an error message in the interpreter's result.
.SH TCL_EOF
.PP
\fBTcl_Eof\fR returns a nonzero value if \fIchannel\fR encountered
an end of file during the last input operation.
.SH TCL_INPUTBLOCKED
.PP
\fBTcl_InputBlocked\fR returns a nonzero value if \fIchannel\fR is in
nonblocking mode and the last input operation returned less data than
requested because there was insufficient data available.
The call always returns zero if the channel is in blocking mode.
.SH TCL_INPUTBUFFERED
.PP
\fBTcl_InputBuffered\fR returns the number of bytes of input currently
buffered in the internal buffers for a channel. If the channel is not open
for reading, this function always returns zero.
.SH TCL_OUTPUTBUFFERED
.VS 8.4
\fBTcl_OutputBuffered\fR returns the number of bytes of output
currently buffered in the internal buffers for a channel. If the
channel is not open for writing, this function always returns zero.
.VE
.SH "PLATFORM ISSUES"
.PP
The handles returned from \fBTcl_GetChannelHandle\fR depend on the
platform and the channel type. On Unix platforms, the handle is
always a Unix file descriptor as returned from the \fBopen\fR system
call. On Windows platforms, the handle is a file \fBHANDLE\fR when
the channel was created with \fBTcl_OpenFileChannel\fR,
\fBTcl_OpenCommandChannel\fR, or \fBTcl_MakeFileChannel\fR. Other
channel types may return a different type of handle on Windows
platforms.
.SH "SEE ALSO"
DString(3), fconfigure(n), filename(n), fopen(3), Tcl_CreateChannel(3)
.SH KEYWORDS
access point, blocking, buffered I/O, channel, channel driver, end of file,
flush, input, nonblocking, output, read, seek, write
tcl8.4.20/doc/ToUpper.3 0000644 0036047 0045461 00000005655 11737050674 013161 0 ustar dgp 771div '\"
'\" Copyright (c) 1997 by Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_UtfToUpper 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_UniCharToUpper, Tcl_UniCharToLower, Tcl_UniCharToTitle, Tcl_UtfToUpper, Tcl_UtfToLower, Tcl_UtfToTitle \- routines for manipulating the case of Unicode characters and UTF-8 strings.
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_UniChar
\fBTcl_UniCharToUpper\fR(\fIch\fR)
.sp
Tcl_UniChar
\fBTcl_UniCharToLower\fR(\fIch\fR)
.sp
Tcl_UniChar
\fBTcl_UniCharToTitle\fR(\fIch\fR)
.sp
int
\fBTcl_UtfToUpper\fR(\fIstr\fR)
.sp
int
\fBTcl_UtfToLower\fR(\fIstr\fR)
.sp
int
\fBTcl_UtfToTitle\fR(\fIstr\fR)
.SH ARGUMENTS
.AS char *str in/out
.AP int ch in
The Tcl_UniChar to be converted.
.AP char *str in/out
Pointer to UTF-8 string to be converted in place.
.BE
.SH DESCRIPTION
.PP
The first three routines convert the case of individual Unicode characters:
.PP
If \fIch\fR represents a lower-case character,
\fBTcl_UniCharToUpper\fR returns the corresponding upper-case
character. If no upper-case character is defined, it returns the
character unchanged.
.PP
If \fIch\fR represents an upper-case character,
\fBTcl_UniCharToLower\fR returns the corresponding lower-case
character. If no lower-case character is defined, it returns the
character unchanged.
.PP
If \fIch\fR represents a lower-case character,
\fBTcl_UniCharToTitle\fR returns the corresponding title-case
character. If no title-case character is defined, it returns the
corresponding upper-case character. If no upper-case character is
defined, it returns the character unchanged. Title-case is defined
for a small number of characters that have a different appearance when
they are at the beginning of a capitalized word.
.PP
The next three routines convert the case of UTF-8 strings in place in
memory:
.PP
\fBTcl_UtfToUpper\fR changes every UTF-8 character in \fIstr\fR to
upper-case. Because changing the case of a character may change its
size, the byte offset of each character in the resulting string may
differ from its original location. \fBTcl_UtfToUpper\fR writes a null
byte at the end of the converted string. \fBTcl_UtfToUpper\fR returns
the new length of the string in bytes. This new length is guaranteed
to be no longer than the original string length.
.PP
\fBTcl_UtfToLower\fR is the same as \fBTcl_UtfToUpper\fR except it
turns each character in the string into its lower-case equivalent.
.PP
\fBTcl_UtfToTitle\fR is the same as \fBTcl_UtfToUpper\fR except it
turns the first character in the string into its title-case equivalent
and all following characters into their lower-case equivalents.
.SH BUGS
.PP
At this time, the case conversions are only defined for the ISO8859-1
characters. Unicode characters above 0x00ff are not modified by these
routines.
.SH KEYWORDS
utf, unicode, toupper, tolower, totitle, case
tcl8.4.20/doc/for.n 0000644 0036047 0045461 00000005456 11737050674 012443 0 ustar dgp 771div '\"
'\" Copyright (c) 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.
'\"
.so man.macros
.TH for n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
for \- ``For'' loop
.SH SYNOPSIS
\fBfor \fIstart test next body\fR
.BE
.SH DESCRIPTION
.PP
\fBFor\fR is a looping command, similar in structure to the C
\fBfor\fR statement. The \fIstart\fR, \fInext\fR, and
\fIbody\fR arguments must be Tcl command strings, and \fItest\fR
is an expression string.
The \fBfor\fR command first invokes the Tcl interpreter to
execute \fIstart\fR. Then it repeatedly evaluates \fItest\fR as
an expression; if the result is non-zero it invokes the Tcl
interpreter on \fIbody\fR, then invokes the Tcl interpreter on \fInext\fR,
then repeats the loop. The command terminates when \fItest\fR evaluates
to 0. If a \fBcontinue\fR command is invoked within \fIbody\fR then
any remaining commands in the current execution of \fIbody\fR are skipped;
processing continues by invoking the Tcl interpreter on \fInext\fR, then
evaluating \fItest\fR, and so on. If a \fBbreak\fR command is invoked
within \fIbody\fR
or \fInext\fR,
then the \fBfor\fR command will
return immediately.
The operation of \fBbreak\fR and \fBcontinue\fR are similar to the
corresponding statements in C.
\fBFor\fR returns an empty string.
.PP
Note: \fItest\fR should almost always be enclosed in braces. If not,
variable substitutions will be made before the \fBfor\fR
command starts executing, which means that variable changes
made by the loop body will not be considered in the expression.
This is likely to result in an infinite loop. If \fItest\fR is
enclosed in braces, variable substitutions are delayed until the
expression is evaluated (before
each loop iteration), so changes in the variables will be visible.
See below for an example:
.SH EXAMPLES
Print a line for each of the integers from 0 to 10:
.CS
for {set x 0} {$x<10} {incr x} {
puts "x is $x"
}
.CE
.PP
Either loop infinitely or not at all because the expression being
evaluated is actually the constant, or even generate an error! The
actual behaviour will depend on whether the variable \fIx\fR exists
before the \fBfor\fR command is run and whether its value is a value
that is less than or greater than/equal to ten, and this is because
the expression will be substituted before the \fBfor\fR command is
executed.
.CS
for {set x 0} $x<10 {incr x} {
puts "x is $x"
}
.CE
.PP
Print out the powers of two from 1 to 1024:
.CS
for {set x 1} {$x<=1024} {set x [expr {$x * 2}]} {
puts "x is $x"
}
.CE
.SH "SEE ALSO"
break, continue, foreach, while
.SH KEYWORDS
for, iteration, looping
tcl8.4.20/doc/Exit.3 0000644 0036047 0045461 00000012324 11737050674 012463 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH Tcl_Exit 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Exit, Tcl_Finalize, Tcl_CreateExitHandler, Tcl_DeleteExitHandler, Tcl_ExitThread, Tcl_FinalizeThread, Tcl_CreateThreadExitHandler, Tcl_DeleteThreadExitHandler \- end the application or thread (and invoke exit handlers)
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_Exit\fR(\fIstatus\fR)
.sp
\fBTcl_Finalize\fR()
.sp
\fBTcl_CreateExitHandler\fR(\fIproc, clientData\fR)
.sp
\fBTcl_DeleteExitHandler\fR(\fIproc, clientData\fR)
.sp
\fBTcl_ExitThread\fR(\fIstatus\fR)
.sp
\fBTcl_FinalizeThread\fR()
.sp
\fBTcl_CreateThreadExitHandler\fR(\fIproc, clientData\fR)
.sp
\fBTcl_DeleteThreadExitHandler\fR(\fIproc, clientData\fR)
.SH ARGUMENTS
.AS Tcl_ExitProc clientData
.AP int status in
Provides information about why the application or thread exited.
Exact meaning may
be platform-specific. 0 usually means a normal exit, any nonzero value
usually means that an error occurred.
.AP Tcl_ExitProc *proc in
Procedure to invoke before exiting application.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE
.SH DESCRIPTION
.PP
The procedures described here provide a graceful mechanism to end the
execution of a \fBTcl\fR application. Exit handlers are invoked to cleanup the
application's state before ending the execution of \fBTcl\fR code.
.PP
Invoke \fBTcl_Exit\fR to end a \fBTcl\fR application and to exit from this
process. This procedure is invoked by the \fBexit\fR command, and can be
invoked anyplace else to terminate the application.
No-one should ever invoke the \fBexit\fR system procedure directly; always
invoke \fBTcl_Exit\fR instead, so that it can invoke exit handlers.
Note that if other code invokes \fBexit\fR system procedure directly, or
otherwise causes the application to terminate without calling
\fBTcl_Exit\fR, the exit handlers will not be run.
\fBTcl_Exit\fR internally invokes the \fBexit\fR system call, thus it never
returns control to its caller.
.PP
\fBTcl_Finalize\fR is similar to \fBTcl_Exit\fR except that it does not
exit from the current process.
It is useful for cleaning up when a process is finished using \fBTcl\fR but
wishes to continue executing, and when \fBTcl\fR is used in a dynamically
loaded extension that is about to be unloaded.
On some systems \fBTcl\fR is automatically notified when it is being
unloaded, and it calls \fBTcl_Finalize\fR internally; on these systems it
not necessary for the caller to explicitly call \fBTcl_Finalize\fR.
However, to ensure portability, your code should always invoke
\fBTcl_Finalize\fR when \fBTcl\fR is being unloaded, to ensure that the
code will work on all platforms. \fBTcl_Finalize\fR can be safely called
more than once.
.PP
.VS
\fBTcl_ExitThread\fR is used to terminate the current thread and invoke
per-thread exit handlers. This finalization is done by
\fBTcl_FinalizeThread\fR, which you can call if you just want to clean
up per-thread state and invoke the thread exit handlers.
\fBTcl_Finalize\fR calls \fBTcl_FinalizeThread\fR for the current
thread automatically.
.VE
.PP
\fBTcl_CreateExitHandler\fR arranges for \fIproc\fR to be invoked
by \fBTcl_Finalize\fR and \fBTcl_Exit\fR.
\fBTcl_CreateThreadExitHandler\fR arranges for \fIproc\fR to be invoked
by \fBTcl_FinalizeThread\fR and \fBTcl_ExitThread\fR.
This provides a hook for cleanup operations such as flushing buffers
and freeing global memory.
\fIProc\fR should match the type \fBTcl_ExitProc\fR:
.CS
typedef void Tcl_ExitProc(ClientData \fIclientData\fR);
.CE
The \fIclientData\fR parameter to \fIproc\fR is a
copy of the \fIclientData\fR argument given to
\fBTcl_CreateExitHandler\fR or \fBTcl_CreateThreadExitHandler\fR when
the callback
was created. Typically, \fIclientData\fR points to a data
structure containing application-specific information about
what to do in \fIproc\fR.
.PP
\fBTcl_DeleteExitHandler\fR and \fBTcl_DeleteThreadExitHandler\fR may be
called to delete a
previously-created exit handler. It removes the handler
indicated by \fIproc\fR and \fIclientData\fR so that no call
to \fIproc\fR will be made. If no such handler exists then
\fBTcl_DeleteExitHandler\fR or \fBTcl_DeleteThreadExitHandler\fR does nothing.
.PP
.VS
.PP
\fBTcl_Finalize\fR and \fBTcl_Exit\fR execute all registered exit handlers,
in reverse order from the order in which they were registered.
This matches the natural order in which extensions are loaded and unloaded;
if extension \fBA\fR loads extension \fBB\fR, it usually
unloads \fBB\fR before it itself is unloaded.
If extension \fBA\fR registers its exit handlers before loading extension
\fBB\fR, this ensures that any exit handlers for \fBB\fR will be executed
before the exit handlers for \fBA\fR.
.VE
.VS
.PP
\fBTcl_Finalize\fR and \fBTcl_Exit\fR call \fBTcl_FinalizeThread\fR
and the thread exit handlers \fIafter\fR
the process-wide exit handlers. This is because thread finalization shuts
down the I/O channel system, so any attempt at I/O by the global exit
handlers will vanish into the bitbucket.
.VE
.SH KEYWORDS
callback, cleanup, dynamic loading, end application, exit, unloading, thread
tcl8.4.20/doc/join.n 0000644 0036047 0045461 00000002214 11737050674 012601 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH join n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
join \- Create a string by joining together list elements
.SH SYNOPSIS
\fBjoin \fIlist \fR?\fIjoinString\fR?
.BE
.SH DESCRIPTION
.PP
The \fIlist\fR argument must be a valid Tcl list.
This command returns the string
formed by joining all of the elements of \fIlist\fR together with
\fIjoinString\fR separating each adjacent pair of elements.
The \fIjoinString\fR argument defaults to a space character.
.SH EXAMPLES
Making a comma-separated list:
.CS
set data {1 2 3 4 5}
\fBjoin\fR $data ", "
\fB=> 1, 2, 3, 4, 5\fR
.CE
.PP
Using \fBjoin\fR to flatten a list by a single level:
.CS
set data {1 {2 3} 4 {5 {6 7} 8}}
\fBjoin\fR $data
\fB=> 1 2 3 4 5 {6 7} 8\fR
.CE
.SH "SEE ALSO"
list(n), lappend(n), split(n)
.SH KEYWORDS
element, join, list, separator
tcl8.4.20/doc/Concat.3 0000644 0036047 0045461 00000003271 11737050674 012762 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_Concat 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Concat \- concatenate a collection of strings
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
CONST char *
\fBTcl_Concat\fR(\fIargc, argv\fR)
.SH ARGUMENTS
.AP int argc in
Number of strings.
.AP "CONST char * CONST" argv[] in
Array of strings to concatenate. Must have \fIargc\fR entries.
.BE
.SH DESCRIPTION
.PP
\fBTcl_Concat\fR is a utility procedure used by several of the
Tcl commands. Given a collection of strings, it concatenates
them together into a single string, with the original strings
separated by spaces. This procedure behaves differently than
\fBTcl_Merge\fR, in that the arguments are simply concatenated:
no effort is made to ensure proper list structure.
However, in most common usage the arguments will all be proper
lists themselves; if this is true, then the result will also have
proper list structure.
.PP
\fBTcl_Concat\fR eliminates leading and trailing white space as it
copies strings from \fBargv\fR to the result. If an element of
\fBargv\fR consists of nothing but white space, then that string
is ignored entirely. This white-space removal was added to make
the output of the \fBconcat\fR command cleaner-looking.
.PP
.VS
The result string is dynamically allocated
using \fBTcl_Alloc\fR; the caller must eventually release the space
by calling \fBTcl_Free\fR.
.VE
.VS
.SH "SEE ALSO"
Tcl_ConcatObj
.SH KEYWORDS
concatenate, strings
tcl8.4.20/doc/incr.n 0000644 0036047 0045461 00000002625 11737050674 012603 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH incr n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
incr \- Increment the value of a variable
.SH SYNOPSIS
\fBincr \fIvarName \fR?\fIincrement\fR?
.BE
.SH DESCRIPTION
.PP
Increments the value stored in the variable whose name is \fIvarName\fR.
The value of the variable must be an integer.
If \fIincrement\fR is supplied then its value (which must be an
integer) is added to the value of variable \fIvarName\fR; otherwise
1 is added to \fIvarName\fR.
The new value is stored as a decimal string in variable \fIvarName\fR
and also returned as result.
.SH EXAMPLES
Add one to the contents of the variable \fIx\fR:
.CS
\fBincr\fR x
.CE
.PP
Add 42 to the contents of the variable \fIx\fR:
.CS
\fBincr\fR x 42
.CE
.PP
Add the contents of the variable \fIy\fR to the contents of the
variable \fIx\fR:
.CS
\fBincr\fR x $y
.CE
.PP
Add nothing at all to the variable \fIx\fR (often useful for checking
whether an argument to a procedure is actually numeric and generating
an error if it is not):
.CS
\fBincr\fR x 0
.CE
.SH "SEE ALSO"
expr(n)
.SH KEYWORDS
add, increment, variable, value
tcl8.4.20/doc/scan.n 0000644 0036047 0045461 00000024456 11737050674 012602 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH scan n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
scan \- Parse string using conversion specifiers in the style of sscanf
.SH SYNOPSIS
\fBscan \fIstring format \fR?\fIvarName varName ...\fR?
.BE
.SH INTRODUCTION
.PP
This command parses fields from an input string in the same fashion as the
ANSI C \fBsscanf\fR procedure and returns a count of the number of
conversions performed, or -1 if the end of the input string is reached
before any conversions have been performed. \fIString\fR gives the input
to be parsed and \fIformat\fR indicates how to parse it, using \fB%\fR
conversion specifiers as in \fBsscanf\fR. Each \fIvarName\fR gives the
name of a variable; when a field is scanned from \fIstring\fR the result is
converted back into a string and assigned to the corresponding variable.
If no \fIvarName\fR variables are specified, then \fBscan\fR works in an
inline manner, returning the data that would otherwise be stored in the
variables as a list. In the inline case, an empty string is returned when
the end of the input string is reached before any conversions have been
performed.
.SH "DETAILS ON SCANNING"
.PP
\fBScan\fR operates by scanning \fIstring\fR and \fIformat\fR together.
If the next character in \fIformat\fR is a blank or tab then it
matches any number of white space characters in \fIstring\fR (including
zero).
Otherwise, if it isn't a \fB%\fR character then it
must match the next character of \fIstring\fR.
When a \fB%\fR is encountered in \fIformat\fR, it indicates
the start of a conversion specifier.
.VS 8.4
A conversion specifier contains up to four fields after the \fB%\fR:
a \fB*\fR, which indicates that the converted value is to be discarded
instead of assigned to a variable; a XPG3 position specifier; a number
indicating a maximum field width; a field size modifier; and a
conversion character.
.VE 8.4
All of these fields are optional except for the conversion character.
The fields that are present must appear in the order given above.
.PP
When \fBscan\fR finds a conversion specifier in \fIformat\fR, it
first skips any white-space characters in \fIstring\fR (unless the
specifier is \fB[\fR or \fBc\fR).
Then it converts the next input characters according to the
conversion specifier and stores the result in the variable given
by the next argument to \fBscan\fR.
.PP
If the \fB%\fR is followed by a decimal number and a \fB$\fR, as in
``\fB%2$d\fR'', then the variable to use is not taken from the next
sequential argument. Instead, it is taken from the argument indicated
by the number, where 1 corresponds to the first \fIvarName\fR. If
there are any positional specifiers in \fIformat\fR then all of the
specifiers must be positional. Every \fIvarName\fR on the argument
list must correspond to exactly one conversion specifier or an error
is generated, or in the inline case, any position can be specified
at most once and the empty positions will be filled in with empty strings.
.PP
The following conversion characters are supported:
.TP 10
\fBd\fR
The input field must be a decimal integer.
It is read in and the value is stored in the variable as a decimal string.
.VS 8.4
If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
.VE 8.4
.TP 10
\fBo\fR
The input field must be an octal integer. It is read in and the
value is stored in the variable as a decimal string.
.VS 8.4
If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
If the value exceeds MAX_INT (017777777777 on platforms using 32-bit
integers when the \fBl\fR and \fBL\fR modifiers are not given), it
will be truncated to a signed integer. Hence, 037777777777 will
appear as -1 on a 32-bit machine by default.
.VE 8.4
.TP 10
\fBx\fR
The input field must be a hexadecimal integer. It is read in
and the value is stored in the variable as a decimal string.
.VS 8.4
If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
If the value exceeds MAX_INT (0x7FFFFFFF on platforms using 32-bit
integers when the \fBl\fR and \fBL\fR modifiers are not given), it
will be truncated to a signed integer. Hence, 0xFFFFFFFF will appear
as -1 on a 32-bit machine.
.VE 8.4
.TP 10
\fBu\fR
The input field must be a decimal integer. The value is stored in the
variable as an unsigned decimal integer string.
.VS 8.4
If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
.VE 8.4
.TP 10
\fBi\fR
The input field must be an integer. The base (i.e. decimal, octal, or
hexadecimal) is determined in the same fashion as described in
\fBexpr\fR. The value is stored in the variable as a decimal string.
.VS 8.4
If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
value will have an internal representation that is at least 64-bits in
size.
.VE 8.4
.TP 10
\fBc\fR
A single character is read in and its binary value is stored in
the variable as a decimal string.
Initial white space is not skipped in this case, so the input
field may be a white-space character.
This conversion is different from the ANSI standard in that the
input field always consists of a single character and no field
width may be specified.
.TP 10
\fBs\fR
The input field consists of all the characters up to the next
white-space character; the characters are copied to the variable.
.TP 10
\fBe\fR or \fBf\fR or \fBg\fR
The input field must be a floating-point number consisting
of an optional sign, a string of decimal digits possibly
containing a decimal point, and an optional exponent consisting
of an \fBe\fR or \fBE\fR followed by an optional sign and a string of
decimal digits.
It is read in and stored in the variable as a floating-point string.
.TP 10
\fB[\fIchars\fB]\fR
The input field consists of any number of characters in
\fIchars\fR.
The matching string is stored in the variable.
If the first character between the brackets is a \fB]\fR then
it is treated as part of \fIchars\fR rather than the closing
bracket for the set.
If \fIchars\fR
contains a sequence of the form \fIa\fB\-\fIb\fR then any
character between \fIa\fR and \fIb\fR (inclusive) will match.
If the first or last character between the brackets is a \fB\-\fR, then
it is treated as part of \fIchars\fR rather than indicating a range.
.TP 10
\fB[^\fIchars\fB]\fR
The input field consists of any number of characters not in
\fIchars\fR.
The matching string is stored in the variable.
If the character immediately following the \fB^\fR is a \fB]\fR then it is
treated as part of the set rather than the closing bracket for
the set.
If \fIchars\fR
contains a sequence of the form \fIa\fB\-\fIb\fR then any
character between \fIa\fR and \fIb\fR (inclusive) will be excluded
from the set.
If the first or last character between the brackets is a \fB\-\fR, then
it is treated as part of \fIchars\fR rather than indicating a range.
.TP 10
\fBn\fR
No input is consumed from the input string. Instead, the total number
of characters scanned from the input string so far is stored in the variable.
.LP
The number of characters read from the input for a conversion is the
largest number that makes sense for that particular conversion (e.g.
as many decimal digits as possible for \fB%d\fR, as
many octal digits as possible for \fB%o\fR, and so on).
The input field for a given conversion terminates either when a
white-space character is encountered or when the maximum field
width has been reached, whichever comes first.
If a \fB*\fR is present in the conversion specifier
then no variable is assigned and the next scan argument is not consumed.
.SH "DIFFERENCES FROM ANSI SSCANF"
.PP
The behavior of the \fBscan\fR command is the same as the behavior of
the ANSI C \fBsscanf\fR procedure except for the following differences:
.IP [1]
\fB%p\fR conversion specifier is not currently supported.
.IP [2]
For \fB%c\fR conversions a single character value is
converted to a decimal string, which is then assigned to the
corresponding \fIvarName\fR;
no field width may be specified for this conversion.
.IP [3]
.VS 8.4
The \fBh\fR modifier is always ignored and the \fBl\fR and \fBL\fR
modifiers are ignored when converting real values (i.e. type
\fBdouble\fR is used for the internal representation).
.VE 8.4
.IP [4]
If the end of the input string is reached before any conversions have been
performed and no variables are given, an empty string is returned.
.SH EXAMPLES
Parse a simple color specification of the form \fI#RRGGBB\fR using
hexadecimal conversions with field sizes:
.CS
set string "#08D03F"
\fBscan\fR $string "#%2x%2x%2x" r g b
.CE
.PP
Parse a \fIHH:MM\fR time string, noting that this avoids problems with
octal numbers by forcing interpretation as decimals (if we did not
care, we would use the \fB%i\fR conversion instead):
.CS
set string "08:08" ;# *Not* octal!
if {[\fBscan\fR $string "%d:%d" hours minutes] != 2} {
error "not a valid time string"
}
# We have to understand numeric ranges ourselves...
if {$minutes < 0 || $minutes > 59} {
error "invalid number of minutes"
}
.CE
.PP
Break a string up into sequences of non-whitespace characters (note
the use of the \fB%n\fR conversion so that we get skipping over
leading whitespace correct):
.CS
set string " a string {with braced words} + leading space "
set words {}
while {[\fBscan\fR $string %s%n word length] == 2} {
lappend words $word
set string [string range $string $length end]
}
.CE
.PP
Parse a simple coordinate string, checking that it is complete by
looking for the terminating character explicitly:
.CS
set string "(5.2,-4e-2)"
# Note that the spaces before the literal parts of
# the scan pattern are significant, and that ")" is
# the Unicode character \\u0029
if {
[\fBscan\fR $string " (%f ,%f %c" x y last] != 3
|| $last != 0x0029
} then {
error "invalid coordinate string"
}
puts "X=$x, Y=$y"
.CE
.SH "SEE ALSO"
format(n), sscanf(3)
.SH KEYWORDS
conversion specifier, parse, scan
tcl8.4.20/doc/ExprLongObj.3 0000644 0036047 0045461 00000007166 11737050674 013753 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_ExprLongObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj \- evaluate an expression
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_ExprLongObj\fR(\fIinterp, objPtr, longPtr\fR)
.sp
int
\fBTcl_ExprDoubleObj\fR(\fIinterp, objPtr, doublePtr\fR)
.sp
int
\fBTcl_ExprBooleanObj\fR(\fIinterp, objPtr, booleanPtr\fR)
.sp
int
\fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp **resultPtrPtr out
.AP Tcl_Interp *interp in
Interpreter in whose context to evaluate \fIobjPtr\fR.
.AP Tcl_Obj *objPtr in
Pointer to an object containing the expression to evaluate.
.AP long *longPtr out
Pointer to location in which to store the integer value of the
expression.
.AP int *doublePtr out
Pointer to location in which to store the floating-point value of the
expression.
.AP int *booleanPtr out
Pointer to location in which to store the 0/1 boolean value of the
expression.
.AP Tcl_Obj **resultPtrPtr out
Pointer to location in which to store a pointer to the object
that is the result of the expression.
.BE
.SH DESCRIPTION
.PP
These four procedures all evaluate an expression, returning
the result in one of four different forms.
The expression is given by the \fIobjPtr\fR argument, and it
can have any of the forms accepted by the \fBexpr\fR command.
.PP
The \fIinterp\fR argument refers to an interpreter used to
evaluate the expression (e.g. for variables and nested Tcl
commands) and to return error information.
.PP
For all of these procedures the return value is a standard
Tcl result: \fBTCL_OK\fR means the expression was successfully
evaluated, and \fBTCL_ERROR\fR means that an error occurred while
evaluating the expression.
If \fBTCL_ERROR\fR is returned,
then a message describing the error
can be retrieved using \fBTcl_GetObjResult\fR.
If an error occurs while executing a Tcl command embedded in
the expression then that error will be returned.
.PP
If the expression is successfully evaluated, then its value is
returned in one of four forms, depending on which procedure
is invoked.
\fBTcl_ExprLongObj\fR stores an integer value at \fI*longPtr\fR.
If the expression's actual value is a floating-point number,
then it is truncated to an integer.
If the expression's actual value is a non-numeric string then
an error is returned.
.PP
\fBTcl_ExprDoubleObj\fR stores a floating-point value at \fI*doublePtr\fR.
If the expression's actual value is an integer, it is converted to
floating-point.
If the expression's actual value is a non-numeric string then
an error is returned.
.PP
\fBTcl_ExprBooleanObj\fR stores a 0/1 integer value at \fI*booleanPtr\fR.
If the expression's actual value is an integer or floating-point
number, then they store 0 at \fI*booleanPtr\fR if
the value was zero and 1 otherwise.
If the expression's actual value is a non-numeric string then
it must be one of the values accepted by \fBTcl_GetBoolean\fR
such as ``yes'' or ``no'', or else an error occurs.
.PP
If \fBTcl_ExprObj\fR successfully evaluates the expression,
it stores a pointer to the Tcl object
containing the expression's value at \fI*resultPtrPtr\fR.
In this case, the caller is responsible for calling
\fBTcl_DecrRefCount\fR to decrement the object's reference count
when it is finished with the object.
.SH "SEE ALSO"
Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString, Tcl_GetObjResult
.SH KEYWORDS
boolean, double, evaluate, expression, integer, object, string
tcl8.4.20/doc/GetVersion.3 0000755 0036047 0045461 00000003074 11737050674 013644 0 ustar dgp 771div '\"
'\" Copyright (c) 1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_GetVersion 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetVersion \- get the version of the library at runtime
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_GetVersion\fR(\fImajor, minor, patchLevel, type\fR)
.SH ARGUMENTS
.AP int *major out
Major version number of the Tcl library.
.AP int *minor out
Minor version number of the Tcl library.
.AP int *patchLevel out
The patch level of the Tcl library (or alpha or beta number).
.AP Tcl_ReleaseType *type out
The type of release, also indicates the type of patch level. Can be
one of \fBTCL_ALPHA_RELEASE\fR, \fBTCL_BETA_RELEASE\fR, or
\fBTCL_FINAL_RELEASE\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_GetVersion\fR should be used to query the version number
of the Tcl library at runtime. This is useful when using a
dynamically loaded Tcl library or when writing a stubs-aware
extension. For instance, if you write an extension that is
linked against the Tcl stubs library, it could be loaded into
a program linked to an older version of Tcl than you expected.
Use \fBTcl_GetVersion\fR to verify that fact, and possibly to
change the behavior of your extension.
.PP
\fBTcl_GetVersion\fR accepts NULL for any of the arguments. For instance if
you do not care about the \fIpatchLevel\fR of the library, pass
a NULL for the \fIpatchLevel\fR argument.
.SH KEYWORDS
version, patchlevel, major, minor, alpha, beta, release
tcl8.4.20/doc/RegExp.3 0000644 0036047 0045461 00000035357 11737050674 012757 0 ustar dgp 771div '\"
'\" Copyright (c) 1994 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.
'\"
.so man.macros
.TH Tcl_RegExpMatch 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange, Tcl_GetRegExpFromObj, Tcl_RegExpMatchObj, Tcl_RegExpExecObj, Tcl_RegExpGetInfo \- Pattern matching with regular expressions
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_RegExpMatchObj\fR(\fIinterp\fR, \fIstrObj\fR, \fIpatObj\fR)
.sp
int
\fBTcl_RegExpMatch\fR(\fIinterp\fR, \fIstring\fR, \fIpattern\fR)
.sp
Tcl_RegExp
\fBTcl_RegExpCompile\fR(\fIinterp\fR, \fIpattern\fR)
.sp
int
\fBTcl_RegExpExec\fR(\fIinterp\fR, \fIregexp\fR, \fIstring\fR, \fIstart\fR)
.sp
\fBTcl_RegExpRange\fR(\fIregexp\fR, \fIindex\fR, \fIstartPtr\fR, \fIendPtr\fR)
.VS 8.1
.sp
Tcl_RegExp
\fBTcl_GetRegExpFromObj\fR(\fIinterp\fR, \fIpatObj\fR, \fIcflags\fR)
.sp
int
\fBTcl_RegExpExecObj\fR(\fIinterp\fR, \fIregexp\fR, \fIobjPtr\fR, \fIoffset\fR, \fInmatches\fR, \fIeflags\fR)
.sp
\fBTcl_RegExpGetInfo\fR(\fIregexp\fR, \fIinfoPtr\fR)
.VE 8.1
.SH ARGUMENTS
.AS Tcl_Interp *interp
.AP Tcl_Interp *interp in
Tcl interpreter to use for error reporting. The interpreter may be
NULL if no error reporting is desired.
.VS 8.1
.AP Tcl_Obj *strObj in/out
Refers to the object from which to get the string to search. The
internal representation of the object may be converted to a form that
can be efficiently searched.
.AP Tcl_Obj *patObj in/out
Refers to the object from which to get a regular expression. The
compiled regular expression is cached in the object.
.VE 8.1
.AP char *string in
String to check for a match with a regular expression.
.AP "CONST char" *pattern in
String in the form of a regular expression pattern.
.AP Tcl_RegExp regexp in
Compiled regular expression. Must have been returned previously
by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR.
.AP char *start in
If \fIstring\fR is just a portion of some other string, this argument
identifies the beginning of the larger string.
If it isn't the same as \fIstring\fR, then no \fB^\fR matches
will be allowed.
.AP int index in
Specifies which range is desired: 0 means the range of the entire
match, 1 or greater means the range that matched a parenthesized
sub-expression.
.VS 8.4
.AP "CONST char" **startPtr out
The address of the first character in the range is stored here, or
NULL if there is no such range.
.AP "CONST char" **endPtr out
The address of the character just after the last one in the range
is stored here, or NULL if there is no such range.
.VE 8.4
.VS 8.1
.AP int cflags in
OR-ed combination of compilation flags. See below for more information.
.AP Tcl_Obj *objPtr in/out
An object which contains the string to check for a match with a
regular expression.
.AP int offset in
The character offset into the string where matching should begin.
The value of the offset has no impact on \fB^\fR matches. This
behavior is controlled by \fIeflags\fR.
.AP int nmatches in
The number of matching subexpressions that should be remembered for
later use. If this value is 0, then no subexpression match
information will be computed. If the value is -1, then
all of the matching subexpressions will be remembered. Any other
value will be taken as the maximum number of subexpressions to
remember.
.AP int eflags in
OR-ed combination of the values TCL_REG_NOTBOL and TCL_REG_NOTEOL.
See below for more information.
.AP Tcl_RegExpInfo *infoPtr out
The address of the location where information about a previous match
should be stored by \fBTcl_RegExpGetInfo\fR.
.VE 8.1
.BE
.SH DESCRIPTION
.PP
\fBTcl_RegExpMatch\fR determines whether its \fIpattern\fR argument
matches \fIregexp\fR, where \fIregexp\fR is interpreted
as a regular expression using the rules in the \fBre_syntax\fR
reference page.
If there is a match then \fBTcl_RegExpMatch\fR returns 1.
If there is no match then \fBTcl_RegExpMatch\fR returns 0.
If an error occurs in the matching process (e.g. \fIpattern\fR
is not a valid regular expression) then \fBTcl_RegExpMatch\fR
returns \-1 and leaves an error message in the interpreter result.
.VS 8.1.2
\fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it
operates on the Tcl objects \fIstrObj\fR and \fIpatObj\fR instead of
UTF strings.
\fBTcl_RegExpMatchObj\fR is generally more efficient than
\fBTcl_RegExpMatch\fR, so it is the preferred interface.
.VE 8.1.2
.PP
\fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR
provide lower-level access to the regular expression pattern matcher.
\fBTcl_RegExpCompile\fR compiles a regular expression string into
the internal form used for efficient pattern matching.
The return value is a token for this compiled form, which can be
used in subsequent calls to \fBTcl_RegExpExec\fR or \fBTcl_RegExpRange\fR.
If an error occurs while compiling the regular expression then
\fBTcl_RegExpCompile\fR returns NULL and leaves an error message
in the interpreter result.
Note: the return value from \fBTcl_RegExpCompile\fR is only valid
up to the next call to \fBTcl_RegExpCompile\fR; it is not safe to
retain these values for long periods of time.
.PP
\fBTcl_RegExpExec\fR executes the regular expression pattern matcher.
It returns 1 if \fIstring\fR contains a range of characters that
match \fIregexp\fR, 0 if no match is found, and
\-1 if an error occurs.
In the case of an error, \fBTcl_RegExpExec\fR leaves an error
message in the interpreter result.
When searching a string for multiple matches of a pattern,
it is important to distinguish between the start of the original
string and the start of the current search.
For example, when searching for the second occurrence of a
match, the \fIstring\fR argument might point to the character
just after the first match; however, it is important for the
pattern matcher to know that this is not the start of the entire string,
so that it doesn't allow \fB^\fR atoms in the pattern to match.
The \fIstart\fR argument provides this information by pointing
to the start of the overall string containing \fIstring\fR.
\fIStart\fR will be less than or equal to \fIstring\fR; if it
is less than \fIstring\fR then no \fB^\fR matches will be allowed.
.PP
\fBTcl_RegExpRange\fR may be invoked after \fBTcl_RegExpExec\fR
returns; it provides detailed information about what ranges of
the string matched what parts of the pattern.
\fBTcl_RegExpRange\fR returns a pair of pointers in \fI*startPtr\fR
and \fI*endPtr\fR that identify a range of characters in
the source string for the most recent call to \fBTcl_RegExpExec\fR.
\fIIndex\fR indicates which of several ranges is desired:
if \fIindex\fR is 0, information is returned about the overall range
of characters that matched the entire pattern; otherwise,
information is returned about the range of characters that matched the
\fIindex\fR'th parenthesized subexpression within the pattern.
If there is no range corresponding to \fIindex\fR then NULL
is stored in \fI*startPtr\fR and \fI*endPtr\fR.
.PP
.VS 8.1
\fBTcl_GetRegExpFromObj\fR, \fBTcl_RegExpExecObj\fR, and
\fBTcl_RegExpGetInfo\fR are object interfaces that provide the most
direct control of Henry Spencer's regular expression library. For
users that need to modify compilation and execution options directly,
it is recommended that you use these interfaces instead of calling the
internal regexp functions. These interfaces handle the details of UTF
to Unicode translations as well as providing improved performance
through caching in the pattern and string objects.
.PP
\fBTcl_GetRegExpFromObj\fR attempts to return a compiled regular
expression from the \fIpatObj\fR. If the object does not already
contain a compiled regular expression it will attempt to create one
from the string in the object and assign it to the internal
representation of the \fIpatObj\fR. The return value of this function
is of type \fBTcl_RegExp\fR. The return value is a token for this
compiled form, which can be used in subsequent calls to
\fBTcl_RegExpExecObj\fR or \fBTcl_RegExpGetInfo\fR. If an error
occurs while compiling the regular expression then
\fBTcl_GetRegExpFromObj\fR returns NULL and leaves an error message in
the interpreter result. The regular expression token can be used as
long as the internal representation of \fIpatObj\fR refers to the
compiled form. The \fIeflags\fR argument is a bitwise OR of
zero or more of the following flags that control the compilation of
\fIpatObj\fR:
.RS 2
.TP
\fBTCL_REG_ADVANCED\fR
Compile advanced regular expressions (`AREs'). This mode corresponds to
the normal regular expression syntax accepted by the Tcl regexp and
regsub commands.
.TP
\fBTCL_REG_EXTENDED\fR
Compile extended regular expressions (`EREs'). This mode corresponds
to the regular expression syntax recognized by Tcl 8.0 and earlier
versions.
.TP
\fBTCL_REG_BASIC\fR
Compile basic regular expressions (`BREs'). This mode corresponds
to the regular expression syntax recognized by common Unix utilities
like \fBsed\fR and \fBgrep\fR. This is the default if no flags are
specified.
.TP
\fBTCL_REG_EXPANDED\fR
Compile the regular expression (basic, extended, or advanced) using an
expanded syntax that allows comments and whitespace. This mode causes
non-backslashed non-bracket-expression white
space and #-to-end-of-line comments to be ignored.
.TP
\fBTCL_REG_QUOTE\fR
Compile a literal string, with all characters treated as ordinary characters.
.TP
\fBTCL_REG_NOCASE\fR
Compile for matching that ignores upper/lower case distinctions.
.TP
\fBTCL_REG_NEWLINE\fR
Compile for newline-sensitive matching. By default, newline is a
completely ordinary character with no special meaning in either
regular expressions or strings. With this flag, `[^' bracket
expressions and `.' never match newline, `^' matches an empty string
after any newline in addition to its normal function, and `$' matches
an empty string before any newline in addition to its normal function.
\fBREG_NEWLINE\fR is the bitwise OR of \fBREG_NLSTOP\fR and
\fBREG_NLANCH\fR.
.TP
\fBTCL_REG_NLSTOP\fR
Compile for partial newline-sensitive matching,
with the behavior of
`[^' bracket expressions and `.' affected,
but not the behavior of `^' and `$'. In this mode, `[^' bracket
expressions and `.' never match newline.
.TP
\fBTCL_REG_NLANCH\fR
Compile for inverse partial newline-sensitive matching,
with the behavior of
of `^' and `$' (the ``anchors'') affected, but not the behavior of
`[^' bracket expressions and `.'. In this mode `^' matches an empty string
after any newline in addition to its normal function, and `$' matches
an empty string before any newline in addition to its normal function.
.TP
\fBTCL_REG_NOSUB\fR
Compile for matching that reports only success or failure,
not what was matched. This reduces compile overhead and may improve
performance. Subsequent calls to \fBTcl_RegExpGetInfo\fR or
\fBTcl_RegExpRange\fR will not report any match information.
.TP
\fBTCL_REG_CANMATCH\fR
Compile for matching that reports the potential to complete a partial
match given more text (see below).
.RE
.PP
Only one of
\fBTCL_REG_EXTENDED\fR,
\fBTCL_REG_ADVANCED\fR,
\fBTCL_REG_BASIC\fR, and
\fBTCL_REG_QUOTE\fR may be specified.
.PP
\fBTcl_RegExpExecObj\fR executes the regular expression pattern
matcher. It returns 1 if \fIobjPtr\fR contains a range of characters
that match \fIregexp\fR, 0 if no match is found, and \-1 if an error
occurs. In the case of an error, \fBTcl_RegExpExecObj\fR leaves an
error message in the interpreter result. The \fInmatches\fR value
indicates to the matcher how many subexpressions are of interest. If
\fInmatches\fR is 0, then no subexpression match information is
recorded, which may allow the matcher to make various optimizations.
If the value is -1, then all of the subexpressions in the pattern are
remembered. If the value is a positive integer, then only that number
of subexpressions will be remembered. Matching begins at the
specified Unicode character index given by \fIoffset\fR. Unlike
\fBTcl_RegExpExec\fR, the behavior of anchors is not affected by the
offset value. Instead the behavior of the anchors is explicitly
controlled by the \fIeflags\fR argument, which is a bitwise OR of
zero or more of the following flags:
.RS 2
.TP
\fBTCL_REG_NOTBOL\fR
The starting character will not be treated as the beginning of a
line or the beginning of the string, so `^' will not match there.
Note that this flag has no effect on how `\fB\eA\fR' matches.
.TP
\fBTCL_REG_NOTEOL\fR
The last character in the string will not be treated as the end of a
line or the end of the string, so '$' will not match there.
Note that this flag has no effect on how `\fB\eZ\fR' matches.
.RE
.PP
\fBTcl_RegExpGetInfo\fR retrieves information about the last match
performed with a given regular expression \fIregexp\fR. The
\fIinfoPtr\fR argument contains a pointer to a structure that is
defined as follows:
.PP
.CS
typedef struct Tcl_RegExpInfo {
int \fInsubs\fR;
Tcl_RegExpIndices *\fImatches\fR;
long \fIextendStart\fR;
} Tcl_RegExpInfo;
.CE
.PP
The \fInsubs\fR field contains a count of the number of parenthesized
subexpressions within the regular expression. If the \fBTCL_REG_NOSUB\fR
was used, then this value will be zero. The \fImatches\fR field
points to an array of \fInsubs\fR values that indicate the bounds of each
subexpression matched. The first element in the array refers to the
range matched by the entire regular expression, and subsequent elements
refer to the parenthesized subexpressions in the order that they
appear in the pattern. Each element is a structure that is defined as
follows:
.PP
.CS
typedef struct Tcl_RegExpIndices {
long \fIstart\fR;
long \fIend\fR;
} Tcl_RegExpIndices;
.CE
.PP
The \fIstart\fR and \fIend\fR values are Unicode character indices
relative to the offset location within \fIobjPtr\fR where matching began.
The \fIstart\fR index identifies the first character of the matched
subexpression. The \fIend\fR index identifies the first character
after the matched subexpression. If the subexpression matched the
empty string, then \fIstart\fR and \fIend\fR will be equal. If the
subexpression did not participate in the match, then \fIstart\fR and
\fIend\fR will be set to -1.
.PP
The \fIextendStart\fR field in \fBTcl_RegExpInfo\fR is only set if the
\fBTCL_REG_CANMATCH\fR flag was used. It indicates the first
character in the string where a match could occur. If a match was
found, this will be the same as the beginning of the current match.
If no match was found, then it indicates the earliest point at which a
match might occur if additional text is appended to the string. If it
is no match is possible even with further text, this field will be set
to -1.
.VE 8.1
.SH "SEE ALSO"
re_syntax(n)
.SH KEYWORDS
match, pattern, regular expression, string, subexpression, Tcl_RegExpIndices, Tcl_RegExpInfo
tcl8.4.20/doc/license.terms 0000644 0036047 0045461 00000004321 11737050674 014162 0 ustar dgp 771div This software is copyrighted by the Regents of the University of
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
Corporation and other parties. The following terms apply to all files
associated with the software unless explicitly disclaimed in
individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that this
notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
and need not follow the licensing terms described here, provided that
the new terms are clearly indicated on the first page of each file where
they apply.
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.
tcl8.4.20/doc/GetHostName.3 0000644 0036047 0045461 00000001205 11737050674 013724 0 ustar dgp 771div '\"
'\" Copyright (c) 1998-2000 by Scriptics Corporation.
'\" All rights reserved.
'\"
.so man.macros
.TH Tcl_GetHostName 3 8.3 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetHostName \- get the name of the local host
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
CONST char *
\fBTcl_GetHostName\fR()
.BE
.SH DESCRIPTION
.PP
\fBTcl_GetHostName\fR is a utility procedure used by some of the
Tcl commands. It returns a pointer to a string containing the name
for the current machine, or an empty string if the name cannot be
determined. The string is statically allocated, and the caller must
not modify of free it.
.PP
.SH KEYWORDS
hostname
tcl8.4.20/doc/file.n 0000644 0036047 0045461 00000045272 12052456743 012572 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH file n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
file \- Manipulate file names and attributes
.SH SYNOPSIS
\fBfile \fIoption\fR \fIname\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command provides several operations on a file's name or attributes.
\fIName\fR is the name of a file; if it starts with a tilde, then tilde
substitution is done before executing the command (see the manual entry for
\fBfilename\fR for details). \fIOption\fR indicates what to do with the
file name. Any unique abbreviation for \fIoption\fR is acceptable. The
valid options are:
.TP
\fBfile atime \fIname\fR ?\fBtime\fR?
.
Returns a decimal string giving the time at which file \fIname\fR was last
accessed. If \fItime\fR is specified, it is an access time to set
for the file. The time is measured in the standard POSIX fashion as
seconds from a fixed starting time (often January 1, 1970). If the file
doesn't exist or its access time cannot be queried or set then an error is
generated. On Windows, FAT file systems do not support access time.
.TP
\fBfile attributes \fIname\fR
.TP
\fBfile attributes \fIname\fR ?\fBoption\fR?
.TP
\fBfile attributes \fIname\fR ?\fBoption value option value...\fR?
.RS
This subcommand returns or sets platform specific values associated
with a file. The first form returns a list of the platform specific
flags and their values. The second form returns the value for the
specific option. The third form sets one or more of the values. The
values are as follows:
.PP
On Unix, \fB-group\fR gets or sets the group name for the file. A group id
can be given to the command, but it returns a group name. \fB-owner\fR gets
or sets the user name of the owner of the file. The command returns the
owner name, but the numerical id can be passed when setting the
owner. \fB-permissions\fR sets or retrieves the octal code that chmod(1)
uses. This command does also has limited support for setting using the
symbolic attributes for chmod(1), of the form [ugo]?[[+\-=][rwxst],[...]],
where multiple symbolic attributes can be separated by commas (example:
\fBu+s,go\-rw\fR add sticky bit for user, remove read and write
permissions for group and other). A simplified \fBls\fR style string,
of the form rwxrwxrwx (must be 9 characters), is also supported
(example: \fBrwxr\-xr\-t\fR is equivalent to 01755).
.PP
On Windows, \fB-archive\fR gives the value or sets or clears the
archive attribute of the file. \fB-hidden\fR gives the value or sets
or clears the hidden attribute of the file. \fB-longname\fR will
expand each path element to its long version. This attribute cannot be
set. \fB-readonly\fR gives the value or sets or clears the readonly
attribute of the file. \fB-shortname\fR gives a string where every
path element is replaced with its short (8.3) version of the
name. This attribute cannot be set. \fB-system\fR gives or sets or
clears the value of the system attribute of the file.
.RE
.VS
.TP
\fBfile channels ?\fIpattern\fR?
.
If \fIpattern\fR isn't specified, returns a list of names of all
registered open channels in this interpreter. If \fIpattern\fR is
specified, only those names matching \fIpattern\fR are returned. Matching
is determined using the same rules as for \fBstring match\fR.
.VE
.TP
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR
.TP
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR
.RS
The first form makes a copy of the file or directory \fIsource\fR under
the pathname \fItarget\fR. If \fItarget\fR is an existing directory,
then the second form is used. The second form makes a copy inside
\fItargetDir\fR of each \fIsource\fR file listed. If a directory is
specified as a \fIsource\fR, then the contents of the directory will be
recursively copied into \fItargetDir\fR. Existing files will not be
overwritten unless the \fB\-force\fR option is specified. When copying
within a single filesystem, \fIfile copy\fR will copy soft links (i.e.
the links themselves are copied, not the things they point to). Trying
to overwrite a non-empty directory, overwrite a directory with a file,
or overwrite a file with a directory will all result in errors even if
\fI\-force\fR was specified. Arguments are processed in the order
specified, halting at the first error, if any. A \fB\-\|\-\fR marks
the end of switches; the argument following the \fB\-\|\-\fR will be
treated as a \fIsource\fR even if it starts with a \fB\-\fR.
.RE
.TP
\fBfile delete \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIpathname\fR ?\fIpathname\fR ... ?
.
Removes the file or directory specified by each \fIpathname\fR
argument. Non-empty directories will be removed only if the
\fB\-force\fR option is specified. When operating on symbolic links,
the links themselves will be deleted, not the objects they point to.
Trying to delete a non-existent file is not considered an error.
Trying to delete a read-only file will cause the file to be deleted,
even if the \fB\-force\fR flags is not specified. If the \fB\-force\fR
option is specified on a directory, Tcl will attempt both to change
permissions and move the current directory 'pwd' out of the given path
if that is necessary to allow the deletion to proceed. Arguments are
processed in the order specified, halting at the first error, if any.
A \fB\-\|\-\fR marks the end of switches; the argument following the
\fB\-\|\-\fR will be treated as a \fIpathname\fR even if it starts with
a \fB\-\fR.
.TP
\fBfile dirname \fIname\fR
Returns a name comprised of all of the path components in \fIname\fR
excluding the last element. If \fIname\fR is a relative file name and
only contains one path element, then returns ``\fB.\fR''.
If \fIname\fR refers to a root directory, then the
root directory is returned. For example,
.RS
.CS
\fBfile dirname c:/\fR
.CE
returns \fBc:/\fR.
.PP
Note that tilde substitution will only be
performed if it is necessary to complete the command. For example,
.CS
\fBfile dirname ~/src/foo.c\fR
.CE
returns \fB~/src\fR, whereas
.CS
\fBfile dirname ~\fR
.CE
returns \fB/home\fR (or something similar).
.RE
.TP
\fBfile executable \fIname\fR
.
Returns \fB1\fR if file \fIname\fR is executable by the current user,
\fB0\fR otherwise.
.TP
\fBfile exists \fIname\fR
.
Returns \fB1\fR if file \fIname\fR exists and the current user has
search privileges for the directories leading to it, \fB0\fR otherwise.
.TP
\fBfile extension \fIname\fR
.
Returns all of the characters in \fIname\fR after and including the last
dot in the last element of \fIname\fR. If there is no dot in the last
element of \fIname\fR then returns the empty string.
.TP
\fBfile isdirectory \fIname\fR
.
Returns \fB1\fR if file \fIname\fR is a directory, \fB0\fR otherwise.
.TP
\fBfile isfile \fIname\fR
.
Returns \fB1\fR if file \fIname\fR is a regular file, \fB0\fR otherwise.
.TP
\fBfile join \fIname\fR ?\fIname ...\fR?
.
Takes one or more file names and combines them, using the correct path
separator for the current platform. If a particular \fIname\fR is
relative, then it will be joined to the previous file name argument.
Otherwise, any earlier arguments will be discarded, and joining will
proceed from the current argument. For example,
.RS
.CS
\fBfile join a b /foo bar\fR
.CE
returns \fB/foo/bar\fR.
.PP
Note that any of the names can contain separators, and that the result
is always canonical for the current platform: \fB/\fR for Unix and
Windows.
.RE
.TP
\fBfile link ?\fI-linktype\fR? \fIlinkName\fR ?\fItarget\fR?
.
If only one argument is given, that argument is assumed to be
\fIlinkName\fR, and this command returns the value of the link given by
\fIlinkName\fR (i.e. the name of the file it points to). If
\fIlinkName\fR isn't a link or its value cannot be read (as, for example,
seems to be the case with hard links, which look just like ordinary
files), then an error is returned.
.
If 2 arguments are given, then these are assumed to be \fIlinkName\fR
and \fItarget\fR. If \fIlinkName\fR already exists, or if \fItarget\fR
doesn't exist, an error will be returned. Otherwise, Tcl creates a new
link called \fIlinkName\fR which points to the existing filesystem object
at \fItarget\fR, where the type of the link is platform-specific (on Unix
a symbolic link will be the default). This is useful for the case where
the user wishes to create a link in a cross-platform way, and doesn't
care what type of link is created.
.
If the user wishes to make a link of a specific type only, (and signal an
error if for some reason that is not possible), then the optional
\fI-linktype\fR argument should be given. Accepted values for
\fI-linktype\fR are "-symbolic" and "-hard".
.
When creating links on filesystems that either do not support any links,
or do not support the specific type requested, an error message will be
returned. In particular Windows 95, 98 and ME do not support any links
at present, but most Unix platforms support both symbolic and hard links
(the latter for files only), MacOS supports symbolic links and Windows
NT/2000/XP (on NTFS drives) support symbolic directory links and hard
file links.
.TP
\fBfile lstat \fIname varName\fR
.
Same as \fBstat\fR option (see below) except uses the \fIlstat\fR
kernel call instead of \fIstat\fR. This means that if \fIname\fR
refers to a symbolic link the information returned in \fIvarName\fR
is for the link rather than the file it refers to. On systems that
don't support symbolic links this option behaves exactly the same
as the \fBstat\fR option.
.TP
\fBfile mkdir \fIdir\fR ?\fIdir\fR ...?
.
Creates each directory specified. For each pathname \fIdir\fR specified,
this command will create all non-existing parent directories as
well as \fIdir\fR itself. If an existing directory is specified, then
no action is taken and no error is returned. Trying to overwrite an existing
file with a directory will result in an error. Arguments are processed in
the order specified, halting at the first error, if any.
.TP
\fBfile mtime \fIname\fR ?\fItime\fR?
.
Returns a decimal string giving the time at which file \fIname\fR was last
modified. If \fItime\fR is specified, it is a modification time to set for
the file (equivalent to Unix \fBtouch\fR). The time is measured in the
standard POSIX fashion as seconds from a fixed starting time (often January
1, 1970). If the file doesn't exist or its modified time cannot be queried
or set then an error is generated.
.TP
\fBfile nativename \fIname\fR
.
Returns the platform-specific name of the file. This is useful if the
filename is needed to pass to a platform-specific call, such as exec
under Windows.
.TP
\fBfile normalize \fIname\fR
.
.RS
Returns a unique normalized path representation for the file-system
object (file, directory, link, etc), whose string value can be used as a
unique identifier for it. A normalized path is an absolute path which has
all '../', './' removed. Also it is one which is in the ``standard''
format for the native platform. On MacOS, Unix, this means the segments
leading up to the path must be free of symbolic links/aliases (but the
very last path component may be a symbolic link), and on Windows it also
means we want the long form with that form's case-dependence (which
gives us a unique, case-dependent path). The one exception concerning the
last link in the path is necessary, because Tcl or the user may wish to
operate on the actual symbolic link itself (for example 'file delete', 'file
rename', 'file copy' are defined to operate on symbolic links, not on the
things that they point to).
.RE
.TP
\fBfile owned \fIname\fR
.
Returns \fB1\fR if file \fIname\fR is owned by the current user, \fB0\fR
otherwise.
.TP
\fBfile pathtype \fIname\fR
.
Returns one of \fBabsolute\fR, \fBrelative\fR, \fBvolumerelative\fR. If
\fIname\fR refers to a specific file on a specific volume, the path type
will be \fBabsolute\fR. If \fIname\fR refers to a file relative to the
current working directory, then the path type will be \fBrelative\fR. If
\fIname\fR refers to a file relative to the current working directory on
a specified volume, or to a specific file on the current working volume, then
the path type is \fBvolumerelative\fR.
.TP
\fBfile readable \fIname\fR
.
Returns \fB1\fR if file \fIname\fR is readable by the current user,
\fB0\fR otherwise.
.TP
\fBfile readlink \fIname\fR
.
Returns the value of the symbolic link given by \fIname\fR (i.e. the name
of the file it points to). If \fIname\fR isn't a symbolic link or its
value cannot be read, then an error is returned. On systems that don't
support symbolic links this option is undefined.
.TP
\fBfile rename \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR
.TP
\fBfile rename \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR
.RS
The first form takes the file or directory specified by pathname
\fIsource\fR and renames it to \fItarget\fR, moving the file if the
pathname \fItarget\fR specifies a name in a different directory. If
\fItarget\fR is an existing directory, then the second form is used.
The second form moves each \fIsource\fR file or directory into the
directory \fItargetDir\fR. Existing files will not be overwritten
unless the \fB\-force\fR option is specified. When operating inside a
single filesystem, Tcl will rename symbolic links rather than the
things that they point to. Trying to overwrite a non-empty directory,
overwrite a directory with a file, or a file with a directory will all
result in errors. Arguments are processed in the order specified,
halting at the first error, if any. A \fB\-\|\-\fR marks the end of
switches; the argument following the \fB\-\|\-\fR will be treated as a
\fIsource\fR even if it starts with a \fB\-\fR.
.RE
.TP
\fBfile rootname \fIname\fR
.
Returns all of the characters in \fIname\fR up to but not including the
last ``.'' character in the last component of name. If the last
component of \fIname\fR doesn't contain a dot, then returns \fIname\fR.
.TP
\fBfile separator\fR ?\fIname\fR?
.
If no argument is given, returns the character which is used to separate
path segments for native files on this platform. If a path is given,
the filesystem responsible for that path is asked to return its
separator character. If no file system accepts \fIname\fR, an error
is generated.
.TP
\fBfile size \fIname\fR
.
Returns a decimal string giving the size of file \fIname\fR in bytes. If
the file doesn't exist or its size cannot be queried then an error is
generated.
.TP
\fBfile split \fIname\fR
.
Returns a list whose elements are the path components in \fIname\fR. The
first element of the list will have the same path type as \fIname\fR.
All other elements will be relative. Path separators will be discarded
unless they are needed ensure that an element is unambiguously relative.
For example, under Unix
.RS
.CS
file split /foo/~bar/baz
.CE
returns \fB/\0\0foo\0\0./~bar\0\0baz\fR to ensure that later commands
that use the third component do not attempt to perform tilde
substitution.
.RE
.TP
\fBfile stat \fIname varName\fR
.
Invokes the \fBstat\fR kernel call on \fIname\fR, and uses the variable
given by \fIvarName\fR to hold information returned from the kernel call.
\fIVarName\fR is treated as an array variable, and the following elements
of that variable are set: \fBatime\fR, \fBctime\fR, \fBdev\fR, \fBgid\fR,
\fBino\fR, \fBmode\fR, \fBmtime\fR, \fBnlink\fR, \fBsize\fR, \fBtype\fR,
\fBuid\fR. Each element except \fBtype\fR is a decimal string with the
value of the corresponding field from the \fBstat\fR return structure;
see the manual entry for \fBstat\fR for details on the meanings of the
values. The \fBtype\fR element gives the type of the file in the same
form returned by the command \fBfile type\fR. This command returns an
empty string.
.TP
\fBfile system \fIname\fR
.
Returns a list of two elements, the first of which is the name of the
filesystem to use for the file, and the second an arbitrary string
representing the filesystem-specific nature or type of the location
within that filesystem. If a filesystem only supports one type of file,
the second element may be null. For example the native files have a
first element 'native', and a second element which is a platform-specific
type name for the file's system (e.g. 'NTFS', 'FAT', etc), or possibly
the empty string if no further information is available or if this
is not implemented. A generic virtual file system might return the
list 'vfs ftp' to represent a file on a remote ftp site mounted as a
virtual filesystem through an extension called 'vfs'. If the file does
not belong to any filesystem, an error is generated.
.TP
\fBfile tail \fIname\fR
.
Returns all of the characters in \fIname\fR after the last directory
separator. If \fIname\fR contains no separators then returns
\fIname\fR.
.TP
\fBfile type \fIname\fR
.
Returns a string giving the type of file \fIname\fR, which will be one of
\fBfile\fR, \fBdirectory\fR, \fBcharacterSpecial\fR, \fBblockSpecial\fR,
\fBfifo\fR, \fBlink\fR, or \fBsocket\fR.
.TP
\fBfile volumes\fR
.
Returns the absolute paths to the volumes mounted on the system, as a
proper Tcl list. On UNIX, the
command will always return "/", since all filesystems are locally mounted.
On Windows, it will return a list of the available local drives
(e.g. {a:/ c:/}).
.TP
\fBfile writable \fIname\fR
.
Returns \fB1\fR if file \fIname\fR is writable by the current user,
\fB0\fR otherwise.
.SH "PORTABILITY ISSUES"
.TP
\fBUnix\fR\0\0\0\0\0\0\0
.
These commands always operate using the real user and group identifiers,
not the effective ones.
.SH EXAMPLES
This procedure shows how to search for C files in a given directory
that have a correspondingly-named object file in the current
directory:
.CS
proc findMatchingCFiles {dir} {
set files {}
switch $::tcl_platform(platform) {
windows {
set ext .obj
}
unix {
set ext .o
}
}
foreach file [glob -nocomplain -directory $dir *.c] {
set objectFile [\fBfile tail\fR [\fBfile rootname\fR $file]]$ext
if {[\fBfile exists\fR $objectFile]} {
lappend files $file
}
}
return $files
}
.CE
.PP
Rename a file and leave a symbolic link pointing from the old location
to the new place:
.CS
set oldName foobar.txt
set newName foo/bar.txt
# Make sure that where we're going to move to exists...
if {![\fBfile isdirectory\fR [\fBfile dirname\fR $newName]]} {
\fBfile mkdir\fR [\fBfile dirname\fR $newName]
}
\fBfile rename\fR $oldName $newName
\fBfile link\fR -symbolic $oldName $newName
.CE
.SH "SEE ALSO"
filename(n), open(n), close(n), eof(n), gets(n), tell(n), seek(n),
fblocked(n), flush(n)
.SH KEYWORDS
attributes, copy files, delete files, directory, file, move files, name, rename files, stat
tcl8.4.20/doc/AllowExc.3 0000644 0036047 0045461 00000003053 11737050674 013267 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_AllowExceptions 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_AllowExceptions \- allow all exceptions in next script evaluation
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_AllowExceptions\fR(\fIinterp\fR)
.SH ARGUMENTS
.AS Tcl_Interp *doublePtr
.AP Tcl_Interp *interp in
Interpreter in which script will be evaluated.
.BE
.SH DESCRIPTION
.PP
If a script is evaluated at top-level (i.e. no other scripts are
pending evaluation when the script is invoked), and if the script
terminates with a completion code other than TCL_OK, TCL_ERROR
or TCL_RETURN, then Tcl normally converts this into a TCL_ERROR
return with an appropriate message. The particular script
evaluation procedures of Tcl that act in the manner are
\fBTcl_EvalObjEx\fR, \fBTcl_EvalObjv\fR, \fBTcl_Eval\fR, \fBTcl_EvalEx\fR,
\fBTcl_GlobalEval\fR, \fBTcl_GlobalEvalObj\fR, \fBTcl_VarEval\fR and
\fBTcl_VarEvalVA\fR.
.PP
However, if \fBTcl_AllowExceptions\fR is invoked immediately before
calling one of those a procedures, then arbitrary completion
codes are permitted from the script, and they are returned without
modification.
This is useful in cases where the caller can deal with exceptions
such as TCL_BREAK or TCL_CONTINUE in a meaningful way.
.SH KEYWORDS
continue, break, exception, interpreter
tcl8.4.20/doc/Panic.3 0000644 0036047 0045461 00000007472 11737050674 012614 0 ustar dgp 771div '\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc, panic, panicVA \- report fatal error and abort
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
void
\fBTcl_Panic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR)
.sp
void
\fBTcl_PanicVA\fR(\fIformat\fR, \fIargList\fR)
.sp
void
\fBTcl_SetPanicProc\fR(\fIpanicProc\fR)
.sp
void
\fBpanic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR)
.sp
void
\fBpanicVA\fR(\fIformat\fR, \fIargList\fR)
.sp
.SH ARGUMENTS
.AS Tcl_PanicProc *panicProc
.AP "CONST char*" format in
A printf-style format string.
.AP "" arg in
Arguments matching the format string.
.AP va_list argList in
An argument list of arguments matching the format string.
Must have been initialized using \fBTCL_VARARGS_START\fR,
and cleared using \fBva_end\fR.
.AP Tcl_PanicProc *panicProc in
Procedure to report fatal error message and abort.
.BE
.SH DESCRIPTION
.PP
When the Tcl library detects that its internal data structures are in an
inconsistent state, or that its C procedures have been called in a
manner inconsistent with their documentation, it calls \fBTcl_Panic\fR
to display a message describing the error and abort the process. The
\fIformat\fR argument is a format string describing how to format the
remaining arguments \fIarg\fR into an error message, according to the
same formatting rules used by the \fBprintf\fR family of functions. The
same formatting rules are also used by the builtin Tcl command
\fBformat\fR.
.PP
In a freshly loaded Tcl library, \fBTcl_Panic\fR prints the formatted
error message to the standard error file of the process, and then
calls \fBabort\fR to terminate the process. \fBTcl_Panic\fR does not
return.
.PP
\fBTcl_SetPanicProc\fR may be used to modify the behavior of
\fBTcl_Panic\fR. The \fIpanicProc\fR argument should match the
type \fBTcl_PanicProc\fR:
.PP
.CS
typedef void Tcl_PanicProc(
CONST char *\fBformat\fR,
\fBarg\fR, \fBarg\fR,...);
.CE
.PP
After \fBTcl_SetPanicProc\fR returns, any future calls to
\fBTcl_Panic\fR will call \fIpanicProc\fR, passing along the
\fIformat\fR and \fIarg\fR arguments. To maintain consistency with the
callers of \fBTcl_Panic\fR, \fIpanicProc\fR must not return; it must
call \fBabort\fR. \fIpanicProc\fR should avoid making calls into the
Tcl library, or into other libraries that may call the Tcl library,
since the original call to \fBTcl_Panic\fR indicates the Tcl library is
not in a state of reliable operation.
.PP
The typical use of \fBTcl_SetPanicProc\fR arranges for the error message
to be displayed or reported in a manner more suitable for the
application or the platform. As an example, the Windows implementation
of \fBwish\fR calls \fBTcl_SetPanicProc\fR to force all panic messages
to be displayed in a system dialog box, rather than to be printed to the
standard error file (usually not visible under Windows).
.PP
Although the primary callers of \fBTcl_Panic\fR are the procedures of
the Tcl library, \fBTcl_Panic\fR is a public function and may be called
by any extension or application that wishes to abort the process and
have a panic message displayed the same way that panic messages from Tcl
will be displayed.
.PP
\fBTcl_PanicVA\fR is the same as \fBTcl_Panic\fR except that instead of
taking a variable number of arguments it takes an argument list. The
procedures \fBpanic\fR and \fBpanicVA\fR are synonyms (implemented as
macros) for \fBTcl_Panic\fR and \fBTcl_PanicVA\fR, respectively. They
exist to support old code; new code should use direct calls to
\fBTcl_Panic\fR or \fBTcl_PanicVA\fR.
.SH "SEE ALSO"
abort(3), printf(3), exec(n), format(n)
.SH KEYWORDS
abort, fatal, error
tcl8.4.20/doc/Sleep.3 0000644 0036047 0045461 00000002041 11737050674 012615 0 ustar dgp 771div '\"
'\" Copyright (c) 1990 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_Sleep 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Sleep \- delay execution for a given number of milliseconds
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_Sleep\fR(\fIms\fR)
.SH ARGUMENTS
.AP int ms in
Number of milliseconds to sleep.
.BE
.SH DESCRIPTION
.PP
This procedure delays the calling process by the number of
milliseconds given by the \fIms\fR parameter and returns
after that time has elapsed. It is typically used for things
like flashing a button, where the delay is short and the
application needn't do anything while it waits. For longer
delays where the application needs to respond to other events
during the delay, the procedure \fBTcl_CreateTimerHandler\fR
should be used instead of \fBTcl_Sleep\fR.
.SH KEYWORDS
sleep, time, wait
tcl8.4.20/doc/continue.n 0000644 0036047 0045461 00000002426 11737050674 013473 0 ustar dgp 771div '\"
'\" Copyright (c) 1993-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH continue n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
continue \- Skip to the next iteration of a loop
.SH SYNOPSIS
\fBcontinue\fR
.BE
.SH DESCRIPTION
.PP
This command is typically invoked inside the body of a looping command
such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR.
It returns a \fBTCL_CONTINUE\fR code, which causes a continue exception
to occur.
The exception causes the current script to be aborted
out to the innermost containing loop command, which then
continues with the next iteration of the loop.
Catch exceptions are also handled in a few other situations, such
as the \fBcatch\fR command and the outermost scripts of procedure
bodies.
.SH EXAMPLE
Print a line for each of the integers from 0 to 10 \fIexcept\fR 5:
.CS
for {set x 0} {$x<10} {incr x} {
if {$x == 5} {
\fBcontinue\fR
}
puts "x is $x"
}
.CE
.SH "SEE ALSO"
break(n), for(n), foreach(n), return(n), while(n)
.SH KEYWORDS
continue, iteration, loop
tcl8.4.20/doc/PrintDbl.3 0000644 0036047 0045461 00000002747 11737050674 013300 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-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.
'\"
.so man.macros
.TH Tcl_PrintDouble 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_PrintDouble \- Convert floating value to string
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp
.AP Tcl_Interp *interp in
.VS
Before Tcl 8.0, the \fBtcl_precision\fR variable in this interpreter
controlled the conversion. As of Tcl 8.0, this argument is ignored and
the conversion is controlled by the \fBtcl_precision\fR variable
that is now shared by all interpreters.
.VE
.AP double value in
Floating-point value to be converted.
.AP char *dst out
Where to store string representing \fIvalue\fR. Must have at
least TCL_DOUBLE_SPACE characters of storage.
.BE
.SH DESCRIPTION
.PP
\fBTcl_PrintDouble\fR generates a string that represents the value
of \fIvalue\fR and stores it in memory at the location given by
\fIdst\fR. It uses \fB%g\fR format to generate the string, with one
special twist: the string is guaranteed to contain either
a ``.'' or an ``e'' so that it doesn't look like an integer. Where
\fB%g\fR would generate an integer with no decimal point, \fBTcl_PrintDouble\fR
adds ``.0''.
.SH KEYWORDS
conversion, double-precision, floating-point, string
tcl8.4.20/doc/AssocData.3 0000644 0036047 0045461 00000006706 11737050674 013423 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH Tcl_SetAssocData 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetAssocData, Tcl_SetAssocData, Tcl_DeleteAssocData \- manage
associations of string keys and user specified data with Tcl
interpreters.
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
ClientData
\fBTcl_GetAssocData\fR(\fIinterp, key, delProcPtr\fR)
.sp
\fBTcl_SetAssocData\fR(\fIinterp, key, delProc, clientData\fR)
.sp
\fBTcl_DeleteAssocData\fR(\fIinterp, key\fR)
.SH ARGUMENTS
.AS Tcl_InterpDeleteProc *delProcPtr
.AP Tcl_Interp *interp in
Interpreter in which to execute the specified command.
.VS 8.4
.AP "CONST char" *key in
.VE
Key for association with which to store data or from which to delete or
retrieve data. Typically the module prefix for a package.
.AP Tcl_InterpDeleteProc *delProc in
Procedure to call when \fIinterp\fR is deleted.
.AP Tcl_InterpDeleteProc **delProcPtr in
Pointer to location in which to store address of current deletion procedure
for association. Ignored if NULL.
.AP ClientData clientData in
Arbitrary one-word value associated with the given key in this
interpreter. This data is owned by the caller.
.BE
.SH DESCRIPTION
.PP
These procedures allow extensions to associate their own data with
a Tcl interpreter.
An association consists of a string key, typically the name of
the extension, and a one-word value, which is typically a pointer
to a data structure holding data specific to the extension.
Tcl makes no interpretation of either the key or the value for
an association.
.PP
Storage management is facilitated by storing with each association a
procedure to call when the interpreter is deleted. This
procedure can dispose of the storage occupied by the client's data in any
way it sees fit.
.PP
\fBTcl_SetAssocData\fR creates an association between a string
key and a user specified datum in the given interpreter.
If there is already an association with the given \fIkey\fR,
\fBTcl_SetAssocData\fR overwrites it with the new information.
It is up to callers to organize their use of names to avoid conflicts,
for example, by using package names as the keys.
If the \fIdeleteProc\fR argument is non-NULL it specifies the address of a
procedure to invoke if the interpreter is deleted before the association
is deleted. \fIDeleteProc\fR should have arguments and result that match
the type \fBTcl_InterpDeleteProc\fR:
.CS
typedef void Tcl_InterpDeleteProc(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
When \fIdeleteProc\fR is invoked the \fIclientData\fR and \fIinterp\fR
arguments will be the same as the corresponding arguments passed to
\fBTcl_SetAssocData\fR.
The deletion procedure will \fInot\fR be invoked if the association
is deleted before the interpreter is deleted.
.PP
\fBTcl_GetAssocData\fR returns the datum stored in the association with the
specified key in the given interpreter, and if the \fIdelProcPtr\fR field
is non-\fBNULL\fR, the address indicated by it gets the address of the
delete procedure stored with this association. If no association with the
specified key exists in the given interpreter \fBTcl_GetAssocData\fR
returns \fBNULL\fR.
.PP
\fBTcl_DeleteAssocData\fR deletes an association with a specified key in
the given interpreter. Then it calls the deletion procedure.
.SH KEYWORDS
association, data, deletion procedure, interpreter, key
tcl8.4.20/doc/BackgdErr.3 0000644 0036047 0045461 00000004314 11737050674 013376 0 ustar dgp 771div '\"
'\" Copyright (c) 1992-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_BackgroundError 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_BackgroundError \- report Tcl error that occurred in background processing
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_BackgroundError\fR(\fIinterp\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp
.AP Tcl_Interp *interp in
Interpreter in which the error occurred.
.BE
.SH DESCRIPTION
.PP
This procedure is typically invoked when a Tcl error occurs during
``background processing'' such as executing an event handler.
When such an error occurs, the error condition is reported to Tcl
or to a widget or some other C code, and there is not usually any
obvious way for that code to report the error to the user.
In these cases the code calls \fBTcl_BackgroundError\fR with an
\fIinterp\fR argument identifying the interpreter in which the
error occurred. At the time \fBTcl_BackgroundError\fR is invoked,
the interpreter's result is expected to contain an error message.
\fBTcl_BackgroundError\fR will invoke the \fBbgerror\fR
Tcl command to report the error in an application-specific fashion.
If no \fBbgerror\fR command exists, or if it returns with an error condition,
then \fBTcl_BackgroundError\fR reports the error itself by printing
a message on the standard error file.
.PP
\fBTcl_BackgroundError\fR does not invoke \fBbgerror\fR immediately
because this could potentially interfere with scripts that are in process
at the time the error occurred.
Instead, it invokes \fBbgerror\fR later as an idle callback.
\fBTcl_BackgroundError\fR saves the values of the \fBerrorInfo\fR and
\fBerrorCode\fR variables and restores these values just before
invoking \fBbgerror\fR.
.PP
It is possible for many background errors to accumulate before
\fBbgerror\fR is invoked. When this happens, each of the errors
is processed in order. However, if \fBbgerror\fR returns a
break exception, then all remaining error reports for the
interpreter are skipped.
.SH KEYWORDS
background, bgerror, error
tcl8.4.20/doc/catch.n 0000644 0036047 0045461 00000006201 11737050674 012724 0 ustar dgp 771div '\"
'\" Copyright (c) 1993-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH catch n "8.0" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
catch \- Evaluate script and trap exceptional returns
.SH SYNOPSIS
\fBcatch\fI script \fR?\fIvarName\fR?
.BE
.SH DESCRIPTION
.PP
The \fBcatch\fR command may be used to prevent errors from aborting command
interpretation. The \fBcatch\fR command calls the Tcl interpreter recursively to
execute \fIscript\fR, and always returns without raising an error,
regardless of any errors that might occur while executing \fIscript\fR.
.PP
If \fIscript\fR raises an error, \fBcatch\fR will return a non-zero integer
value corresponding to the exceptional return code returned by evaluation
of \fIscript\fR. Tcl defines the normal return code from script
evaluation to be zero (0), or \fBTCL_OK\fR. Tcl also defines four exceptional
return codes: 1 (\fBTCL_ERROR\fR), 2 (\fBTCL_RETURN\fR), 3 (\fBTCL_BREAK\fR),
and 4 (\fBTCL_CONTINUE\fR). Errors during evaluation of a script are indicated
by a return code of \fBTCL_ERROR\fR. The other exceptional return codes are
returned by the \fBreturn\fR, \fBbreak\fR, and \fBcontinue\fR commands
and in other special situations as documented. Tcl packages can define
new commands that return other integer values as return codes as well,
and scripts that make use of the \fBreturn -code\fR command can also
have return codes other than the five defined by Tcl.
.PP
If the \fIvarName\fR argument is given, then the variable it names is
set to the result of the script evaluation. When the return code from
the script is 1 (\fBTCL_ERROR\fR), the value stored in \fIvarName\fR is an error
message. When the return code from the script is 0 (\fBTCL_OK\fR), the value
stored in \fIresultVarName\fR is the value returned from \fIscript\fR.
.PP
If \fIscript\fR does not raise an error, \fBcatch\fR will return 0
(\fBTCL_OK\fR) and set the variable to the value returned from \fIscript\fR.
.PP
Note that \fBcatch\fR catches all exceptions, including those
generated by \fBbreak\fR and \fBcontinue\fR as well as errors. The
only errors that are not caught are syntax errors found when the
script is compiled. This is because the catch command only catches
errors during runtime. When the catch statement is compiled, the
script is compiled as well and any syntax errors will generate a Tcl
error.
.SH EXAMPLES
The \fBcatch\fR command may be used in an \fBif\fR to branch based on
the success of a script.
.CS
if { [\fBcatch\fR {open $someFile w} fid] } {
puts stderr "Could not open $someFile for writing\\n$fid"
exit 1
}
.CE
.PP
The \fBcatch\fR command will not catch compiled syntax errors. The
first time proc \fBfoo\fR is called, the body will be compiled and a
Tcl error will be generated.
.CS
proc foo {} {
\fBcatch\fR {expr {1 +- }}
}
.CE
.SH "SEE ALSO"
break(n), continue(n), error(n), return(n), tclvars(n)
.SH KEYWORDS
catch, error
tcl8.4.20/doc/Interp.3 0000644 0036047 0045461 00000012717 11737050674 013021 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_Interp 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Interp \- client-visible fields of interpreter structures
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
typedef struct {
char *\fIresult\fR;
Tcl_FreeProc *\fIfreeProc\fR;
int \fIerrorLine\fR;
} Tcl_Interp;
typedef void Tcl_FreeProc(char *\fIblockPtr\fR);
.BE
.SH DESCRIPTION
.PP
The \fBTcl_CreateInterp\fR procedure returns a pointer to a Tcl_Interp
structure. This pointer is then passed into other Tcl procedures
to process commands in the interpreter and perform other operations
on the interpreter. Interpreter structures contain many many fields
that are used by Tcl, but only three that may be accessed by
clients: \fIresult\fR, \fIfreeProc\fR, and \fIerrorLine\fR.
.PP
The \fIresult\fR and \fIfreeProc\fR fields are used to return
results or error messages from commands.
This information is returned by command procedures back to \fBTcl_Eval\fR,
and by \fBTcl_Eval\fR back to its callers.
The \fIresult\fR field points to the string that represents the
result or error message, and the \fIfreeProc\fR field tells how
to dispose of the storage for the string when it isn't needed anymore.
The easiest way for command procedures to manipulate these
fields is to call procedures like \fBTcl_SetResult\fR
or \fBTcl_AppendResult\fR; they
will hide all the details of managing the fields.
The description below is for those procedures that manipulate the
fields directly.
.PP
Whenever a command procedure returns, it must ensure
that the \fIresult\fR field of its interpreter points to the string
being returned by the command.
The \fIresult\fR field must always point to a valid string.
If a command wishes to return no result then \fIinterp->result\fR
should point to an empty string.
Normally, results are assumed to be statically allocated,
which means that the contents will not change before the next time
\fBTcl_Eval\fR is called or some other command procedure is invoked.
.VS
In this case, the \fIfreeProc\fR field must be zero.
Alternatively, a command procedure may dynamically
allocate its return value (e.g. using \fBTcl_Alloc\fR)
and store a pointer to it in \fIinterp->result\fR.
In this case, the command procedure must also set \fIinterp->freeProc\fR
to the address of a procedure that can free the value, or \fBTCL_DYNAMIC\fR
if the storage was allocated directly by Tcl or by a call to
\fBTcl_Alloc\fR.
.VE
If \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR
to free the space pointed to by \fIinterp->result\fR before it
invokes the next command.
If a client procedure overwrites \fIinterp->result\fR when
\fIinterp->freeProc\fR is non-zero, then it is responsible for calling
\fIfreeProc\fR to free the old \fIinterp->result\fR (the \fBTcl_FreeResult\fR
macro should be used for this purpose).
.PP
\fIFreeProc\fR should have arguments and result that match the
\fBTcl_FreeProc\fR declaration above: it receives a single
argument which is a pointer to the result value to free.
.VS
In most applications \fBTCL_DYNAMIC\fR is the only non-zero value ever
used for \fIfreeProc\fR.
.VE
However, an application may store a different procedure address
in \fIfreeProc\fR in order to use an alternate memory allocator
or in order to do other cleanup when the result memory is freed.
.PP
As part of processing each command, \fBTcl_Eval\fR initializes
\fIinterp->result\fR
and \fIinterp->freeProc\fR just before calling the command procedure for
the command. The \fIfreeProc\fR field will be initialized to zero,
and \fIinterp->result\fR will point to an empty string. Commands that
do not return any value can simply leave the fields alone.
Furthermore, the empty string pointed to by \fIresult\fR is actually
part of an array of \fBTCL_RESULT_SIZE\fR characters (approximately 200).
If a command wishes to return a short string, it can simply copy
it to the area pointed to by \fIinterp->result\fR. Or, it can use
the sprintf procedure to generate a short result string at the location
pointed to by \fIinterp->result\fR.
.PP
It is a general convention in Tcl-based applications that the result
of an interpreter is normally in the initialized state described
in the previous paragraph.
Procedures that manipulate an interpreter's result (e.g. by
returning an error) will generally assume that the result
has been initialized when the procedure is called.
If such a procedure is to be called after the result has been
changed, then \fBTcl_ResetResult\fR should be called first to
reset the result to its initialized state. The direct use of
\fIinterp->result\fR is strongly deprecated (see \fBTcl_SetResult\fR).
.PP
The \fIerrorLine\fR
field is valid only after \fBTcl_Eval\fR returns
a \fBTCL_ERROR\fR return code. In this situation the \fIerrorLine\fR
field identifies the line number of the command being executed when
the error occurred. The line numbers are relative to the command
being executed: 1 means the first line of the command passed to
\fBTcl_Eval\fR, 2 means the second line, and so on.
The \fIerrorLine\fR field is typically used in conjunction with
\fBTcl_AddErrorInfo\fR to report information about where an error
occurred.
\fIErrorLine\fR should not normally be modified except by \fBTcl_Eval\fR.
.SH KEYWORDS
free, initialized, interpreter, malloc, result
tcl8.4.20/doc/tell.n 0000644 0036047 0045461 00000003107 11737050674 012604 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH tell n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
tell \- Return current access position for an open channel
.SH SYNOPSIS
\fBtell \fIchannelId\fR
.BE
.SH DESCRIPTION
.PP
.VS 8.1
Returns an integer string giving the current access position in
\fIchannelId\fR. This value returned is a byte offset that can be passed to
\fBseek\fR in order to set the channel to a particular position. Note
that this value is in terms of bytes, not characters like \fBread\fR.
.VE 8.1
The value returned is -1 for channels that do not support
seeking.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.VE
.SH EXAMPLE
Read a line from a file channel only if it starts with \fBfoobar\fR:
.CS
# Save the offset in case we need to undo the read...
set offset [\fBtell\fR $chan]
if {[read $chan 6] eq "foobar"} {
gets $chan line
} else {
set line {}
# Undo the read...
seek $chan $offset
}
.CE
.SH "SEE ALSO"
file(n), open(n), close(n), gets(n), seek(n), Tcl_StandardChannels(3)
.SH KEYWORDS
access position, channel, seeking
tcl8.4.20/doc/Init.3 0000644 0036047 0045461 00000001274 12052456743 012455 0 ustar dgp 771div '\"
'\" Copyright (c) 1998-2000 by Scriptics Corporation.
'\" All rights reserved.
'\"
.so man.macros
.TH Tcl_Init 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Init \- find and source initialization script
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_Init\fR(\fIinterp\fR)
.SH ARGUMENTS
.AP Tcl_Interp *interp in
Interpreter to initialize.
.BE
.SH DESCRIPTION
.PP
\fBTcl_Init\fR is a helper procedure that finds and \fBsource\fR's the
\fBinit.tcl\fR script, which should exist somewhere on the Tcl library
path.
.PP
\fBTcl_Init\fR is typically called from \fBTcl_AppInit\fR procedures.
.SH "SEE ALSO"
Tcl_AppInit, Tcl_Main
.SH KEYWORDS
application, initialization, interpreter
tcl8.4.20/doc/DumpActiveMemory.3 0000644 0036047 0045461 00000004277 11737050674 015014 0 ustar dgp 771div '\"
'\" Copyright (c) 1992-1999 Karl Lehenbauer and Mark Diekhans.
'\" Copyright (c) 2000 by Scriptics Corporation.
'\" All rights reserved.
'\"
.so man.macros
.TH "Tcl_DumpActiveMemory" 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_DumpActiveMemory, Tcl_InitMemory, Tcl_ValidateAllMemory \- Validated memory allocation interface.
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_DumpActiveMemory\fR(\fIfileName\fR)
.sp
void
\fBTcl_InitMemory\fR(\fIinterp\fR)
.sp
void
\fBTcl_ValidateAllMemory\fR(\fIfileName, line\fR)
.SH ARGUMENTS
.AP Tcl_Interp *interp in
Tcl interpreter in which to add commands.
.AP "CONST char" *fileName in
For \fBTcl_DumpActiveMemory\fR, name of the file to which memory
information will be written. For \fBTcl_ValidateAllMemory\fR, name of
the file from which the call is being made (normally \fB__FILE__\fR).
.AP int line in
Line number at which the call to \fBTcl_ValidateAllMemory\fR is made
(normally \fB__LINE__\fR).
.BE
.SH DESCRIPTION
These functions provide access to Tcl memory debugging information.
They are only functional when Tcl has been compiled with
\fBTCL_MEM_DEBUG\fR defined at compile-time. When \fBTCL_MEM_DEBUG\fR
is not defined, these functions are all no-ops.
.PP
\fBTcl_DumpActiveMemory\fR will output a list of all currently
allocated memory to the specified file. The information output for
each allocated block of memory is: starting and ending addresses
(excluding guard zone), size, source file where \fBckalloc\fR was
called to allocate the block and line number in that file. It is
especially useful to call \fBTcl_DumpActiveMemory\fR after the Tcl
interpreter has been deleted.
.PP
\fBTcl_InitMemory\fR adds the Tcl \fBmemory\fR command to the
interpreter given by \fIinterp\fR. \fBTcl_InitMemory\fR is called
by \fBTcl_Main\fR.
.PP
\fBTcl_ValidateAllMemory\fR forces a validation of the guard zones of
all currently allocated blocks of memory. Normally validation of a
block occurs when its freed, unless full validation is enabled, in
which case validation of all blocks occurs when \fBckalloc\fR and
\fBckfree\fR are called. This function forces the validation to occur
at any point.
.SH "SEE ALSO"
TCL_MEM_DEBUG, memory
.SH KEYWORDS
memory, debug
tcl8.4.20/doc/string.n 0000644 0036047 0045461 00000034717 12133546537 013164 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH string n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
string \- Manipulate strings
.SH SYNOPSIS
\fBstring \fIoption arg \fR?\fIarg ...?\fR
.BE
.SH DESCRIPTION
.PP
Performs one of several string operations, depending on \fIoption\fR.
The legal \fIoption\fRs (which may be abbreviated) are:
.TP
\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR
Perform a character-by-character comparison of strings \fIstring1\fR
and \fIstring2\fR. Returns \-1, 0, or 1, depending on whether
\fIstring1\fR is lexicographically less than, equal to, or greater
than \fIstring2\fR. If \fB\-length\fR is specified, then only the
first \fIlength\fR characters are used in the comparison. If
\fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is
specified, then the strings are compared in a case-insensitive manner.
.TP
\fBstring equal\fR ?\fB\-nocase\fR? ?\fB-length int\fR? \fIstring1 string2\fR
Perform a character-by-character comparison of strings \fIstring1\fR
and \fIstring2\fR. Returns 1 if \fIstring1\fR and \fIstring2\fR are
identical, or 0 when not. If \fB\-length\fR is specified, then only
the first \fIlength\fR characters are used in the comparison. If
\fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is
specified, then the strings are compared in a case-insensitive manner.
.TP
\fBstring first \fIneedleString haystackString\fR ?\fIstartIndex\fR?
Search \fIhaystackString\fR for a sequence of characters that exactly match
the characters in \fIneedleString\fR. If found, return the index of the
first character in the first such match within \fIhaystackString\fR. If not
found, return \-1. If \fIstartIndex\fR is specified (in any of the
forms accepted by the \fBindex\fR method), then the search is
constrained to start with the character in \fIhaystackString\fR specified by
the index. For example,
.RS
.CS
\fBstring first a 0a23456789abcdef 5\fR
.CE
will return \fB10\fR, but
.CS
\fBstring first a 0123456789abcdef 11\fR
.CE
will return \fB\-1\fR.
.RE
.TP
\fBstring index \fIstring charIndex\fR
Returns the \fIcharIndex\fR'th character of the \fIstring\fR argument.
A \fIcharIndex\fR of 0 corresponds to the first character of the
string. \fIcharIndex\fR may be specified as follows:
.RS
.IP \fIinteger\fR 10
The char specified at this integral index.
.IP \fBend\fR 10
The last char of the string.
.IP \fBend\-\fIinteger\fR 10
The last char of the string minus the specified integer offset
(e.g. \fBend\-1\fR would refer to the "c" in "abcd").
.PP
If \fIcharIndex\fR is less than 0 or greater than or equal to the
length of the string then this command returns an empty string.
.RE
.TP
\fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR
Returns 1 if \fIstring\fR is a valid member of the specified character
class, otherwise returns 0. If \fB\-strict\fR is specified, then an
empty string returns 0, otherwise an empty string will return 1 on
any class. If \fB\-failindex\fR is specified, then if the function
returns 0, the index in the string where the class was no longer valid
will be stored in the variable named \fIvarname\fR. The \fIvarname\fR
will not be set if \fBstring is\fR returns 1. The following character
classes are recognized (the class name can be abbreviated):
.RS
.IP \fBalnum\fR 12
Any Unicode alphabet or digit character.
.IP \fBalpha\fR 12
Any Unicode alphabet character.
.IP \fBascii\fR 12
Any character with a value less than \\u0080 (those that are in the
7\-bit ascii range).
.IP \fBboolean\fR 12
Any of the forms allowed to \fBTcl_GetBoolean\fR.
.IP \fBcontrol\fR 12
Any Unicode control character.
.IP \fBdigit\fR 12
Any Unicode digit character. Note that this includes characters
outside of the [0\-9] range.
.IP \fBdouble\fR 12
Any of the valid forms for a double in Tcl, with optional surrounding
whitespace. In case of under/overflow in the value, 0 is returned and
the \fIvarname\fR will contain \-1.
.IP \fBfalse\fR 12
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
false.
.IP \fBgraph\fR 12
Any Unicode printing character, except space.
.IP \fBinteger\fR 12
Any of the valid forms for an ordinary integer in Tcl, with optional
surrounding whitespace. In case of under/overflow in the value, 0 is
returned and the \fIvarname\fR will contain \-1.
.IP \fBlower\fR 12
Any Unicode lower case alphabet character.
.IP \fBprint\fR 12
Any Unicode printing character, including space.
.IP \fBpunct\fR 12
Any Unicode punctuation character.
.IP \fBspace\fR 12
Any Unicode space character.
.IP \fBtrue\fR 12
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
true.
.IP \fBupper\fR 12
Any upper case alphabet character in the Unicode character set.
.IP \fBwordchar\fR 12
Any Unicode word character. That is any alphanumeric character, and
any Unicode connector punctuation characters (e.g. underscore).
.IP \fBxdigit\fR 12
Any hexadecimal digit character ([0\-9A\-Fa\-f]).
.PP
In the case of \fBboolean\fR, \fBtrue\fR and \fBfalse\fR, if the
function will return 0, then the \fIvarname\fR will always be set to
0, due to the varied nature of a valid boolean value.
.RE
.TP
\fBstring last \fIneedleString haystackString\fR ?\fIlastIndex\fR?
Search \fIhaystackString\fR for a sequence of characters that exactly match
the characters in \fIneedleString\fR. If found, return the index of the
first character in the last such match within \fIhaystackString\fR. If there
is no match, then return \-1. If \fIlastIndex\fR is specified (in any
of the forms accepted by the \fBindex\fR method), then only the
characters in \fIhaystackString\fR at or before the specified \fIlastIndex\fR
will be considered by the search. For example,
.RS
.CS
\fBstring last a 0a23456789abcdef 15\fR
.CE
will return \fB10\fR, but
.CS
\fBstring last a 0a23456789abcdef 9\fR
.CE
will return \fB1\fR.
.RE
.TP
\fBstring length \fIstring\fR
Returns a decimal string giving the number of characters in
\fIstring\fR. Note that this is not necessarily the same as the
number of bytes used to store the string. If the object is a
ByteArray object (such as those returned from reading a binary encoded
channel), then this will return the actual byte length of the object.
.TP
\fBstring map\fR ?\fB\-nocase\fR? \fImapping string\fR
Replaces substrings in \fIstring\fR based on the key-value pairs in
\fImapping\fR. \fImapping\fR is a list of \fIkey value key value ...\fR
as in the form returned by \fBarray get\fR. Each instance of a
key in the string will be replaced with its corresponding value. If
\fB\-nocase\fR is specified, then matching is done without regard to
case differences. Both \fIkey\fR and \fIvalue\fR may be multiple
characters. Replacement is done in an ordered manner, so the key
appearing first in the list will be checked first, and so on.
\fIstring\fR is only iterated over once, so earlier key replacements
will have no affect for later key matches. For example,
.RS
.CS
\fBstring map {abc 1 ab 2 a 3 1 0} 1abcaababcabababc\fR
.CE
will return the string \fB01321221\fR.
.PP
Note that if an earlier \fIkey\fR is a prefix of a later one, it will
completely mask the later one. So if the previous example is
reordered like this,
.CS
\fBstring map {1 0 ab 2 a 3 abc 1} 1abcaababcabababc\fR
.CE
it will return the string \fB02c322c222c\fR.
.RE
.TP
\fBstring match\fR ?\fB\-nocase\fR? \fIpattern\fR \fIstring\fR
See if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0 if
it does not. If \fB\-nocase\fR is specified, then the pattern attempts
to match against the string in a case insensitive manner. For the two
strings to match, their contents must be identical except that the
following special sequences may appear in \fIpattern\fR:
.RS
.IP \fB*\fR 10
Matches any sequence of characters in \fIstring\fR, including a null
string.
.IP \fB?\fR 10
Matches any single character in \fIstring\fR.
.IP \fB[\fIchars\fB]\fR 10
Matches any character in the set given by \fIchars\fR. If a sequence
of the form \fIx\fB\-\fIy\fR appears in \fIchars\fR, then any
character between \fIx\fR and \fIy\fR, inclusive, will match. When
used with \fB\-nocase\fR, the end points of the range are converted to
lower case first. Whereas {[A\-z]} matches '_' when matching
case-sensitively ('_' falls between the 'Z' and 'a'), with
\fB\-nocase\fR this is considered like {[A\-Za\-z]} (and probably what
was meant in the first place).
.IP \fB\e\fIx\fR 10
Matches the single character \fIx\fR. This provides a way of avoiding
the special interpretation of the characters \fB*?[]\e\fR in
\fIpattern\fR.
.RE
.TP
\fBstring range \fIstring first last\fR
Returns a range of consecutive characters from \fIstring\fR, starting
with the character whose index is \fIfirst\fR and ending with the
character whose index is \fIlast\fR. An index of 0 refers to the first
character of the string. \fIfirst\fR and \fIlast\fR may be specified
as for the \fBindex\fR method. If \fIfirst\fR is less than zero then
it is treated as if it were zero, and if \fIlast\fR is greater than or
equal to the length of the string then it is treated as if it were
\fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty
string is returned.
.TP
\fBstring repeat \fIstring count\fR
Returns \fIstring\fR repeated \fIcount\fR number of times.
.TP
\fBstring replace \fIstring first last\fR ?\fInewstring\fR?
Removes a range of consecutive characters from \fIstring\fR, starting
with the character whose index is \fIfirst\fR and ending with the
character whose index is \fIlast\fR. An index of 0 refers to the
first character of the string. \fIFirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method. If \fInewstring\fR is
specified, then it is placed in the removed character range. If
\fIfirst\fR is less than zero then it is treated as if it were zero,
and if \fIlast\fR is greater than or equal to the length of the string
then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater
than \fIlast\fR or the length of the initial string, or \fIlast\fR is
less than 0, then the initial string is returned untouched.
.TP
\fBstring tolower \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that all upper (or title)
case letters have been converted to lower case. If \fIfirst\fR is
specified, it refers to the first char index in the string to start
modifying. If \fIlast\fR is specified, it refers to the char index in
the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.
.TP
\fBstring totitle \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that the first character
in \fIstring\fR is converted to its Unicode title case variant (or
upper case if there is no title case variant) and the rest of the
string is converted to lower case. If \fIfirst\fR is specified, it
refers to the first char index in the string to start modifying. If
\fIlast\fR is specified, it refers to the char index in the string to
stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified as
for the \fBindex\fR method.
.TP
\fBstring toupper \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that all lower (or title)
case letters have been converted to upper case. If \fIfirst\fR is
specified, it refers to the first char index in the string to start
modifying. If \fIlast\fR is specified, it refers to the char index in
the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.
.TP
\fBstring trim \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any leading or
trailing characters present in the string given by \fIchars\fR are removed. If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring trimleft \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any leading
characters present in the string given by \fIchars\fR are removed. If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring trimright \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any trailing
characters present in the string given by \fIchars\fR are removed. If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.SH "OBSOLETE SUBCOMMANDS"
.PP
These subcommands are currently supported, but are likely to go away in a
future release as their functionality is either virtually never used or highly
misleading.
.TP
\fBstring bytelength \fIstring\fR
Returns a decimal string giving the number of bytes used to represent
\fIstring\fR in memory. Because UTF\-8 uses one to three bytes to
represent Unicode characters, the byte length will not be the same as
the character length in general. The cases where a script cares about
the byte length are rare. In almost all cases, you should use the
\fBstring length\fR operation (including determining the length of a
Tcl ByteArray object). Refer to the \fBTcl_NumUtfChars\fR manual
entry for more details on the UTF\-8 representation.
.TP
\fBstring wordend \fIstring charIndex\fR
Returns the index of the character just after the last one in the word
containing character \fIcharIndex\fR of \fIstring\fR. \fIcharIndex\fR
may be specified as for the \fBindex\fR method. A word is
considered to be any contiguous range of alphanumeric (Unicode letters
or decimal digits) or underscore (Unicode connector punctuation)
characters, or any single character other than these.
.TP
\fBstring wordstart \fIstring charIndex\fR
Returns the index of the first character in the word containing
character \fIcharIndex\fR of \fIstring\fR. \fIcharIndex\fR may be
specified as for the \fBindex\fR method. A word is considered to be any
contiguous range of alphanumeric (Unicode letters or decimal digits)
or underscore (Unicode connector punctuation) characters, or any
single character other than these.
.SH EXAMPLE
Test if the string in the variable \fIstring\fR is a proper non-empty
prefix of the string \fBfoobar\fR.
.CS
set length [\fBstring length\fR $string]
if {$length == 0} {
set isPrefix 0
} else {
set isPrefix [\fBstring equal\fR -length $length $string "foobar"]
}
.CE
.SH "SEE ALSO"
expr(n), list(n)
.SH KEYWORDS
case conversion, compare, index, match, pattern, string, word, equal, ctype
tcl8.4.20/doc/re_syntax.n 0000644 0036047 0045461 00000062442 11737050674 013667 0 ustar dgp 771div '\"
'\" Copyright (c) 1998 Sun Microsystems, Inc.
'\" Copyright (c) 1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH re_syntax n "8.1" Tcl "Tcl Built-In Commands"
.BS
.SH NAME
re_syntax \- Syntax of Tcl regular expressions.
.BE
.SH DESCRIPTION
.PP
A \fIregular expression\fR describes strings of characters.
It's a pattern that matches certain strings and doesn't match others.
.SH "DIFFERENT FLAVORS OF REs"
Regular expressions (``RE''s), as defined by POSIX, come in two
flavors: \fIextended\fR REs (``EREs'') and \fIbasic\fR REs (``BREs'').
EREs are roughly those of the traditional \fIegrep\fR, while BREs are
roughly those of the traditional \fIed\fR. This implementation adds
a third flavor, \fIadvanced\fR REs (``AREs''), basically EREs with
some significant extensions.
.PP
This manual page primarily describes AREs. BREs mostly exist for
backward compatibility in some old programs; they will be discussed at
the end. POSIX EREs are almost an exact subset of AREs. Features of
AREs that are not present in EREs will be indicated.
.SH "REGULAR EXPRESSION SYNTAX"
.PP
Tcl regular expressions are implemented using the package written by
Henry Spencer, based on the 1003.2 spec and some (not quite all) of
the Perl5 extensions (thanks, Henry!). Much of the description of
regular expressions below is copied verbatim from his manual entry.
.PP
An ARE is one or more \fIbranches\fR,
separated by `\fB|\fR',
matching anything that matches any of the branches.
.PP
A branch is zero or more \fIconstraints\fR or \fIquantified atoms\fR,
concatenated.
It matches a match for the first, followed by a match for the second, etc;
an empty branch matches the empty string.
.PP
A quantified atom is an \fIatom\fR possibly followed
by a single \fIquantifier\fR.
Without a quantifier, it matches a match for the atom.
The quantifiers,
and what a so-quantified atom matches, are:
.RS 2
.TP 6
\fB*\fR
a sequence of 0 or more matches of the atom
.TP
\fB+\fR
a sequence of 1 or more matches of the atom
.TP
\fB?\fR
a sequence of 0 or 1 matches of the atom
.TP
\fB{\fIm\fB}\fR
a sequence of exactly \fIm\fR matches of the atom
.TP
\fB{\fIm\fB,}\fR
a sequence of \fIm\fR or more matches of the atom
.TP
\fB{\fIm\fB,\fIn\fB}\fR
a sequence of \fIm\fR through \fIn\fR (inclusive) matches of the atom;
\fIm\fR may not exceed \fIn\fR
.TP
\fB*? +? ?? {\fIm\fB}? {\fIm\fB,}? {\fIm\fB,\fIn\fB}?\fR
\fInon-greedy\fR quantifiers,
which match the same possibilities,
but prefer the smallest number rather than the largest number
of matches (see MATCHING)
.RE
.PP
The forms using
\fB{\fR and \fB}\fR
are known as \fIbound\fRs.
The numbers
\fIm\fR and \fIn\fR are unsigned decimal integers
with permissible values from 0 to 255 inclusive.
.PP
An atom is one of:
.RS 2
.TP 6
\fB(\fIre\fB)\fR
(where \fIre\fR is any regular expression)
matches a match for
\fIre\fR, with the match noted for possible reporting
.TP
\fB(?:\fIre\fB)\fR
as previous,
but does no reporting
(a ``non-capturing'' set of parentheses)
.TP
\fB()\fR
matches an empty string,
noted for possible reporting
.TP
\fB(?:)\fR
matches an empty string,
without reporting
.TP
\fB[\fIchars\fB]\fR
a \fIbracket expression\fR,
matching any one of the \fIchars\fR (see BRACKET EXPRESSIONS for more detail)
.TP
\fB.\fR
matches any single character
.TP
\fB\e\fIk\fR
(where \fIk\fR is a non-alphanumeric character)
matches that character taken as an ordinary character,
e.g. \e\e matches a backslash character
.TP
\fB\e\fIc\fR
where \fIc\fR is alphanumeric
(possibly followed by other characters),
an \fIescape\fR (AREs only),
see ESCAPES below
.TP
\fB{\fR
when followed by a character other than a digit,
matches the left-brace character `\fB{\fR';
when followed by a digit, it is the beginning of a
\fIbound\fR (see above)
.TP
\fIx\fR
where \fIx\fR is
a single character with no other significance, matches that character.
.RE
.PP
A \fIconstraint\fR matches an empty string when specific conditions
are met.
A constraint may not be followed by a quantifier.
The simple constraints are as follows; some more constraints are
described later, under ESCAPES.
.RS 2
.TP 8
\fB^\fR
matches at the beginning of a line
.TP
\fB$\fR
matches at the end of a line
.TP
\fB(?=\fIre\fB)\fR
\fIpositive lookahead\fR (AREs only), matches at any point
where a substring matching \fIre\fR begins
.TP
\fB(?!\fIre\fB)\fR
\fInegative lookahead\fR (AREs only), matches at any point
where no substring matching \fIre\fR begins
.RE
.PP
The lookahead constraints may not contain back references (see later),
and all parentheses within them are considered non-capturing.
.PP
An RE may not end with `\fB\e\fR'.
.SH "BRACKET EXPRESSIONS"
A \fIbracket expression\fR is a list of characters enclosed in `\fB[\|]\fR'.
It normally matches any single character from the list (but see below).
If the list begins with `\fB^\fR',
it matches any single character
(but see below) \fInot\fR from the rest of the list.
.PP
If two characters in the list are separated by `\fB\-\fR',
this is shorthand
for the full \fIrange\fR of characters between those two (inclusive) in the
collating sequence,
e.g.
\fB[0\-9]\fR
in ASCII matches any decimal digit.
Two ranges may not share an
endpoint, so e.g.
\fBa\-c\-e\fR
is illegal.
Ranges are very collating-sequence-dependent,
and portable programs should avoid relying on them.
.PP
To include a literal
\fB]\fR
or
\fB\-\fR
in the list,
the simplest method is to
enclose it in
\fB[.\fR and \fB.]\fR
to make it a collating element (see below).
Alternatively,
make it the first character
(following a possible `\fB^\fR'),
or (AREs only) precede it with `\fB\e\fR'.
Alternatively, for `\fB\-\fR',
make it the last character,
or the second endpoint of a range.
To use a literal
\fB\-\fR
as the first endpoint of a range,
make it a collating element
or (AREs only) precede it with `\fB\e\fR'.
With the exception of these, some combinations using
\fB[\fR
(see next
paragraphs), and escapes,
all other special characters lose their
special significance within a bracket expression.
.PP
Within a bracket expression, a collating element (a character,
a multi-character sequence that collates as if it were a single character,
or a collating-sequence name for either)
enclosed in
\fB[.\fR and \fB.]\fR
stands for the
sequence of characters of that collating element.
The sequence is a single element of the bracket expression's list.
A bracket expression in a locale that has
multi-character collating elements
can thus match more than one character.
.VS 8.2
So (insidiously), a bracket expression that starts with \fB^\fR
can match multi-character collating elements even if none of them
appear in the bracket expression!
(\fINote:\fR Tcl currently has no multi-character collating elements.
This information is only for illustration.)
.PP
For example, assume the collating sequence includes a \fBch\fR
multi-character collating element.
Then the RE \fB[[.ch.]]*c\fR (zero or more \fBch\fP's followed by \fBc\fP)
matches the first five characters of `\fBchchcc\fR'.
Also, the RE \fB[^c]b\fR matches all of `\fBchb\fR'
(because \fB[^c]\fR matches the multi-character \fBch\fR).
.VE 8.2
.PP
Within a bracket expression, a collating element enclosed in
\fB[=\fR
and
\fB=]\fR
is an equivalence class, standing for the sequences of characters
of all collating elements equivalent to that one, including itself.
(If there are no other equivalent collating elements,
the treatment is as if the enclosing delimiters were `\fB[.\fR'\&
and `\fB.]\fR'.)
For example, if
\fBo\fR
and
\fB\o'o^'\fR
are the members of an equivalence class,
then `\fB[[=o=]]\fR', `\fB[[=\o'o^'=]]\fR',
and `\fB[o\o'o^']\fR'\&
are all synonymous.
An equivalence class may not be an endpoint
of a range.
.VS 8.2
(\fINote:\fR
Tcl currently implements only the Unicode locale.
It doesn't define any equivalence classes.
The examples above are just illustrations.)
.VE 8.2
.PP
Within a bracket expression, the name of a \fIcharacter class\fR enclosed
in
\fB[:\fR
and
\fB:]\fR
stands for the list of all characters
(not all collating elements!)
belonging to that
class.
Standard character classes are:
.PP
.RS
.ne 5
.ta 3c
.nf
\fBalpha\fR A letter.
\fBupper\fR An upper-case letter.
\fBlower\fR A lower-case letter.
\fBdigit\fR A decimal digit.
\fBxdigit\fR A hexadecimal digit.
\fBalnum\fR An alphanumeric (letter or digit).
\fBprint\fR A "printable" (same as graph, except also including space).
\fBblank\fR A space or tab character.
\fBspace\fR A character producing white space in displayed text.
\fBpunct\fR A punctuation character.
\fBgraph\fR A character with a visible representation.
\fBcntrl\fR A control character.
.fi
.RE
.PP
A locale may provide others.
.VS 8.2
(Note that the current Tcl implementation has only one locale:
the Unicode locale.)
.VE 8.2
A character class may not be used as an endpoint of a range.
.PP
There are two special cases of bracket expressions:
the bracket expressions
\fB[[:<:]]\fR
and
\fB[[:>:]]\fR
are constraints, matching empty strings at
the beginning and end of a word respectively.
'\" note, discussion of escapes below references this definition of word
A word is defined as a sequence of
word characters
that is neither preceded nor followed by
word characters.
A word character is an
\fIalnum\fR
character
or an underscore
(\fB_\fR).
These special bracket expressions are deprecated;
users of AREs should use constraint escapes instead (see below).
.SH ESCAPES
Escapes (AREs only), which begin with a
\fB\e\fR
followed by an alphanumeric character,
come in several varieties:
character entry, class shorthands, constraint escapes, and back references.
A
\fB\e\fR
followed by an alphanumeric character but not constituting
a valid escape is illegal in AREs.
In EREs, there are no escapes:
outside a bracket expression,
a
\fB\e\fR
followed by an alphanumeric character merely stands for that
character as an ordinary character,
and inside a bracket expression,
\fB\e\fR
is an ordinary character.
(The latter is the one actual incompatibility between EREs and AREs.)
.PP
Character-entry escapes (AREs only) exist to make it easier to specify
non-printing and otherwise inconvenient characters in REs:
.RS 2
.TP 5
\fB\ea\fR
alert (bell) character, as in C
.TP
\fB\eb\fR
backspace, as in C
.TP
\fB\eB\fR
synonym for
\fB\e\fR
to help reduce backslash doubling in some
applications where there are multiple levels of backslash processing
.TP
\fB\ec\fIX\fR
(where X is any character) the character whose
low-order 5 bits are the same as those of
\fIX\fR,
and whose other bits are all zero
.TP
\fB\ee\fR
the character whose collating-sequence name
is `\fBESC\fR',
or failing that, the character with octal value 033
.TP
\fB\ef\fR
formfeed, as in C
.TP
\fB\en\fR
newline, as in C
.TP
\fB\er\fR
carriage return, as in C
.TP
\fB\et\fR
horizontal tab, as in C
.TP
\fB\eu\fIwxyz\fR
(where
\fIwxyz\fR
is exactly four hexadecimal digits)
the Unicode character
\fBU+\fIwxyz\fR
in the local byte ordering
.TP
\fB\eU\fIstuvwxyz\fR
(where
\fIstuvwxyz\fR
is exactly eight hexadecimal digits)
reserved for a somewhat-hypothetical Unicode extension to 32 bits
.TP
\fB\ev\fR
vertical tab, as in C
are all available.
.TP
\fB\ex\fIhhh\fR
(where
\fIhhh\fR
is any sequence of hexadecimal digits)
the character whose hexadecimal value is
\fB0x\fIhhh\fR
(a single character no matter how many hexadecimal digits are used).
.TP
\fB\e0\fR
the character whose value is
\fB0\fR
.TP
\fB\e\fIxy\fR
(where
\fIxy\fR
is exactly two octal digits,
and is not a
\fIback reference\fR (see below))
the character whose octal value is
\fB0\fIxy\fR
.TP
\fB\e\fIxyz\fR
(where
\fIxyz\fR
is exactly three octal digits,
and is not a
back reference (see below))
the character whose octal value is
\fB0\fIxyz\fR
.RE
.PP
Hexadecimal digits are `\fB0\fR'-`\fB9\fR', `\fBa\fR'-`\fBf\fR',
and `\fBA\fR'-`\fBF\fR'.
Octal digits are `\fB0\fR'-`\fB7\fR'.
.PP
The character-entry escapes are always taken as ordinary characters.
For example,
\fB\e135\fR
is
\fB]\fR
in ASCII,
but
\fB\e135\fR
does not terminate a bracket expression.
Beware, however, that some applications (e.g., C compilers) interpret
such sequences themselves before the regular-expression package
gets to see them, which may require doubling (quadrupling, etc.) the `\fB\e\fR'.
.PP
Class-shorthand escapes (AREs only) provide shorthands for certain commonly-used
character classes:
.RS 2
.TP 10
\fB\ed\fR
\fB[[:digit:]]\fR
.TP
\fB\es\fR
\fB[[:space:]]\fR
.TP
\fB\ew\fR
\fB[[:alnum:]_]\fR
(note underscore)
.TP
\fB\eD\fR
\fB[^[:digit:]]\fR
.TP
\fB\eS\fR
\fB[^[:space:]]\fR
.TP
\fB\eW\fR
\fB[^[:alnum:]_]\fR
(note underscore)
.RE
.PP
Within bracket expressions, `\fB\ed\fR', `\fB\es\fR',
and `\fB\ew\fR'\&
lose their outer brackets,
and `\fB\eD\fR', `\fB\eS\fR',
and `\fB\eW\fR'\&
are illegal.
.VS 8.2
(So, for example, \fB[a-c\ed]\fR is equivalent to \fB[a-c[:digit:]]\fR.
Also, \fB[a-c\eD]\fR, which is equivalent to \fB[a-c^[:digit:]]\fR, is illegal.)
.VE 8.2
.PP
A constraint escape (AREs only) is a constraint,
matching the empty string if specific conditions are met,
written as an escape:
.RS 2
.TP 6
\fB\eA\fR
matches only at the beginning of the string
(see MATCHING, below, for how this differs from `\fB^\fR')
.TP
\fB\em\fR
matches only at the beginning of a word
.TP
\fB\eM\fR
matches only at the end of a word
.TP
\fB\ey\fR
matches only at the beginning or end of a word
.TP
\fB\eY\fR
matches only at a point that is not the beginning or end of a word
.TP
\fB\eZ\fR
matches only at the end of the string
(see MATCHING, below, for how this differs from `\fB$\fR')
.TP
\fB\e\fIm\fR
(where
\fIm\fR
is a nonzero digit) a \fIback reference\fR, see below
.TP
\fB\e\fImnn\fR
(where
\fIm\fR
is a nonzero digit, and
\fInn\fR
is some more digits,
and the decimal value
\fImnn\fR
is not greater than the number of closing capturing parentheses seen so far)
a \fIback reference\fR, see below
.RE
.PP
A word is defined as in the specification of
\fB[[:<:]]\fR
and
\fB[[:>:]]\fR
above.
Constraint escapes are illegal within bracket expressions.
.PP
A back reference (AREs only) matches the same string matched by the parenthesized
subexpression specified by the number,
so that (e.g.)
\fB([bc])\e1\fR
matches
\fBbb\fR
or
\fBcc\fR
but not `\fBbc\fR'.
The subexpression must entirely precede the back reference in the RE.
Subexpressions are numbered in the order of their leading parentheses.
Non-capturing parentheses do not define subexpressions.
.PP
There is an inherent historical ambiguity between octal character-entry
escapes and back references, which is resolved by heuristics,
as hinted at above.
A leading zero always indicates an octal escape.
A single non-zero digit, not followed by another digit,
is always taken as a back reference.
A multi-digit sequence not starting with a zero is taken as a back
reference if it comes after a suitable subexpression
(i.e. the number is in the legal range for a back reference),
and otherwise is taken as octal.
.SH "METASYNTAX"
In addition to the main syntax described above, there are some special
forms and miscellaneous syntactic facilities available.
.PP
Normally the flavor of RE being used is specified by
application-dependent means.
However, this can be overridden by a \fIdirector\fR.
If an RE of any flavor begins with `\fB***:\fR',
the rest of the RE is an ARE.
If an RE of any flavor begins with `\fB***=\fR',
the rest of the RE is taken to be a literal string,
with all characters considered ordinary characters.
.PP
An ARE may begin with \fIembedded options\fR:
a sequence
\fB(?\fIxyz\fB)\fR
(where
\fIxyz\fR
is one or more alphabetic characters)
specifies options affecting the rest of the RE.
These supplement, and can override,
any options specified by the application.
The available option letters are:
.RS 2
.TP 3
\fBb\fR
rest of RE is a BRE
.TP 3
\fBc\fR
case-sensitive matching (usual default)
.TP 3
\fBe\fR
rest of RE is an ERE
.TP 3
\fBi\fR
case-insensitive matching (see MATCHING, below)
.TP 3
\fBm\fR
historical synonym for
\fBn\fR
.TP 3
\fBn\fR
newline-sensitive matching (see MATCHING, below)
.TP 3
\fBp\fR
partial newline-sensitive matching (see MATCHING, below)
.TP 3
\fBq\fR
rest of RE is a literal (``quoted'') string, all ordinary characters
.TP 3
\fBs\fR
non-newline-sensitive matching (usual default)
.TP 3
\fBt\fR
tight syntax (usual default; see below)
.TP 3
\fBw\fR
inverse partial newline-sensitive (``weird'') matching (see MATCHING, below)
.TP 3
\fBx\fR
expanded syntax (see below)
.RE
.PP
Embedded options take effect at the
\fB)\fR
terminating the sequence.
They are available only at the start of an ARE,
and may not be used later within it.
.PP
In addition to the usual (\fItight\fR) RE syntax, in which all characters are
significant, there is an \fIexpanded\fR syntax,
available in all flavors of RE
with the \fB-expanded\fR switch, or in AREs with the embedded x option.
In the expanded syntax,
white-space characters are ignored
and all characters between a
\fB#\fR
and the following newline (or the end of the RE) are ignored,
permitting paragraphing and commenting a complex RE.
There are three exceptions to that basic rule:
.RS 2
.PP
a white-space character or `\fB#\fR' preceded by `\fB\e\fR' is retained
.PP
white space or `\fB#\fR' within a bracket expression is retained
.PP
white space and comments are illegal within multi-character symbols
like the ARE `\fB(?:\fR' or the BRE `\fB\e(\fR'
.RE
.PP
Expanded-syntax white-space characters are blank, tab, newline, and
.VS 8.2
any character that belongs to the \fIspace\fR character class.
.VE 8.2
.PP
Finally, in an ARE,
outside bracket expressions, the sequence `\fB(?#\fIttt\fB)\fR'
(where
\fIttt\fR
is any text not containing a `\fB)\fR')
is a comment,
completely ignored.
Again, this is not allowed between the characters of
multi-character symbols like `\fB(?:\fR'.
Such comments are more a historical artifact than a useful facility,
and their use is deprecated;
use the expanded syntax instead.
.PP
\fINone\fR of these metasyntax extensions is available if the application
(or an initial
\fB***=\fR
director)
has specified that the user's input be treated as a literal string
rather than as an RE.
.SH MATCHING
In the event that an RE could match more than one substring of a given
string,
the RE matches the one starting earliest in the string.
If the RE could match more than one substring starting at that point,
its choice is determined by its \fIpreference\fR:
either the longest substring, or the shortest.
.PP
Most atoms, and all constraints, have no preference.
A parenthesized RE has the same preference (possibly none) as the RE.
A quantified atom with quantifier
\fB{\fIm\fB}\fR
or
\fB{\fIm\fB}?\fR
has the same preference (possibly none) as the atom itself.
A quantified atom with other normal quantifiers (including
\fB{\fIm\fB,\fIn\fB}\fR
with
\fIm\fR
equal to
\fIn\fR)
prefers longest match.
A quantified atom with other non-greedy quantifiers (including
\fB{\fIm\fB,\fIn\fB}?\fR
with
\fIm\fR
equal to
\fIn\fR)
prefers shortest match.
A branch has the same preference as the first quantified atom in it
which has a preference.
An RE consisting of two or more branches connected by the
\fB|\fR
operator prefers longest match.
.PP
Subject to the constraints imposed by the rules for matching the whole RE,
subexpressions also match the longest or shortest possible substrings,
based on their preferences,
with subexpressions starting earlier in the RE taking priority over
ones starting later.
Note that outer subexpressions thus take priority over
their component subexpressions.
.PP
Note that the quantifiers
\fB{1,1}\fR
and
\fB{1,1}?\fR
can be used to force longest and shortest preference, respectively,
on a subexpression or a whole RE.
.PP
Match lengths are measured in characters, not collating elements.
An empty string is considered longer than no match at all.
For example,
\fBbb*\fR
matches the three middle characters of `\fBabbbc\fR',
\fB(week|wee)(night|knights)\fR
matches all ten characters of `\fBweeknights\fR',
when
\fB(.*).*\fR
is matched against
\fBabc\fR
the parenthesized subexpression
matches all three characters, and
when
\fB(a*)*\fR
is matched against
\fBbc\fR
both the whole RE and the parenthesized
subexpression match an empty string.
.PP
If case-independent matching is specified,
the effect is much as if all case distinctions had vanished from the
alphabet.
When an alphabetic that exists in multiple cases appears as an
ordinary character outside a bracket expression, it is effectively
transformed into a bracket expression containing both cases,
so that
\fBx\fR
becomes `\fB[xX]\fR'.
When it appears inside a bracket expression, all case counterparts
of it are added to the bracket expression, so that
\fB[x]\fR
becomes
\fB[xX]\fR
and
\fB[^x]\fR
becomes `\fB[^xX]\fR'.
.PP
If newline-sensitive matching is specified, \fB.\fR
and bracket expressions using
\fB^\fR
will never match the newline character
(so that matches will never cross newlines unless the RE
explicitly arranges it)
and
\fB^\fR
and
\fB$\fR
will match the empty string after and before a newline
respectively, in addition to matching at beginning and end of string
respectively.
ARE
\fB\eA\fR
and
\fB\eZ\fR
continue to match beginning or end of string \fIonly\fR.
.PP
If partial newline-sensitive matching is specified,
this affects \fB.\fR
and bracket expressions
as with newline-sensitive matching, but not
\fB^\fR
and `\fB$\fR'.
.PP
If inverse partial newline-sensitive matching is specified,
this affects
\fB^\fR
and
\fB$\fR
as with
newline-sensitive matching,
but not \fB.\fR
and bracket expressions.
This isn't very useful but is provided for symmetry.
.SH "LIMITS AND COMPATIBILITY"
No particular limit is imposed on the length of REs.
Programs intended to be highly portable should not employ REs longer
than 256 bytes,
as a POSIX-compliant implementation can refuse to accept such REs.
.PP
The only feature of AREs that is actually incompatible with
POSIX EREs is that
\fB\e\fR
does not lose its special
significance inside bracket expressions.
All other ARE features use syntax which is illegal or has
undefined or unspecified effects in POSIX EREs;
the
\fB***\fR
syntax of directors likewise is outside the POSIX
syntax for both BREs and EREs.
.PP
Many of the ARE extensions are borrowed from Perl, but some have
been changed to clean them up, and a few Perl extensions are not present.
Incompatibilities of note include `\fB\eb\fR', `\fB\eB\fR',
the lack of special treatment for a trailing newline,
the addition of complemented bracket expressions to the things
affected by newline-sensitive matching,
the restrictions on parentheses and back references in lookahead constraints,
and the longest/shortest-match (rather than first-match) matching semantics.
.PP
The matching rules for REs containing both normal and non-greedy quantifiers
have changed since early beta-test versions of this package.
(The new rules are much simpler and cleaner,
but don't work as hard at guessing the user's real intentions.)
.PP
Henry Spencer's original 1986 \fIregexp\fR package,
still in widespread use (e.g., in pre-8.1 releases of Tcl),
implemented an early version of today's EREs.
There are four incompatibilities between \fIregexp\fR's near-EREs
(`RREs' for short) and AREs.
In roughly increasing order of significance:
.PP
.RS
In AREs,
\fB\e\fR
followed by an alphanumeric character is either an
escape or an error,
while in RREs, it was just another way of writing the
alphanumeric.
This should not be a problem because there was no reason to write
such a sequence in RREs.
.PP
\fB{\fR
followed by a digit in an ARE is the beginning of a bound,
while in RREs,
\fB{\fR
was always an ordinary character.
Such sequences should be rare,
and will often result in an error because following characters
will not look like a valid bound.
.PP
In AREs,
\fB\e\fR
remains a special character within `\fB[\|]\fR',
so a literal
\fB\e\fR
within
\fB[\|]\fR
must be written `\fB\e\e\fR'.
\fB\e\e\fR
also gives a literal
\fB\e\fR
within
\fB[\|]\fR
in RREs,
but only truly paranoid programmers routinely doubled the backslash.
.PP
AREs report the longest/shortest match for the RE,
rather than the first found in a specified search order.
This may affect some RREs which were written in the expectation that
the first match would be reported.
(The careful crafting of RREs to optimize the search order for fast
matching is obsolete (AREs examine all possible matches
in parallel, and their performance is largely insensitive to their
complexity) but cases where the search order was exploited to deliberately
find a match which was \fInot\fR the longest/shortest will need rewriting.)
.RE
.SH "BASIC REGULAR EXPRESSIONS"
BREs differ from EREs in several respects. `\fB|\fR', `\fB+\fR',
and
\fB?\fR
are ordinary characters and there is no equivalent
for their functionality.
The delimiters for bounds are
\fB\e{\fR
and `\fB\e}\fR',
with
\fB{\fR
and
\fB}\fR
by themselves ordinary characters.
The parentheses for nested subexpressions are
\fB\e(\fR
and `\fB\e)\fR',
with
\fB(\fR
and
\fB)\fR
by themselves ordinary characters.
\fB^\fR
is an ordinary character except at the beginning of the
RE or the beginning of a parenthesized subexpression,
\fB$\fR
is an ordinary character except at the end of the
RE or the end of a parenthesized subexpression,
and
\fB*\fR
is an ordinary character if it appears at the beginning of the
RE or the beginning of a parenthesized subexpression
(after a possible leading `\fB^\fR').
Finally,
single-digit back references are available,
and
\fB\e<\fR
and
\fB\e>\fR
are synonyms for
\fB[[:<:]]\fR
and
\fB[[:>:]]\fR
respectively;
no other escapes are available.
.SH "SEE ALSO"
RegExp(3), regexp(n), regsub(n), lsearch(n), switch(n), text(n)
.SH KEYWORDS
match, regular expression, string
tcl8.4.20/doc/Preserve.3 0000644 0036047 0045461 00000010675 11737050674 013354 0 ustar dgp 771div '\"
'\" Copyright (c) 1990 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_Preserve 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Preserve, Tcl_Release, Tcl_EventuallyFree \- avoid freeing storage while it's being used
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_Preserve\fR(\fIclientData\fR)
.sp
\fBTcl_Release\fR(\fIclientData\fR)
.sp
\fBTcl_EventuallyFree\fR(\fIclientData, freeProc\fR)
.SH ARGUMENTS
.AS Tcl_FreeProc clientData
.AP ClientData clientData in
Token describing structure to be freed or reallocated. Usually a pointer
to memory for structure.
.AP Tcl_FreeProc *freeProc in
Procedure to invoke to free \fIclientData\fR.
.BE
.SH DESCRIPTION
.PP
These three procedures help implement a simple reference count mechanism
for managing storage. They are designed to solve a problem
having to do with widget deletion, but are also useful in many other
situations. When a widget is deleted, its
widget record (the structure holding information specific to the
widget) must be returned to the storage allocator.
However, it's possible that the widget record is in active use
by one of the procedures on the stack at the time of the deletion.
This can happen, for example, if the command associated with a button
widget causes the button to be destroyed: an X event causes an
event-handling C procedure in the button to be invoked, which in
turn causes the button's associated Tcl command to be executed,
which in turn causes the button to be deleted, which in turn causes
the button's widget record to be de-allocated.
Unfortunately, when the Tcl command returns, the button's
event-handling procedure will need to reference the
button's widget record.
Because of this, the widget record must not be freed as part of the
deletion, but must be retained until the event-handling procedure has
finished with it.
In other situations where the widget is deleted, it may be possible
to free the widget record immediately.
.PP
\fBTcl_Preserve\fR and \fBTcl_Release\fR
implement short-term reference counts for their \fIclientData\fR
argument.
The \fIclientData\fR argument identifies an object and usually
consists of the address of a structure.
The reference counts guarantee that an object will not be freed
until each call to \fBTcl_Preserve\fR for the object has been
matched by calls to \fBTcl_Release\fR.
There may be any number of unmatched \fBTcl_Preserve\fR calls
in effect at once.
.PP
\fBTcl_EventuallyFree\fR is invoked to free up its \fIclientData\fR
argument.
It checks to see if there are unmatched \fBTcl_Preserve\fR calls
for the object.
If not, then \fBTcl_EventuallyFree\fR calls \fIfreeProc\fR immediately.
Otherwise \fBTcl_EventuallyFree\fR records the fact that \fIclientData\fR
needs eventually to be freed.
When all calls to \fBTcl_Preserve\fR have been matched with
calls to \fBTcl_Release\fR then \fIfreeProc\fR will be called by
\fBTcl_Release\fR to do the cleanup.
.PP
All the work of freeing the object is carried out by \fIfreeProc\fR.
\fIFreeProc\fR must have arguments and result that match the
type \fBTcl_FreeProc\fR:
.CS
typedef void Tcl_FreeProc(char *\fIblockPtr\fR);
.CE
The \fIblockPtr\fR argument to \fIfreeProc\fR will be the
same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR.
The type of \fIblockPtr\fR (\fBchar *\fR) is different than the type of the
\fIclientData\fR argument to \fBTcl_EventuallyFree\fR for historical
reasons, but the value is the same.
.PP
When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR
refers to storage allocated and returned by a prior call to
\fBTcl_Alloc\fR, \fBckalloc\fR, or another function of the Tcl library,
then the \fIfreeProc\fR argument should be given the special value of
\fBTCL_DYNAMIC\fR.
.PP
This mechanism can be used to solve the problem described above
by placing \fBTcl_Preserve\fR and \fBTcl_Release\fR calls around
actions that may cause undesired storage re-allocation. The
mechanism is intended only for short-term use (i.e. while procedures
are pending on the stack); it will not work efficiently as a
mechanism for long-term reference counts.
The implementation does not depend in any way on the internal
structure of the objects being freed; it keeps the reference
counts in a separate structure.
.SH "SEE ALSO"
Tcl_Interp, Tcl_Alloc
.SH KEYWORDS
free, reference count, storage
tcl8.4.20/doc/pwd.n 0000644 0036047 0045461 00000002216 11737050674 012436 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH pwd n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
pwd \- Return the absolute path of the current working directory
.SH SYNOPSIS
\fBpwd\fR
.BE
.SH DESCRIPTION
.PP
Returns the absolute path name of the current working directory.
.SH EXAMPLE
Sometimes it is useful to change to a known directory when running
some external command using \fBexec\fR, but it is important to keep
the application usually running in the directory that it was started
in (unless the user specifies otherwise) since that minimises user
confusion. The way to do this is to save the current directory while
the external command is being run:
.CS
set tarFile [file normalize somefile.tar]
set savedDir [\fBpwd\fR]
cd /tmp
exec tar -xf $tarFile
cd $savedDir
.CE
.SH "SEE ALSO"
file(n), cd(n), glob(n), filename(n)
.SH KEYWORDS
working directory
tcl8.4.20/doc/array.n 0000644 0036047 0045461 00000016540 11737050674 012767 0 ustar dgp 771div '\"
'\" Copyright (c) 1993-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH array n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
array \- Manipulate array variables
.SH SYNOPSIS
\fBarray \fIoption arrayName\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command performs one of several operations on the
variable given by \fIarrayName\fR.
Unless otherwise specified for individual commands below,
\fIarrayName\fR must be the name of an existing array variable.
The \fIoption\fR argument determines what action is carried
out by the command.
The legal \fIoptions\fR (which may be abbreviated) are:
.TP
\fBarray anymore \fIarrayName searchId\fR
Returns 1 if there are any more elements left to be processed
in an array search, 0 if all elements have already been
returned.
\fISearchId\fR indicates which search on \fIarrayName\fR to
check, and must have been the return value from a previous
invocation of \fBarray startsearch\fR.
This option is particularly useful if an array has an element
with an empty name, since the return value from
\fBarray nextelement\fR won't indicate whether the search
has been completed.
.TP
\fBarray donesearch \fIarrayName searchId\fR
This command terminates an array search and destroys all the
state associated with that search. \fISearchId\fR indicates
which search on \fIarrayName\fR to destroy, and must have
been the return value from a previous invocation of
\fBarray startsearch\fR. Returns an empty string.
.TP
\fBarray exists \fIarrayName\fR
Returns 1 if \fIarrayName\fR is an array variable, 0 if there
is no variable by that name or if it is a scalar variable.
.TP
\fBarray get \fIarrayName\fR ?\fIpattern\fR?
Returns a list containing pairs of elements. The first
element in each pair is the name of an element in \fIarrayName\fR
and the second element of each pair is the value of the
array element. The order of the pairs is undefined.
If \fIpattern\fR is not specified, then all of the elements of the
array are included in the result.
If \fIpattern\fR is specified, then only those elements whose names
match \fIpattern\fR (using the matching rules of
\fBstring match\fR) are included.
If \fIarrayName\fR isn't the name of an array variable, or if
the array contains no elements, then an empty list is returned.
.TP
\fBarray names \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR?
Returns a list containing the names of all of the elements in
the array that match \fIpattern\fR. \fIMode\fR may be one of
\fB-exact\fR, \fB-glob\fR, or \fB-regexp\fR. If specified, \fImode\fR
designates which matching rules to use to match \fIpattern\fR against
the names of the elements in the array. If not specified, \fImode\fR
defaults to \fB-glob\fR. See the documentation for \fBstring match\fR
for information on glob style matching, and the documentation for
\fBregexp\fR for information on regexp matching.
If \fIpattern\fR is omitted then the command returns all of
the element names in the array. If there are no (matching) elements
in the array, or if \fIarrayName\fR isn't the name of an array
variable, then an empty string is returned.
.TP
\fBarray nextelement \fIarrayName searchId\fR
Returns the name of the next element in \fIarrayName\fR, or
an empty string if all elements of \fIarrayName\fR have
already been returned in this search. The \fIsearchId\fR
argument identifies the search, and must have
been the return value of an \fBarray startsearch\fR command.
Warning: if elements are added to or deleted from the array,
then all searches are automatically terminated just as if
\fBarray donesearch\fR had been invoked; this will cause
\fBarray nextelement\fR operations to fail for those searches.
.TP
\fBarray set \fIarrayName list\fR
Sets the values of one or more elements in \fIarrayName\fR.
\fIlist\fR must have a form like that returned by \fBarray get\fR,
consisting of an even number of elements.
Each odd-numbered element in \fIlist\fR is treated as an element
name within \fIarrayName\fR, and the following element in \fIlist\fR
is used as a new value for that array element.
If the variable \fIarrayName\fR does not already exist
and \fIlist\fR is empty,
\fIarrayName\fR is created with an empty array value.
.TP
\fBarray size \fIarrayName\fR
Returns a decimal string giving the number of elements in the
array.
If \fIarrayName\fR isn't the name of an array then 0 is returned.
.TP
\fBarray startsearch \fIarrayName\fR
This command initializes an element-by-element search through the
array given by \fIarrayName\fR, such that invocations of the
\fBarray nextelement\fR command will return the names of the
individual elements in the array.
When the search has been completed, the \fBarray donesearch\fR
command should be invoked.
The return value is a
search identifier that must be used in \fBarray nextelement\fR
and \fBarray donesearch\fR commands; it allows multiple
searches to be underway simultaneously for the same array.
It is currently more efficient and easier to use either the \fBarray
get\fR or \fBarray names\fR, together with \fBforeach\fR, to iterate
over all but very large arrays. See the examples below for how to do
this.
.VS 8.4
.TP
\fBarray statistics \fIarrayName\fR
Returns statistics about the distribution of data within the hashtable
that represents the array. This information includes the number of
entries in the table, the number of buckets, and the utilization of
the buckets.
.VE 8.4
.VS 8.3
.TP
\fBarray unset \fIarrayName\fR ?\fIpattern\fR?
Unsets all of the elements in the array that match \fIpattern\fR (using the
matching rules of \fBstring match\fR). If \fIarrayName\fR isn't the name
of an array variable or there are no matching elements in the array, no
error will be raised. If \fIpattern\fR is omitted and \fIarrayName\fR is
an array variable, then the command unsets the entire array.
The command always returns an empty string.
.VE 8.3
.SH EXAMPLES
.CS
\fBarray set\fR colorcount {
red 1
green 5
blue 4
white 9
}
foreach {color count} [\fBarray get\fR colorcount] {
puts "Color: $color Count: $count"
}
=> Color: blue Count: 4
Color: white Count: 9
Color: green Count: 5
Color: red Count: 1
foreach color [\fBarray names\fR colorcount] {
puts "Color: $color Count: $colorcount($color)"
}
=> Color: blue Count: 4
Color: white Count: 9
Color: green Count: 5
Color: red Count: 1
foreach color [lsort [array names colorcount]] {
puts "Color: $color Count: $colorcount($color)"
}
=> Color: blue Count: 4
Color: green Count: 5
Color: red Count: 1
Color: white Count: 9
\fBarray statistics\fR colorcount
=> 4 entries in table, 4 buckets
number of buckets with 0 entries: 1
number of buckets with 1 entries: 2
number of buckets with 2 entries: 1
number of buckets with 3 entries: 0
number of buckets with 4 entries: 0
number of buckets with 5 entries: 0
number of buckets with 6 entries: 0
number of buckets with 7 entries: 0
number of buckets with 8 entries: 0
number of buckets with 9 entries: 0
number of buckets with 10 or more entries: 0
average search distance for entry: 1.2
.CE
.SH "SEE ALSO"
list(n), string(n), variable(n), trace(n), foreach(n)
.SH KEYWORDS
array, element names, search
tcl8.4.20/doc/info.n 0000644 0036047 0045461 00000023202 11737050674 012575 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" 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.
'\"
.so man.macros
.TH info n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
info \- Return information about the state of the Tcl interpreter
.SH SYNOPSIS
\fBinfo \fIoption \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command provides information about various internals of the Tcl
interpreter.
The legal \fIoption\fR's (which may be abbreviated) are:
.TP
\fBinfo args \fIprocname\fR
Returns a list containing the names of the arguments to procedure
\fIprocname\fR, in order. \fIProcname\fR must be the name of a
Tcl command procedure.
.TP
\fBinfo body \fIprocname\fR
Returns the body of procedure \fIprocname\fR. \fIProcname\fR must be
the name of a Tcl command procedure.
.TP
\fBinfo cmdcount\fR
Returns a count of the total number of commands that have been invoked
in this interpreter.
.TP
\fBinfo commands \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified,
returns a list of names of all the Tcl commands in the current namespace,
including both the built-in commands written in C and
the command procedures defined using the \fBproc\fR command.
If \fIpattern\fR is specified,
only those names matching \fIpattern\fR are returned.
Matching is determined using the same rules as for \fBstring match\fR.
\fIpattern\fR can be a qualified name like \fBFoo::print*\fR.
That is, it may specify a particular namespace
using a sequence of namespace names separated by double colons (\fB::\fR),
and may have pattern matching special characters
at the end to specify a set of commands in that namespace.
If \fIpattern\fR is a qualified name,
the resulting list of command names has each one qualified with the name
of the specified namespace.
.TP
\fBinfo complete \fIcommand\fR
Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of
having no unclosed quotes, braces, brackets or array element names.
If the command doesn't appear to be complete then 0 is returned.
This command is typically used in line-oriented input environments
to allow users to type in commands that span multiple lines; if the
command isn't complete, the script can delay evaluating it until additional
lines have been typed to complete the command.
.TP
\fBinfo default \fIprocname arg varname\fR
\fIProcname\fR must be the name of a Tcl command procedure and \fIarg\fR
must be the name of an argument to that procedure. If \fIarg\fR
doesn't have a default value then the command returns \fB0\fR.
Otherwise it returns \fB1\fR and places the default value of \fIarg\fR
into variable \fIvarname\fR.
.TP
\fBinfo exists \fIvarName\fR
Returns \fB1\fR if the variable named \fIvarName\fR exists in the
current context (either as a global or local variable) and has been
defined by being given a value, returns \fB0\fR otherwise.
.VS 8.4
.TP
\fBinfo functions \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the math
functions currently defined.
If \fIpattern\fR is specified, only those functions whose name matches
\fIpattern\fR are returned. Matching is determined using the same
rules as for \fBstring match\fR.
.VE
.TP
\fBinfo globals \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the names
of currently-defined global variables.
Global variables are variables in the global namespace.
If \fIpattern\fR is specified, only those names matching \fIpattern\fR
are returned. Matching is determined using the same rules as for
\fBstring match\fR.
.TP
\fBinfo hostname\fR
Returns the name of the computer on which this invocation is being
executed.
.VS
Note that this name is not guaranteed to be the fully qualified domain
name of the host. Where machines have several different names (as is
common on systems with both TCP/IP (DNS) and NetBIOS-based networking
installed,) it is the name that is suitable for TCP/IP networking that
is returned.
.VE
.TP
\fBinfo level\fR ?\fInumber\fR?
If \fInumber\fR is not specified, this command returns a number
giving the stack level of the invoking procedure, or 0 if the
command is invoked at top-level. If \fInumber\fR is specified,
then the result is a list consisting of the name and arguments for the
procedure call at level \fInumber\fR on the stack. If \fInumber\fR
is positive then it selects a particular stack level (1 refers
to the top-most active procedure, 2 to the procedure it called, and
so on); otherwise it gives a level relative to the current level
(0 refers to the current procedure, -1 to its caller, and so on).
See the \fBuplevel\fR command for more information on what stack
levels mean.
.TP
\fBinfo library\fR
Returns the name of the library directory in which standard Tcl
scripts are stored.
This is actually the value of the \fBtcl_library\fR
variable and may be changed by setting \fBtcl_library\fR.
See the \fBtclvars\fR manual entry for more information.
.TP
\fBinfo loaded \fR?\fIinterp\fR?
Returns a list describing all of the packages that have been loaded into
\fIinterp\fR with the \fBload\fR command.
Each list element is a sub-list with two elements consisting of the
name of the file from which the package was loaded and the name of
the package.
For statically-loaded packages the file name will be an empty string.
If \fIinterp\fR is omitted then information is returned for all packages
loaded in any interpreter in the process.
To get a list of just the packages in the current interpreter, specify
an empty string for the \fIinterp\fR argument.
.TP
\fBinfo locals \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the names
of currently-defined local variables, including arguments to the
current procedure, if any.
Variables defined with the \fBglobal\fR, \fBupvar\fR and
\fBvariable\fR commands will not be returned.
If \fIpattern\fR is specified, only those names matching \fIpattern\fR
are returned. Matching is determined using the same rules as for
\fBstring match\fR.
.TP
\fBinfo nameofexecutable\fR
Returns the full path name of the binary file from which the application
was invoked. If Tcl was unable to identify the file, then an empty
string is returned.
.TP
\fBinfo patchlevel\fR
Returns the value of the global variable \fBtcl_patchLevel\fR; see
the \fBtclvars\fR manual entry for more information.
.TP
\fBinfo procs \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the
names of Tcl command procedures in the current namespace.
If \fIpattern\fR is specified,
only those procedure names in the current namespace
matching \fIpattern\fR are returned.
Matching is determined using the same rules as for
\fBstring match\fR.
If \fIpattern\fR contains any namespace separators, they are used to
select a namespace relative to the current namespace (or relative to
the global namespace if \fIpattern\fR starts with \fB::\fR) to match
within; the matching pattern is taken to be the part after the last
namespace separator.
.TP
\fBinfo script\fR ?\fIfilename\fR?
If a Tcl script file is currently being evaluated (i.e. there is a
call to \fBTcl_EvalFile\fR active or there is an active invocation
of the \fBsource\fR command), then this command returns the name
of the innermost file being processed. If \fIfilename\fR is specified,
then the return value of this command will be modified for the
duration of the active invocation to return that name. This is
useful in virtual file system applications.
Otherwise the command returns an empty string.
.TP
\fBinfo sharedlibextension\fR
Returns the extension used on this platform for the names of files
containing shared libraries (for example, \fB.so\fR under Solaris).
If shared libraries aren't supported on this platform then an empty
string is returned.
.TP
\fBinfo tclversion\fR
Returns the value of the global variable \fBtcl_version\fR; see
the \fBtclvars\fR manual entry for more information.
.TP
\fBinfo vars\fR ?\fIpattern\fR?
If \fIpattern\fR isn't specified,
returns a list of all the names of currently-visible variables.
This includes locals and currently-visible globals.
If \fIpattern\fR is specified, only those names matching \fIpattern\fR
are returned. Matching is determined using the same rules as for
\fBstring match\fR.
\fIpattern\fR can be a qualified name like \fBFoo::option*\fR.
That is, it may specify a particular namespace
using a sequence of namespace names separated by double colons (\fB::\fR),
and may have pattern matching special characters
at the end to specify a set of variables in that namespace.
If \fIpattern\fR is a qualified name,
the resulting list of variable names
has each matching namespace variable qualified with the name
of its namespace.
Note that a currently-visible variable may not yet "exist" if it has not
been set (e.g. a variable declared but not set by \fBvariable\fR).
.SH EXAMPLE
This command prints out a procedure suitable for saving in a Tcl
script:
.CS
proc printProc {procName} {
set result [list proc $procName]
set formals {}
foreach var [\fBinfo args\fR $procName] {
if {[\fBinfo default\fR $procName $var def]} {
lappend formals [list $var $def]
} else {
# Still need the list-quoting because variable
# names may properly contain spaces.
lappend formals [list $var]
}
}
puts [lappend result $formals [\fBinfo body\fR $procName]]
}
.CE
.SH "SEE ALSO"
global(n), proc(n)
.SH KEYWORDS
command, information, interpreter, level, namespace, procedure, variable
'\" Local Variables:
'\" mode: nroff
'\" End:
tcl8.4.20/doc/CrtTimerHdlr.3 0000644 0036047 0045461 00000005344 11737050674 014121 0 ustar dgp 771div '\"
'\" Copyright (c) 1990 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_CreateTimerHandler 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateTimerHandler, Tcl_DeleteTimerHandler \- call a procedure at a
given time
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_TimerToken
\fBTcl_CreateTimerHandler\fR(\fImilliseconds, proc, clientData\fR)
.sp
\fBTcl_DeleteTimerHandler\fR(\fItoken\fR)
.SH ARGUMENTS
.AS Tcl_TimerToken milliseconds
.AP int milliseconds in
How many milliseconds to wait before invoking \fIproc\fR.
.AP Tcl_TimerProc *proc in
Procedure to invoke after \fImilliseconds\fR have elapsed.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.AP Tcl_TimerToken token in
Token for previously-created timer handler (the return value
from some previous call to \fBTcl_CreateTimerHandler\fR).
.BE
.SH DESCRIPTION
.PP
\fBTcl_CreateTimerHandler\fR arranges for \fIproc\fR to be
invoked at a time \fImilliseconds\fR milliseconds in the
future.
The callback to \fIproc\fR will be made by \fBTcl_DoOneEvent\fR,
so \fBTcl_CreateTimerHandler\fR is only useful in programs that
dispatch events through \fBTcl_DoOneEvent\fR or through Tcl commands
such as \fBvwait\fR.
The call to \fIproc\fR may not be made at the exact time given by
\fImilliseconds\fR: it will be made at the next opportunity
after that time. For example, if \fBTcl_DoOneEvent\fR isn't
called until long after the time has elapsed, or if there
are other pending events to process before the call to
\fIproc\fR, then the call to \fIproc\fR will be delayed.
.PP
\fIProc\fR should have arguments and return value that match
the type \fBTcl_TimerProc\fR:
.CS
typedef void Tcl_TimerProc(ClientData \fIclientData\fR);
.CE
The \fIclientData\fR parameter to \fIproc\fR is a
copy of the \fIclientData\fR argument given to
\fBTcl_CreateTimerHandler\fR when the callback
was created. Typically, \fIclientData\fR points to a data
structure containing application-specific information about
what to do in \fIproc\fR.
.PP
\fBTcl_DeleteTimerHandler\fR may be called to delete a
previously-created timer handler. It deletes the handler
indicated by \fItoken\fR so that no call to \fIproc\fR
will be made; if that handler no longer exists
(e.g. because the time period has already elapsed and \fIproc\fR
has been invoked then \fBTcl_DeleteTimerHandler\fR does nothing.
The tokens returned by \fBTcl_CreateTimerHandler\fR never have
a value of NULL, so if NULL is passed to \fBTcl_DeleteTimerHandler\fR
then the procedure does nothing.
.SH KEYWORDS
callback, clock, handler, timer
tcl8.4.20/doc/history.n 0000644 0036047 0045461 00000010136 11737050674 013345 0 ustar dgp 771div '\"
'\" Copyright (c) 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.
'\"
.so man.macros
.TH history n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
history \- Manipulate the history list
.SH SYNOPSIS
\fBhistory \fR?\fIoption\fR? ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBhistory\fR command performs one of several operations related to
recently-executed commands recorded in a history list. Each of
these recorded commands is referred to as an ``event''. When
specifying an event to the \fBhistory\fR command, the following
forms may be used:
.IP [1]
A number: if positive, it refers to the event with
that number (all events are numbered starting at 1). If the number
is negative, it selects an event relative to the current event
(\fB\-1\fR refers to the previous event, \fB\-2\fR to the one before that, and
so on). Event \fB0\fP refers to the current event.
.IP [2]
A string: selects the most recent event that matches the string.
An event is considered to match the string either if the string is
the same as the first characters of the event, or if the string
matches the event in the sense of the \fBstring match\fR command.
.PP
The \fBhistory\fR command can take any of the following forms:
.TP
\fBhistory\fR
Same
as \fBhistory info\fR, described below.
.TP
\fBhistory add\fI command \fR?\fBexec\fR?
Adds the \fIcommand\fR argument to the history list as a new event. If
\fBexec\fR is specified (or abbreviated) then the command is also
executed and its result is returned. If \fBexec\fR isn't specified
then an empty string is returned as result.
.TP
\fBhistory change\fI newValue\fR ?\fIevent\fR?
Replaces the value recorded for an event with \fInewValue\fR. \fIEvent\fR
specifies the event to replace, and
defaults to the \fIcurrent\fR event (not event \fB\-1\fR). This command
is intended for use in commands that implement new forms of history
substitution and wish to replace the current event (which invokes the
substitution) with the command created through substitution. The return
value is an empty string.
.TP
\fBhistory clear\fR
Erase the history list. The current keep limit is retained.
The history event numbers are reset.
.TP
\fBhistory event\fR ?\fIevent\fR?
Returns the value of the event given by \fIevent\fR. \fIEvent\fR
defaults to \fB\-1\fR.
.TP
\fBhistory info \fR?\fIcount\fR?
Returns a formatted string (intended for humans to read) giving
the event number and contents for each of the events in the history
list except the current event. If \fIcount\fR is specified
then only the most recent \fIcount\fR events are returned.
.TP
\fBhistory keep \fR?\fIcount\fR?
This command may be used to change the size of the history list to
\fIcount\fR events. Initially, 20 events are retained in the history
list. If \fIcount\fR is not specified, the current keep limit is returned.
.TP
\fBhistory nextid\fR
Returns the number of the next event to be recorded
in the history list. It is useful for things like printing the
event number in command-line prompts.
.TP
\fBhistory redo \fR?\fIevent\fR?
Re-executes the command indicated by \fIevent\fR and returns its result.
\fIEvent\fR defaults to \fB\-1\fR. This command results in history
revision: see below for details.
.SH "HISTORY REVISION"
.PP
Pre-8.0 Tcl had a complex history revision mechanism.
The current mechanism is more limited, and the old
history operations \fBsubstitute\fP and \fBwords\fP have been removed.
(As a consolation, the \fBclear\fP operation was added.)
.PP
The history option \fBredo\fR results in much simpler ``history revision''.
When this option is invoked then the most recent event
is modified to eliminate the history command and replace it with
the result of the history command.
If you want to redo an event without modifying history, then use
the \fBevent\fP operation to retrieve some event,
and the \fBadd\fP operation to add it to history and execute it.
.SH KEYWORDS
event, history, record
tcl8.4.20/doc/subst.n 0000644 0036047 0045461 00000010756 11737050674 013014 0 ustar dgp 771div '\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH subst n 7.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
subst \- Perform backslash, command, and variable substitutions
.SH SYNOPSIS
\fBsubst \fR?\fB\-nobackslashes\fR? ?\fB\-nocommands\fR? ?\fB\-novariables\fR? \fIstring\fR
.BE
.SH DESCRIPTION
.PP
This command performs variable substitutions, command substitutions,
and backslash substitutions on its \fIstring\fR argument and
returns the fully-substituted result.
The substitutions are performed in exactly the same way as for
Tcl commands.
As a result, the \fIstring\fR argument is actually substituted twice,
once by the Tcl parser in the usual fashion for Tcl commands, and
again by the \fIsubst\fR command.
.PP
If any of the \fB\-nobackslashes\fR, \fB\-nocommands\fR, or
\fB\-novariables\fR are specified, then the corresponding substitutions
are not performed.
For example, if \fB\-nocommands\fR is specified, command substitution
is not performed: open and close brackets are treated as ordinary characters
with no special interpretation.
.PP
.VS 8.4
Note that the substitution of one kind can include substitution of
other kinds. For example, even when the \fB-novariables\fR option
is specified, command substitution is performed without restriction.
This means that any variable substitution necessary to complete the
command substitution will still take place. Likewise, any command
substitution necessary to complete a variable substitution will
take place, even when \fB-nocommands\fR is specified. See the
EXAMPLES below.
.PP
If an error occurs during substitution, then \fBsubst\fR will return
that error. If a break exception occurs during command or variable
substitution, the result of the whole substitution will be the
string (as substituted) up to the start of the substitution that
raised the exception. If a continue exception occurs during the
evaluation of a command or variable substitution, an empty string
will be substituted for that entire command or variable substitution
(as long as it is well-formed Tcl.) If a return exception occurs,
or any other return code is returned during command or variable
substitution, then the returned value is substituted for that
substitution. See the EXAMPLES below. In this way, all exceptional
return codes are ``caught'' by \fBsubst\fR. The \fBsubst\fR command
itself will either return an error, or will complete successfully.
.VE
.SH EXAMPLES
.PP
When it performs its substitutions, \fIsubst\fR does not give any
special treatment to double quotes or curly braces (except within
command substitutions) so the script
.CS
set a 44
\fBsubst\fR {xyz {$a}}
.CE
returns ``\fBxyz {44}\fR'', not ``\fBxyz {$a}\fR''
.VS 8.4
and the script
.CS
set a "p\\} q \\{r"
\fBsubst\fR {xyz {$a}}
.CE
return ``\fBxyz {p} q {r}\fR'', not ``\fBxyz {p\\} q \\{r}\fR''.
.PP
When command substitution is performed, it includes any variable
substitution necessary to evaluate the script.
.CS
set a 44
\fBsubst\fR -novariables {$a [format $a]}
.CE
returns ``\fB$a 44\fR'', not ``\fB$a $a\fR''. Similarly, when
variable substitution is performed, it includes any command
substitution necessary to retrieve the value of the variable.
.CS
proc b {} {return c}
array set a {c c [b] tricky}
\fBsubst\fR -nocommands {[b] $a([b])}
.CE
returns ``\fB[b] c\fR'', not ``\fB[b] tricky\fR''.
.PP
The continue and break exceptions allow command substitutions to
prevent substitution of the rest of the command substitution and the
rest of \fIstring\fR respectively, giving script authors more options
when processing text using \fIsubst\fR. For example, the script
.CS
\fBsubst\fR {abc,[break],def}
.CE
returns ``\fBabc,\fR'', not ``\fBabc,,def\fR'' and the script
.CS
\fBsubst\fR {abc,[continue;expr 1+2],def}
.CE
returns ``\fBabc,,def\fR'', not ``\fBabc,3,def\fR''.
.PP
Other exceptional return codes substitute the returned value
.CS
\fBsubst\fR {abc,[return foo;expr 1+2],def}
.CE
returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR'' and
.CS
\fBsubst\fR {abc,[return -code 10 foo;expr 1+2],def}
.CE
also returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR''.
.VE
.SH "SEE ALSO"
Tcl(n), eval(n), break(n), continue(n)
.SH KEYWORDS
backslash substitution, command substitution, variable substitution
tcl8.4.20/doc/DoubleObj.3 0000644 0036047 0045461 00000005426 11737050674 013424 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_DoubleObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewDoubleObj, Tcl_SetDoubleObj, Tcl_GetDoubleFromObj \- manipulate Tcl objects as floating-point values
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Obj *
\fBTcl_NewDoubleObj\fR(\fIdoubleValue\fR)
.sp
\fBTcl_SetDoubleObj\fR(\fIobjPtr, doubleValue\fR)
.sp
int
\fBTcl_GetDoubleFromObj\fR(\fIinterp, objPtr, doublePtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp doubleValue in/out
.AP double doubleValue in
A double-precision floating point value used to initialize or set a double object.
.AP Tcl_Obj *objPtr in/out
For \fBTcl_SetDoubleObj\fR, this points to the object to be converted
to double type.
For \fBTcl_GetDoubleFromObj\fR, this refers to the object
from which to get a double value;
if \fIobjPtr\fR does not already point to a double object,
an attempt will be made to convert it to one.
.AP Tcl_Interp *interp in/out
If an error occurs during conversion,
an error message is left in the interpreter's result object
unless \fIinterp\fR is NULL.
.AP double *doublePtr out
Points to place to store the double value
obtained from \fIobjPtr\fR.
.BE
.SH DESCRIPTION
.PP
These procedures are used to create, modify, and read
double Tcl objects from C code.
\fBTcl_NewDoubleObj\fR and \fBTcl_SetDoubleObj\fR
will create a new object of double type
or modify an existing object to have double type.
Both of these procedures set the object to have the
double-precision floating point value given by \fIdoubleValue\fR;
\fBTcl_NewDoubleObj\fR returns a pointer to a newly created object
with reference count zero.
Both procedures set the object's type to be double
and assign the double value to the object's internal representation
\fIdoubleValue\fR member.
\fBTcl_SetDoubleObj\fR invalidates any old string representation
and, if the object is not already a double object,
frees any old internal representation.
.PP
\fBTcl_GetDoubleFromObj\fR attempts to return a double value
from the Tcl object \fIobjPtr\fR.
If the object is not already a double object,
it will attempt to convert it to one.
If an error occurs during conversion, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
unless \fIinterp\fR is NULL.
Otherwise, it returns \fBTCL_OK\fR and stores the double value
in the address given by \fIdoublePtr\fR.
If the object is not already a double object,
the conversion will free any old internal representation.
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult
.SH KEYWORDS
double, double object, double type, internal representation, object, object type, string representation
tcl8.4.20/doc/FindExec.3 0000644 0036047 0045461 00000003637 11737050674 013246 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH Tcl_FindExecutable 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_FindExecutable, Tcl_GetNameOfExecutable \- identify or return the name of the binary file containing the application
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
void
\fBTcl_FindExecutable\fR(\fIargv0\fR)
.sp
CONST char *
\fBTcl_GetNameOfExecutable\fR()
.SH ARGUMENTS
.AS char *argv0 in
.AP char *argv0 in
The first command-line argument to the program, which gives the
application's name.
.BE
.SH DESCRIPTION
.PP
The \fBTcl_FindExecutable\fR procedure computes the full path name of
the executable file from which the application was invoked and saves
it for Tcl's internal use.
The executable's path name is needed for several purposes in
Tcl. For example, it is needed on some platforms in the
implementation of the \fBload\fR command.
It is also returned by the \fBinfo nameofexecutable\fR command.
.PP
On UNIX platforms this procedure is typically invoked as the very
first thing in the application's main program; it must be passed
\fIargv[0]\fR as its argument. It is important not to change the
working directory before the invocation.
\fBTcl_FindExecutable\fR uses \fIargv0\fR
along with the \fBPATH\fR environment variable to find the
application's executable, if possible. If it fails to find
the binary, then future calls to \fBinfo nameofexecutable\fR
will return an empty string.
.PP
\fBTcl_GetNameOfExecutable\fR simply returns a pointer to the
internal full path name of the executable file as computed by
\fBTcl_FindExecutable\fR. This procedure call is the C API
equivalent to the \fBinfo nameofexecutable\fR command. NULL
is returned if the internal full path name has not been
computed or unknown.
.SH KEYWORDS
binary, executable file
tcl8.4.20/doc/close.n 0000644 0036047 0045461 00000005520 11737050674 012752 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH close n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
close \- Close an open channel.
.SH SYNOPSIS
\fBclose \fIchannelId\fR
.BE
.SH DESCRIPTION
.PP
Closes the channel given by \fIchannelId\fR.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.VE
.PP
All buffered output is flushed to the channel's output device,
any buffered input is discarded, the underlying file or device is closed,
and \fIchannelId\fR becomes unavailable for use.
.VS "" br
.PP
If the channel is blocking, the command does not return until all output
is flushed.
If the channel is nonblocking and there is unflushed output, the
channel remains open and the command
returns immediately; output will be flushed in the background and the
channel will be closed when all the flushing is complete.
.VE
.PP
If \fIchannelId\fR is a blocking channel for a command pipeline then
\fBclose\fR waits for the child processes to complete.
.VS "" br
.PP
If the channel is shared between interpreters, then \fBclose\fR
makes \fIchannelId\fR unavailable in the invoking interpreter but has no
other effect until all of the sharing interpreters have closed the
channel.
When the last interpreter in which the channel is registered invokes
\fBclose\fR, the cleanup actions described above occur. See the
\fBinterp\fR command for a description of channel sharing.
.PP
Channels are automatically closed when an interpreter is destroyed and
when the process exits. Channels are switched to blocking mode, to ensure
that all output is correctly flushed before the process exits.
.VE
.PP
The command returns an empty string, and may generate an error if
an error occurs while flushing output. If a command in a command
pipeline created with \fBopen\fR returns an error, \fBclose\fR
generates an error (similar to the \fBexec\fR command.)
.SH EXAMPLE
This illustrates how you can use Tcl to ensure that files get closed
even when errors happen by combining \fBcatch\fR, \fBclose\fR and
\fBreturn\fR:
.CS
proc withOpenFile {filename channelVar script} {
upvar 1 $channelVar chan
set chan [open $filename]
catch {
uplevel 1 $script
} result options
\fBclose\fR $chan
return -options $options $result
}
.CE
.SH "SEE ALSO"
file(n), open(n), socket(n), eof(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, channel, close, nonblocking
tcl8.4.20/doc/clock.n 0000644 0036047 0045461 00000023643 11737050674 012746 0 ustar dgp 771div '\"
'\" Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
'\" Copyright (c) 1995-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\" Copyright (c) 2002 ActiveState Corporation
'\"
'\" This documentation is derived from the time and date facilities of
'\" TclX, by Mark Diekhans and Karl Lehenbauer.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH clock n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
clock \- Obtain and manipulate time
.SH SYNOPSIS
\fBclock \fIoption\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command performs one of several operations that may obtain
or manipulate strings or values that represent some notion of
time. The \fIoption\fR argument determines what action is carried
out by the command. The legal \fIoptions\fR (which may be
abbreviated) are:
.VS 8.3
.TP
\fBclock clicks\fR ?\fB\-milliseconds\fR?
Return a high-resolution time value as a system-dependent integer
value. The unit of the value is system-dependent but should be the
highest resolution clock available on the system such as a CPU cycle
counter. If \fB\-milliseconds\fR is specified, then the value is
guaranteed to be of millisecond granularity.
This value should only be used for the relative measurement
of elapsed time.
.VE 8.3
.TP
\fBclock format \fIclockValue\fR ?\fB\-format \fIstring\fR? ?\fB\-gmt \fIboolean\fR?
Converts an integer time value, typically returned by
\fBclock seconds\fR, \fBclock scan\fR, or the \fBatime\fR or \fBmtime\fR
options of the \fBfile\fR command, to human-readable
form. If the \fB\-format\fR argument is present the next argument is a
string that describes how the date and time are to be formatted.
Field descriptors consist of a \fB%\fR followed by a field
descriptor character. All other characters are copied into the result.
Valid field descriptors are:
.RS
.IP \fB%%\fR
Insert a %.
.IP \fB%a\fR
Abbreviated weekday name (Mon, Tue, etc.).
.IP \fB%A\fR
Full weekday name (Monday, Tuesday, etc.).
.IP \fB%b\fR
Abbreviated month name (Jan, Feb, etc.).
.IP \fB%B\fR
Full month name.
.VS 8.4
.IP \fB%c\fR
Locale specific date and time. The format for date and time
in the default "C" locale on Unix/Mac is "%a %b %d %H:%M:%S %Y".
On Windows, this value is the locale specific long date and time, as
specified in the Regional Options control panel settings.
.IP \fB%C\fR
First two digits of the four-digit year (19 or 20).
.VE 8.4
.IP \fB%d\fR
Day of month (01 - 31).
.VS 8.4
'\" Since the inclusion of compat/strftime.c, %D, %e, %h should work on all
'\" platforms.
.IP \fB%D\fR
Date as %m/%d/%y.
.IP \fB%e\fR
Day of month (1 - 31), no leading zeros.
.IP \fB%g\fR
The ISO8601 year number corresponding to the ISO8601 week (%V), expressed
as a two-digit year-of-the-century, with leading zero if necessary.
.IP \fB%G\fR
The ISO8601 year number corresponding to the ISO8601 week (%V), expressed
as a four-digit number.
.IP \fB%h\fR
Abbreviated month name.
.VE 8.4
.IP \fB%H\fR
Hour in 24-hour format (00 - 23).
.VS 8.4
.IP \fB%I\fR
Hour in 12-hour format (01 - 12).
.VE 8.4
.IP \fB%j\fR
Day of year (001 - 366).
.VS 8.4
.IP \fB%k\fR
Hour in 24-hour format, without leading zeros (0 - 23).
.IP \fB%l\fR
Hour in 12-hour format, without leading zeros (1 - 12).
.VE 8.4
.IP \fB%m\fR
Month number (01 - 12).
.IP \fB%M\fR
Minute (00 - 59).
.VS 8.4
.IP \fB%n\fR
Insert a newline.
.VE 8.4
.IP \fB%p\fR
AM/PM indicator.
.VS 8.4
.IP \fB%r\fR
Time in a locale-specific "meridian" format. The "meridian"
format in the default "C" locale is "%I:%M:%S %p".
.IP \fB%R\fR
Time as %H:%M.
.IP \fB%s\fR
Count of seconds since the epoch, expressed as a decimal integer.
.VE 8.4
.IP \fB%S\fR
Seconds (00 - 59).
.VS 8.4
.IP \fB%t\fR
Insert a tab.
.IP \fB%T\fR
Time as %H:%M:%S.
.IP \fB%u\fR
Weekday number (Monday = 1, Sunday = 7).
.VE 8.4
.IP \fB%U\fR
Week of year (00 - 52), Sunday is the first day of the week.
.VS 8.4
.IP \fB%V\fR
Week of year according to ISO-8601 rules. Week 1 of a given
year is the week containing 4 January.
.IP \fB%w\fR
Weekday number (Sunday = 0, Saturday = 6).
.VE 8.4
.IP \fB%W\fR
Week of year (00 - 52), Monday is the first day of the week.
.VS 8.4
.IP \fB%x\fR
Locale specific date format. The format for a date in the default "C"
locale for Unix/Mac is "%m/%d/%y".
On Windows, this value is the locale specific short date format, as
specified in the Regional Options control panel settings.
.IP \fB%X\fR
Locale specific 24-hour time format. The format for a
24-hour time in the default "C" locale for Unix/Mac is "%H:%M:%S".
On Windows, this value is the locale specific time format, as
specified in the Regional Options control panel settings.
.VE 8.4
.IP \fB%y\fR
Year without century (00 - 99).
.IP \fB%Y\fR
Year with century (e.g. 1990)
.IP \fB%Z\fR
Time zone name.
.RE
.VS 8.4
.sp
'\" All the field descriptors should be portable now that
'\" compat/strftime.c is in place, with the possible exception
'\" of the time zone name.
'\".RS
'\"In addition, the following field descriptors may be supported on some
'\"systems (e.g. Unix but not Windows):
'\".IP \fB%D\fR
'\"Date as %m/%d/%y.
'\".IP \fB%e\fR
'\"Day of month (1 - 31), no leading zeros.
'\".IP \fB%h\fR
'\"Abbreviated month name.
'\".IP \fB%n\fR
'\"Insert a newline.
'\".IP \fB%r\fR
'\"Time as %I:%M:%S %p.
'\".IP \fB%R\fR
'\"Time as %H:%M.
'\".IP \fB%t\fR
'\"Insert a tab.
'\".IP \fB%T\fR
'\"Time as %H:%M:%S.
'\".RE
'\".sp
.VE 8.4
.RS
If the \fB\-format\fR argument is not specified, the format string
\fB"%a %b %d %H:%M:%S %Z %Y"\fR is used. If the \fB\-gmt\fR argument
is present the next argument must be a boolean which if true specifies
that the time will be formatted as Greenwich Mean Time. If false
then the local timezone will be used as defined by the operating
environment.
.RE
.TP
\fBclock scan \fIdateString\fR ?\fB\-base \fIclockVal\fR? ?\fB\-gmt \fIboolean\fR?
Convert \fIdateString\fR to an integer clock value (see \fBclock seconds\fR).
This command can parse and convert virtually any standard date and/or time
string, which can include standard time zone mnemonics. If only a time is
specified, the current date is assumed. If the string does not contain a
time zone mnemonic, the local time zone is assumed, unless the \fB\-gmt\fR
argument is true, in which case the clock value is calculated assuming
that the specified time is relative to Greenwich Mean Time.
\fB-gmt\fR, if specified, affects only the computed time value; it does not
impact the interpretation of \fB-base\fR.
.sp
If the \fB\-base\fR flag is specified, the next argument should contain
an integer clock value. Only the date in this value is used, not the
time. This is useful for determining the time on a specific day or
doing other date-relative conversions.
.sp
The \fIdateString\fR consists of zero or more specifications of the
following form:
.RS
.TP
\fItime\fR
A time of day, which is of the form: \fIhh\fR?\fI:mm\fR?\fI:ss\fR??
?\fImeridian\fR? ?\fIzone\fR? or \fIhhmm \fR?\fImeridian\fR?
?\fIzone\fR?. If no meridian is specified, \fIhh\fR is interpreted on
a 24-hour clock.
.TP
\fIdate\fR
A specific month and day with optional year. The
acceptable formats are \fImm/dd\fR?\fI/yy\fR?, \fImonthname dd\fR
?, \fIyy\fR?, \fIdd monthname \fR?\fIyy\fR?, \fIday, dd monthname
yy\fR, \fI?CC?yymmdd\fR, \fI?CC?yy-mm-dd\fR, \fIdd-monthname-?CC?yy\fR.
The default year is the current year. If the year is less
.VS
than 100, we treat the years 00-68 as 2000-2068 and the years 69-99
as 1969-1999. Not all platforms can represent the years 38-70, so
an error may result if these years are used.
.VE
.TP
\fIISO 8601 point-in-time\fR
An ISO 8601 point-in-time specification, such as \fICCyymmddThhmmss\fR, where
T is the literal T, \fICCyymmdd hhmmss\fR, or
\fICCyymmddThh:mm:ss\fR. Note that only these three formats are accepted.
The command does \fInot\fR accept the full range of point-in-time
specifications specified in ISO8601. Other formats can be recognized by
using commands such as \fBregexp\fR to extract their fields and reorganize
them into a form accepted by the \fBclock scan\fR command.
.TP
\fIrelative time\fR
A specification relative to the current time. The format is \fInumber
unit\fR acceptable units are \fByear\fR, \fBfortnight\fR, \fBmonth\fR, \fBweek\fR, \fBday\fR,
\fBhour\fR, \fBminute\fR (or \fBmin\fR), and \fBsecond\fR (or \fBsec\fR). The
unit can be specified as a singular or plural, as in \fB3 weeks\fR.
These modifiers may also be specified:
\fBtomorrow\fR, \fByesterday\fR, \fBtoday\fR, \fBnow\fR,
\fBlast\fR, \fBthis\fR, \fBnext\fR, \fBago\fR.
.RE
.sp
.RS
The actual date is calculated according to the following steps.
First, any absolute date and/or time is processed and converted.
Using that time as the base, day-of-week specifications are added.
Next, relative specifications are used. If a date or day is
specified, and no absolute or relative time is given, midnight is
used. Finally, a correction is applied so that the correct hour of
the day is produced after allowing for daylight savings time
differences and the correct date is given when going from the end
of a long month to a short month.
.sp
Daylight savings time correction is applied only when the relative time
is specified in units of days or more, ie, days, weeks, fortnights, months or
years. This means that when crossing the daylight savings time boundary,
different results will be given for \fBclock scan "1 day"\fR and
\fBclock scan "24 hours"\fR:
.CS
.ta 6c
% \fBclock scan\fR "1 day" -base [\fBclock scan\fR 1999-10-31]
941443200
% \fBclock scan\fR "24 hours" -base [\fBclock scan\fR 1999-10-31]
941439600
.CE
.RE
.TP
\fBclock seconds\fR
Return the current date and time as a system-dependent integer value. The
unit of the value is seconds, allowing it to be used for relative time
calculations. The value is usually defined as total elapsed time from
an ``epoch''. You shouldn't assume the value of the epoch.
.SH "SEE ALSO"
date(1), time(n)
.SH KEYWORDS
clock, date, time
tcl8.4.20/doc/if.n 0000644 0036047 0045461 00000004460 11737050674 012245 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH if n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
if \- Execute scripts conditionally
.SH SYNOPSIS
\fBif \fIexpr1 \fR?\fBthen\fR? \fIbody1 \fBelseif \fIexpr2 \fR?\fBthen\fR? \fIbody2\fR \fBelseif\fR ... ?\fBelse\fR? ?\fIbodyN\fR?
.BE
.SH DESCRIPTION
.PP
The \fIif\fR command evaluates \fIexpr1\fR as an expression (in the
same way that \fBexpr\fR evaluates its argument). The value of the
expression must be a boolean
(a numeric value, where 0 is false and
anything is true, or a string value such as \fBtrue\fR or \fByes\fR
for true and \fBfalse\fR or \fBno\fR for false);
if it is true then \fIbody1\fR is executed by passing it to the
Tcl interpreter.
Otherwise \fIexpr2\fR is evaluated as an expression and if it is true
then \fBbody2\fR is executed, and so on.
If none of the expressions evaluates to true then \fIbodyN\fR is
executed.
The \fBthen\fR and \fBelse\fR arguments are optional
``noise words'' to make the command easier to read.
There may be any number of \fBelseif\fR clauses, including zero.
\fIBodyN\fR may also be omitted as long as \fBelse\fR is omitted too.
The return value from the command is the result of the body script
that was executed, or an empty string
if none of the expressions was non-zero and there was no \fIbodyN\fR.
.SH EXAMPLES
A simple conditional:
.CS
\fBif\fR {$vbl == 1} { puts "vbl is one" }
.CE
.PP
With an \fBelse\fR-clause:
.CS
\fBif\fR {$vbl == 1} {
puts "vbl is one"
} \fBelse\fR {
puts "vbl is not one"
}
.CE
.PP
With an \fBelseif\fR-clause too:
.CS
\fBif\fR {$vbl == 1} {
puts "vbl is one"
} \fBelseif\fR {$vbl == 2} {
puts "vbl is two"
} \fBelse\fR {
puts "vbl is not one or two"
}
.CE
.PP
Remember, expressions can be multi-line, but in that case it can be a
good idea to use the optional \fBthen\fR keyword for clarity:
.CS
\fBif\fR {
$vbl == 1 || $vbl == 2 || $vbl == 3
} \fBthen\fR {
puts "vbl is one, two or three"
}
.CE
.SH "SEE ALSO"
expr(n), for(n), foreach(n)
.SH KEYWORDS
boolean, conditional, else, false, if, true
tcl8.4.20/doc/PkgRequire.3 0000644 0036047 0045461 00000005531 11737050674 013632 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_PkgRequire 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_PkgRequire, Tcl_PkgRequireEx, Tcl_PkgPresent, Tcl_PkgPresentEx, Tcl_PkgProvide, Tcl_PkgProvideEx \- package version control
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
CONST char *
\fBTcl_PkgRequire\fR(\fIinterp, name, version, exact\fR)
.sp
CONST char *
\fBTcl_PkgRequireEx\fR(\fIinterp, name, version, exact, clientDataPtr\fR)
.sp
CONST char *
\fBTcl_PkgPresent\fR(\fIinterp, name, version, exact\fR)
.sp
CONST char *
\fBTcl_PkgPresentEx\fR(\fIinterp, name, version, exact, clientDataPtr\fR)
.sp
int
\fBTcl_PkgProvide\fR(\fIinterp, name, version\fR)
.sp
int
\fBTcl_PkgProvideEx\fR(\fIinterp, name, version, clientData\fR)
.SH ARGUMENTS
.AS ClientData clientDataPtr
.AP Tcl_Interp *interp in
Interpreter where package is needed or available.
.AP "CONST char" *name in
Name of package.
.AP "CONST char" *version in
A version string consisting of one or more decimal numbers
separated by dots.
.AP int exact in
Non-zero means that only the particular version specified by
\fIversion\fR is acceptable.
Zero means that newer versions than \fIversion\fR are also
acceptable as long as they have the same major version number
as \fIversion\fR.
.AP ClientData clientData in
Arbitrary value to be associated with the package.
.AP ClientData *clientDataPtr out
Pointer to place to store the value associated with the matching
package. It is only changed if the pointer is not NULL and the
function completed successfully.
.BE
.SH DESCRIPTION
.PP
These procedures provide C-level interfaces to Tcl's package and
version management facilities.
.PP
\fBTcl_PkgRequire\fR is equivalent to the \fBpackage require\fR
command, \fBTcl_PkgPresent\fR is equivalent to the \fBpackage present\fR
command, and \fBTcl_PkgProvide\fR is equivalent to the
\fBpackage provide\fR command.
.PP
See the documentation for the Tcl commands for details on what these
procedures do.
.PP
If \fBTcl_PkgPresent\fR or \fBTcl_PkgRequire\fR complete successfully
they return a pointer to the version string for the version of the package
that is provided in the interpreter (which may be different than
\fIversion\fR); if an error occurs they return NULL and leave an error
message in the interpreter's result.
.PP
\fBTcl_PkgProvide\fR returns TCL_OK if it completes successfully;
if an error occurs it returns TCL_ERROR and leaves an error message
in the interpreter's result.
.PP
\fBTcl_PkgProvideEx\fR, \fBTcl_PkgPresentEx\fR and \fBTcl_PkgRequireEx\fR
allow the setting and retrieving of the client data associated with
the package. In all other respects they are equivalent to the matching
functions.
.SH KEYWORDS
package, present, provide, require, version
tcl8.4.20/doc/InitStubs.3 0000644 0036047 0045461 00000006603 12133546537 013500 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_InitStubs 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_InitStubs \- initialize the Tcl stubs mechanism
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
CONST char *
\fBTcl_InitStubs\fR(\fIinterp, version, exact\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp in
.AP Tcl_Interp *interp in
Tcl interpreter handle.
.AP "CONST char" *version in
A version string consisting of one or more decimal numbers
separated by dots.
.AP int exact in
Non-zero means that only the particular version specified by
\fIversion\fR is acceptable.
Zero means that versions newer than \fIversion\fR are also
acceptable as long as they have the same major version number
as \fIversion\fR.
.BE
.SH INTRODUCTION
.PP
The Tcl stubs mechanism defines a way to dynamically bind
extensions to a particular Tcl implementation at run time.
This provides two significant benefits to Tcl users:
.IP 1) 5
Extensions that use the stubs mechanism can be loaded into
multiple versions of Tcl without being recompiled or
relinked.
.IP 2) 5
Extensions that use the stubs mechanism can be dynamically
loaded into statically-linked Tcl applications.
.PP
The stubs mechanism accomplishes this by exporting function tables
that define an interface to the Tcl API. The extension then accesses
the Tcl API through offsets into the function table, so there are no
direct references to any of the Tcl library's symbols. This
redirection is transparent to the extension, so an extension writer
can continue to use all public Tcl functions as documented.
.PP
The stubs mechanism requires no changes to applications incorporating
Tcl interpreters. Only developers creating C-based Tcl extensions
need to take steps to use the stubs mechanism with their extensions.
.PP
Enabling the stubs mechanism for an extension requires the following
steps:
.IP 1) 5
Call \fBTcl_InitStubs\fR in the extension before calling any other
Tcl functions.
.IP 2) 5
Define the USE_TCL_STUBS symbol. Typically, you would include the
-DUSE_TCL_STUBS flag when compiling the extension.
.IP 3) 5
Link the extension with the Tcl stubs library instead of the standard
Tcl library. On Unix platforms, the library name is
\fIlibtclstub8.4.a\fR; on Windows platforms, the library name is
\fItclstub84.lib\fR.
.PP
If the extension also requires the Tk API, it must also call
\fBTk_InitStubs\fR to initialize the Tk stubs interface and link
with the Tk stubs libraries. See the \fBTk_InitStubs\fR page for
more information.
.SH DESCRIPTION
\fBTcl_InitStubs\fR attempts to initialize the stub table pointers
and ensure that the correct version of Tcl is loaded. In addition
to an interpreter handle, it accepts as arguments a version number
and a Boolean flag indicating whether the extension requires
an exact version match or not. If \fIexact\fR is 0, then the
extension is indicating that newer versions of Tcl are acceptable
as long as they have the same major version number as \fIversion\fR;
non-zero means that only the specified \fIversion\fR is acceptable.
\fBTcl_InitStubs\fR returns a string containing the actual version
of Tcl satisfying the request, or NULL if the Tcl version is not
acceptable, does not support stubs, or any other error condition occurred.
.SH "SEE ALSO"
Tk_InitStubs
.SH KEYWORDS
stubs
tcl8.4.20/doc/msgcat.n 0000644 0036047 0045461 00000026165 12052456743 013131 0 ustar dgp 771div '\"
'\" Copyright (c) 1998 Mark Harrison.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH "msgcat" n 1.3 msgcat "Tcl Bundled Packages"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
msgcat \- Tcl message catalog
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require msgcat 1.3.5\fR
.sp
\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
.sp
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
.sp
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.sp
\fB::msgcat::mcpreferences\fR
.sp
\fB::msgcat::mcload \fIdirname\fR
.sp
\fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR?
.sp
\fB::msgcat::mcmset \fIlocale src-trans-list\fR
.sp
\fB::msgcat::mcunknown \fIlocale src-string\fR
.BE
.SH DESCRIPTION
.PP
The \fBmsgcat\fR package provides a set of functions
that can be used to manage multi-lingual user interfaces.
Text strings are defined in a ``message catalog'' which
is independent from the application, and
which can be edited or localized without modifying
the application source code. New languages
or locales are provided by adding a new file to
the message catalog.
.PP
Use of the message catalog is optional by any application
or package, but is encouraged if the application or package
wishes to be enabled for multi-lingual applications.
.SH COMMANDS
.TP
\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
Returns a translation of \fIsrc-string\fR according to the
user's current locale. If additional arguments past \fIsrc-string\fR
are given, the \fBformat\fR command is used to substitute the
additional arguments in the translation of \fIsrc-string\fR.
.PP
\fB::msgcat::mc\fR will search the messages defined
in the current namespace for a translation of \fIsrc-string\fR; if
none is found, it will search in the parent of the current namespace,
and so on until it reaches the global namespace. If no translation
string exists, \fB::msgcat::mcunknown\fR is called and the string
returned from \fB::msgcat::mcunknown\fR is returned.
.PP
\fB::msgcat::mc\fR is the main function used to localize an
application. Instead of using an English string directly, an
application can pass the English string through \fB::msgcat::mc\fR and
use the result. If an application is written for a single language in
this fashion, then it is easy to add support for additional languages
later simply by defining new message catalog entries.
.TP
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
Given several source strings, \fB::msgcat::mcmax\fR returns the length
of the longest translated string. This is useful when designing
localized GUIs, which may require that all buttons, for example, be a
fixed width (which will be the width of the widest button).
.TP
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR
is omitted, the current locale is returned, otherwise the current locale
is set to \fInewLocale\fR. msgcat stores and compares the locale in a
case-insensitive manner, and returns locales in lowercase.
The initial locale is determined by the locale specified in
the user's environment. See \fBLOCALE SPECIFICATION\fR
below for a description of the locale string format.
.TP
\fB::msgcat::mcpreferences\fR
Returns an ordered list of the locales preferred by
the user, based on the user's language specification.
The list is ordered from most specific to least
preference. The list is derived from the current
locale set in msgcat by \fB::msgcat::mclocale\fR, and
cannot be set independently. For example, if the
current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR
returns \fB{en_US_funky en_US en}\fR.
.TP
\fB::msgcat::mcload \fIdirname\fR
Searches the specified directory for files that match
the language specifications returned by \fB::msgcat::mcpreferences\fR
(note that these are all lowercase), extended by the file
extension ``.msg''. Each matching file is
read in order, assuming a UTF-8 encoding. The file contents are
then evaluated as a Tcl script. This means that Unicode characters
may be present in the message file either directly in their UTF-8
encoded form, or by use of the backslash-u quoting recognized by Tcl
evaluation. The number of message files which matched the specification
and were loaded is returned.
.TP
\fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR?
Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR
in the specified \fIlocale\fR and the current namespace. If
\fItranslate-string\fR is not specified, \fIsrc-string\fR is used
for both. The function returns \fItranslate-string\fR.
.TP
\fB::msgcat::mcmset \fIlocale src-trans-list\fR
Sets the translation for multiple source strings in
\fIsrc-trans-list\fR in the specified \fIlocale\fR and the current
namespace.
\fIsrc-trans-list\fR must have an even number of elements and is in
the form {\fIsrc-string translate-string\fR ?\fIsrc-string
translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly
faster than multiple invocations of \fB::msgcat::mcset\fR. The function
returns the number of translations set.
.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR
This routine is called by \fB::msgcat::mc\fR in the case when
a translation for \fIsrc-string\fR is not defined in the
current locale. The default action is to return
\fIsrc-string\fR. This procedure can be redefined by the
application, for example to log error messages for each unknown
string. The \fB::msgcat::mcunknown\fR procedure is invoked at the
same stack context as the call to \fB::msgcat::mc\fR. The return value
of \fB::msgcat::mcunknown\fR is used as the return value for the call
to \fB::msgcat::mc\fR.
.SH "LOCALE SPECIFICATION"
.PP
The locale is specified to \fBmsgcat\fR by a locale string
passed to \fB::msgcat::mclocale\fR.
The locale string consists of
a language code, an optional country code, and an optional
system-specific code, each separated by ``_''. The country and language
codes are specified in standards ISO-639 and ISO-3166.
For example, the locale ``en'' specifies English and ``en_US'' specifies
U.S. English.
.PP
When the msgcat package is first loaded, the locale is initialized
according to the user's environment. The variables \fBenv(LC_ALL)\fR,
\fBenv(LC_MESSAGES)\fR, and \fBenv(LANG)\fR are examined in order.
The first of them to have a non-empty value is used to determine the
initial locale. The value is parsed according to the XPG4 pattern
.CS
language[_country][.codeset][@modifier]
.CE
to extract its parts. The initial locale is then set by calling
\fB::msgcat::mclocale\fR with the argument
.CS
language[_country][_modifier]
.CE
On Windows, if none of those environment variables is set, msgcat will
attempt to extract locale information from the
registry. If all these attempts to discover an initial locale
from the user's environment fail, msgcat defaults to an initial
locale of ``C''.
.PP
When a locale is specified by the user, a ``best match'' search is
performed during string translation. For example, if a user specifies
en_GB_Funky, the locales ``en_GB_Funky'', ``en_GB'', and ``en'' are
searched in order until a matching translation string is found. If no
translation string is available, then \fB::msgcat::mcunknown\fR is
called.
.SH "NAMESPACES AND MESSAGE CATALOGS"
.PP
Strings stored in the message catalog are stored relative
to the namespace from which they were added. This allows
multiple packages to use the same strings without fear
of collisions with other packages. It also allows the
source string to be shorter and less prone to typographical
error.
.PP
For example, executing the code
.CS
\fB::msgcat::mcset\fR en hello "hello from ::"
namespace eval foo {
\fB::msgcat::mcset\fR en hello "hello from ::foo"
}
puts [\fB::msgcat::mc\fR hello]
namespace eval foo {puts [\fB::msgcat::mc\fR hello]}
.CE
will print
.CS
hello from ::
hello from ::foo
.CE
.PP
When searching for a translation of a message, the
message catalog will search first the current namespace,
then the parent of the current namespace, and so on until
the global namespace is reached. This allows child namespaces
to "inherit" messages from their parent namespace.
.PP
For example, executing (in the ``en'' locale) the code
.CS
\fB::msgcat::mcset\fR en m1 ":: message1"
\fB::msgcat::mcset\fR en m2 ":: message2"
\fB::msgcat::mcset\fR en m3 ":: message3"
namespace eval ::foo {
\fB::msgcat::mcset\fR en m2 "::foo message2"
\fB::msgcat::mcset\fR en m3 "::foo message3"
}
namespace eval ::foo::bar {
\fB::msgcat::mcset\fR en m3 "::foo::bar message3"
}
namespace import \fB::msgcat::mc\fR
puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]"
namespace eval ::foo {puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]"}
namespace eval ::foo::bar {puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]"}
.CE
will print
.CS
:: message1; :: message2; :: message3
:: message1; ::foo message2; ::foo message3
:: message1; ::foo message2; ::foo::bar message3
.CE
.SH "LOCATION AND FORMAT OF MESSAGE FILES"
.PP
Message files can be located in any directory, subject
to the following conditions:
.IP [1]
All message files for a package are in the same directory.
.IP [2]
The message file name is a msgcat locale specifier (all lowercase)
followed by ``.msg''. For example:
.CS
es.msg -- spanish
en_gb.msg -- United Kingdom English
.CE
.IP [3]
The file contains a series of calls to \fBmcset\fR and
\fBmcmset\fR, setting the necessary translation strings
for the language, likely enclosed in a \fBnamespace eval\fR
so that all source strings are tied to the namespace of
the package. For example, a short \fBes.msg\fR might contain:
.CS
namespace eval ::mypackage {
\fB::msgcat::mcset\fR es "Free Beer!" "Cerveza Gracias!"
}
.CE
.SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES"
.PP
If a package is installed into a subdirectory of the
\fBtcl_pkgPath\fR and loaded via \fBpackage require\fR, the
following procedure is recommended.
.IP [1]
During package installation, create a subdirectory
\fBmsgs\fR under your package directory.
.IP [2]
Copy your *.msg files into that directory.
.IP [3]
Add the following command to your package
initialization script:
.CS
# load language files, stored in msgs subdirectory
\fB::msgcat::mcload\fR [file join [file dirname [info script]] msgs]
.CE
.SH "POSITIONAL CODES FOR FORMAT AND SCAN COMMANDS"
.PP
It is possible that a message string used as an argument
to \fBformat\fR might have positionally dependent parameters that
might need to be repositioned. For example, it might be
syntactically desirable to rearrange the sentence structure
while translating.
.CS
format "We produced %d units in location %s" $num $city
format "In location %s we produced %d units" $city $num
.CE
.PP
This can be handled by using the positional
parameters:
.CS
format "We produced %1\\$d units in location %2\\$s" $num $city
format "In location %2\\$s we produced %1\\$d units" $num $city
.CE
.PP
Similarly, positional parameters can be used with \fBscan\fR to
extract values from internationalized strings.
.SH CREDITS
.PP
The message catalog code was developed by Mark Harrison.
.SH "SEE ALSO"
format(n), scan(n), namespace(n), package(n)
.SH KEYWORDS
internationalization, i18n, localization, l10n, message, text, translation
tcl8.4.20/doc/eval.n 0000644 0036047 0045461 00000002740 11737050674 012575 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH eval n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
eval \- Evaluate a Tcl script
.SH SYNOPSIS
\fBeval \fIarg \fR?\fIarg ...\fR?
.BE
.SH DESCRIPTION
.PP
\fBEval\fR takes one or more arguments, which together comprise a Tcl
script containing one or more commands.
\fBEval\fR concatenates all its arguments in the same
fashion as the \fBconcat\fR command, passes the concatenated string to the
Tcl interpreter recursively, and returns the result of that
evaluation (or any error generated by it).
Note that the \fBlist\fR command quotes sequences of words in such a
way that they are not further expanded by the \fBeval\fR command.
.SH EXAMPLE
This procedure acts in a way that is analogous to the \fBlappend\fR
command, except it inserts the argument values at the start of the
list in the variable:
.CS
proc lprepend {varName args} {
upvar 1 $varName var
# Ensure that the variable exists and contains a list
lappend var
# Now we insert all the arguments in one go
set var [\fBeval\fR [list linsert $var 0] $args]
}
.CE
.SH KEYWORDS
concatenate, evaluate, script
.SH "SEE ALSO"
catch(n), concat(n), error(n), list(n), subst(n), tclvars(n)
tcl8.4.20/doc/flush.n 0000644 0036047 0045461 00000003036 11737050674 012766 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH flush n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
flush \- Flush buffered output for a channel
.SH SYNOPSIS
\fBflush \fIchannelId\fR
.BE
.SH DESCRIPTION
.PP
Flushes any output that has been buffered for \fIchannelId\fR.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return
value from an invocation of \fBopen\fR or \fBsocket\fR, or the result
of a channel creation command provided by a Tcl extension. The
channel must have been opened for writing.
.VE
.PP
If the channel is in blocking mode the command does not return until all the
buffered output has been flushed to the channel. If the channel is in
nonblocking mode, the command may return before all buffered output has been
flushed; the remainder will be flushed in the background as fast as the
underlying file or device is able to absorb it.
.SH EXAMPLE
Prompt for the user to type some information in on the console:
.CS
puts -nonewline "Please type your name: "
\fBflush\fR stdout
gets stdin name
puts "Hello there, $name!"
.CE
.SH "SEE ALSO"
file(n), open(n), socket(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, buffer, channel, flush, nonblocking, output
tcl8.4.20/doc/Tcl.n 0000644 0036047 0045461 00000017753 11737050674 012402 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl n "8.1" Tcl "Tcl Built-In Commands"
.BS
.SH NAME
Tcl \- Tool Command Language
.SH SYNOPSIS
Summary of Tcl language syntax.
.BE
.SH DESCRIPTION
.PP
The following rules define the syntax and semantics of the Tcl language:
.IP "[1] \fBCommands.\fR"
A Tcl script is a string containing one or more commands.
Semi-colons and newlines are command separators unless quoted as
described below.
Close brackets are command terminators during command substitution
(see below) unless quoted.
.IP "[2] \fBEvaluation.\fR"
A command is evaluated in two steps.
First, the Tcl interpreter breaks the command into \fIwords\fR
and performs substitutions as described below.
These substitutions are performed in the same way for all
commands.
The first word is used to locate a command procedure to
carry out the command, then all of the words of the command are
passed to the command procedure.
The command procedure is free to interpret each of its words
in any way it likes, such as an integer, variable name, list,
or Tcl script.
Different commands interpret their words differently.
.IP "[3] \fBWords.\fR"
Words of a command are separated by white space (except for
newlines, which are command separators).
.IP "[4] \fBDouble quotes.\fR"
If the first character of a word is double-quote (``"'') then
the word is terminated by the next double-quote character.
If semi-colons, close brackets, or white space characters
(including newlines) appear between the quotes then they are treated
as ordinary characters and included in the word.
Command substitution, variable substitution, and backslash substitution
are performed on the characters between the quotes as described below.
The double-quotes are not retained as part of the word.
.IP "[5] \fBBraces.\fR"
If the first character of a word is an open brace (``{'') then
the word is terminated by the matching close brace (``}'').
Braces nest within the word: for each additional open
brace there must be an additional close brace (however,
if an open brace or close brace within the word is
quoted with a backslash then it is not counted in locating the
matching close brace).
No substitutions are performed on the characters between the
braces except for backslash-newline substitutions described
below, nor do semi-colons, newlines, close brackets,
or white space receive any special interpretation.
The word will consist of exactly the characters between the
outer braces, not including the braces themselves.
.IP "[6] \fBCommand substitution.\fR"
If a word contains an open bracket (``['') then Tcl performs
\fIcommand substitution\fR.
To do this it invokes the Tcl interpreter recursively to process
the characters following the open bracket as a Tcl script.
The script may contain any number of commands and must be terminated
by a close bracket (``]'').
The result of the script (i.e. the result of its last command) is
substituted into the word in place of the brackets and all of the
characters between them.
There may be any number of command substitutions in a single word.
Command substitution is not performed on words enclosed in braces.
.IP "[7] \fBVariable substitution.\fR"
If a word contains a dollar-sign (``$'') followed by one of the forms
described below, then Tcl performs \fIvariable
substitution\fR: the dollar-sign and the following characters are
replaced in the word by the value of a variable.
Variable substitution may take any of the following forms:
.RS
.TP 15
\fB$\fIname\fR
\fIName\fR is the name of a scalar variable; the name is a sequence
of one or more characters that are a letter, digit, underscore,
or namespace separators (two or more colons).
.TP 15
\fB$\fIname\fB(\fIindex\fB)\fR
\fIName\fR gives the name of an array variable and \fIindex\fR gives
the name of an element within that array.
\fIName\fR must contain only letters, digits, underscores, and
namespace separators, and may be an empty string.
Command substitutions, variable substitutions, and backslash
substitutions are performed on the characters of \fIindex\fR.
.TP 15
\fB${\fIname\fB}\fR
\fIName\fR is the name of a scalar variable. It may contain any
characters whatsoever except for close braces.
.LP
There may be any number of variable substitutions in a single word.
Variable substitution is not performed on words enclosed in braces.
.RE
.IP "[8] \fBBackslash substitution.\fR"
If a backslash (``\e'') appears within a word then
\fIbackslash substitution\fR occurs.
In all cases but those described below the backslash is dropped and
the following character is treated as an ordinary
character and included in the word.
This allows characters such as double quotes, close brackets,
and dollar signs to be included in words without triggering
special processing.
The following table lists the backslash sequences that are
handled specially, along with the value that replaces each sequence.
.RS
.TP 7
\e\fBa\fR
Audible alert (bell) (0x7).
.TP 7
\e\fBb\fR
Backspace (0x8).
.TP 7
\e\fBf\fR
Form feed (0xc).
.TP 7
\e\fBn\fR
Newline (0xa).
.TP 7
\e\fBr\fR
Carriage-return (0xd).
.TP 7
\e\fBt\fR
Tab (0x9).
.TP 7
\e\fBv\fR
Vertical tab (0xb).
.TP 7
\e\fB\fIwhiteSpace\fR
.
A single space character replaces the backslash, newline, and all spaces
and tabs after the newline. This backslash sequence is unique in that it
is replaced in a separate pre-pass before the command is actually parsed.
This means that it will be replaced even when it occurs between braces,
and the resulting space will be treated as a word separator if it isn't
in braces or quotes.
.TP 7
\e\e
Backslash (``\e'').
.VS 8.1 br
.TP 7
\e\fIooo\fR
.
The digits \fIooo\fR (one, two, or three of them) give an eight-bit octal
value for the Unicode character that will be inserted. The upper bits of the
Unicode character will be 0.
.TP 7
\e\fBx\fIhh\fR
.
The hexadecimal digits \fIhh\fR give an eight-bit hexadecimal value for the
Unicode character that will be inserted. Any number of hexadecimal digits
may be present; however, all but the last two are ignored (the result is
always a one-byte quantity). The upper bits of the Unicode character will
be 0.
.TP 7
\e\fBu\fIhhhh\fR
.
The hexadecimal digits \fIhhhh\fR (one, two, three, or four of them) give a
sixteen-bit hexadecimal value for the Unicode character that will be
inserted.
.VE
.LP
Backslash substitution is not performed on words enclosed in braces,
except for backslash-newline as described above.
.RE
.IP "[9] \fBComments.\fR"
If a hash character (``#'') appears at a point where Tcl is
expecting the first character of the first word of a command,
then the hash character and the characters that follow it, up
through the next newline, are treated as a comment and ignored.
The comment character only has significance when it appears
at the beginning of a command.
.IP "[10] \fBOrder of substitution.\fR"
Each character is processed exactly once by the Tcl interpreter
as part of creating the words of a command.
For example, if variable substitution occurs then no further
substitutions are performed on the value of the variable; the
value is inserted into the word verbatim.
If command substitution occurs then the nested command is
processed entirely by the recursive call to the Tcl interpreter;
no substitutions are performed before making the recursive
call and no additional substitutions are performed on the result
of the nested script.
.RS
.LP
Substitutions take place from left to right, and each substitution is
evaluated completely before attempting to evaluate the next. Thus, a
sequence like
.CS
set y [set x 0][incr x][incr x]
.CE
will always set the variable \fIy\fR to the value, \fI012\fR.
.RE
.IP "[11] \fBSubstitution and word boundaries.\fR"
Substitutions do not affect the word boundaries of a command.
For example, during variable substitution the entire value of
the variable becomes part of a single word, even if the variable's
value contains spaces.
tcl8.4.20/doc/CrtTrace.3 0000644 0036047 0045461 00000020313 11737050674 013256 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2002 by Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Trace
\fBTcl_CreateTrace\fR(\fIinterp, level, proc, clientData\fR)
.sp
Tcl_Trace
\fBTcl_CreateObjTrace\fR(\fIinterp, level, flags, objProc, clientData, deleteProc\fR)
.sp
\fBTcl_DeleteTrace\fR(\fIinterp, trace\fR)
.SH ARGUMENTS
.AS Tcl_CmdObjTraceDeleteProc (clientData)()
.AP Tcl_Interp *interp in
Interpreter containing command to be traced or untraced.
.AP int level in
Only commands at or below this nesting level will be traced unless
0 is specified. 1 means
top-level commands only, 2 means top-level commands or those that are
invoked as immediate consequences of executing top-level commands
(procedure bodies, bracketed commands, etc.) and so on.
A value of 0 means that commands at any level are traced.
.AP int flags in
Flags governing the trace execution. See below for details.
.AP Tcl_CmdObjTraceProc *objProc in
Procedure to call for each command that's executed. See below for
details of the calling sequence.
.AP Tcl_CmdTraceProc *proc in
Procedure to call for each command that's executed. See below for
details on the calling sequence.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIobjProc\fR or \fIproc\fR.
.AP Tcl_CmdObjTraceDeleteProc *deleteProc
Procedure to call when the trace is deleted. See below for details of
the calling sequence. A NULL pointer is permissible and results in no
callback when the trace is deleted.
.AP Tcl_Trace trace in
Token for trace to be removed (return value from previous call
to \fBTcl_CreateTrace\fR).
.BE
.SH DESCRIPTION
.PP
\fBTcl_CreateObjTrace\fR arranges for command tracing. After it is
called, \fIobjProc\fR will be invoked before the Tcl interpreter calls
any command procedure when evaluating commands in \fIinterp\fR.
The return value from \fBTcl_CreateObjTrace\fR is a token for the trace,
which may be passed to \fBTcl_DeleteTrace\fR to remove the trace.
There may be many traces in effect simultaneously for the same
interpreter.
.PP
\fIobjProc\fR should have arguments and result that match the type,
\fBTcl_CmdObjTraceProc\fR:
.CS
typedef int \fBTcl_CmdObjTraceProc\fR(
\fBClientData\fR \fIclientData\fR,
\fBTcl_Interp\fR* \fIinterp\fR,
int \fIlevel\fR,
CONST char* \fIcommand\fR,
\fBTcl_Command\fR \fIcommandToken\fR,
int \fIobjc\fR,
\fBTcl_Obj\fR *CONST \fIobjv\fR[] );
.CE
The \fIclientData\fR and \fIinterp\fR parameters are copies of the
corresponding arguments given to \fBTcl_CreateTrace\fR.
\fIClientData\fR typically points to an application-specific data
structure that describes what to do when \fIobjProc\fR is invoked. The
\fIlevel\fR parameter gives the nesting level of the command (1 for
top-level commands passed to \fBTcl_Eval\fR by the application, 2 for
the next-level commands passed to \fBTcl_Eval\fR as part of parsing or
interpreting level-1 commands, and so on). The \fIcommand\fR parameter
points to a string containing the text of the command, before any
argument substitution. The \fIcommandToken\fR parameter is a Tcl
command token that identifies the command to be invoked. The token
may be passed to \fBTcl_GetCommandName\fR,
\fBTcl_GetCommandInfoFromToken\fR, or \fBTcl_SetCommandInfoFromToken\fR to
manipulate the definition of the command. The \fIobjc\fR and \fIobjv\fR
parameters designate the final parameter count and parameter vector
that will be passed to the command, and have had all substitutions
performed.
.PP
The \fIobjProc\fR callback is expected to return a standard Tcl status
return code. If this code is \fBTCL_OK\fR (the normal case), then
the Tcl interpreter will invoke the command. Any other return code
is treated as if the command returned that status, and the command is
\fInot\fR invoked.
.PP
The \fIobjProc\fR callback must not modify \fIobjv\fR in any way. It
is, however, permissible to change the command by calling
\fBTcl_SetCommandTokenInfo\fR prior to returning. Any such change
takes effect immediately, and the command is invoked with the new
information.
.PP
Tracing will only occur for commands at nesting level less than
or equal to the \fIlevel\fR parameter (i.e. the \fIlevel\fR
parameter to \fIobjProc\fR will always be less than or equal to the
\fIlevel\fR parameter to \fBTcl_CreateTrace\fR).
.PP
Tracing has a significant effect on runtime performance because it
causes the bytecode compiler to refrain from generating in-line code
for Tcl commands such as \fBif\fR and \fBwhile\fR in order that they
may be traced. If traces for the built-in commands are not required,
the \fIflags\fR parameter may be set to the constant value
\fBTCL_ALLOW_INLINE_COMPILATION\fR. In this case, traces on built-in
commands may or may not result in trace callbacks, depending on the
state of the interpreter, but run-time performance will be improved
significantly. (This functionality is desirable, for example, when
using \fBTcl_CreateObjTrace\fR to implement an execution time
profiler.)
.PP
Calls to \fIobjProc\fR will be made by the Tcl parser immediately before
it calls the command procedure for the command (\fIcmdProc\fR). This
occurs after argument parsing and substitution, so tracing for
substituted commands occurs before tracing of the commands
containing the substitutions. If there is a syntax error in a
command, or if there is no command procedure associated with a
command name, then no tracing will occur for that command. If a
string passed to Tcl_Eval contains multiple commands (bracketed, or
on different lines) then multiple calls to \fIobjProc\fR will occur,
one for each command.
.PP
\fBTcl_DeleteTrace\fR removes a trace, so that no future calls will be
made to the procedure associated with the trace. After \fBTcl_DeleteTrace\fR
returns, the caller should never again use the \fItrace\fR token.
.PP
When \fBTcl_DeleteTrace\fR is called, the interpreter invokes the
\fIdeleteProc\fR that was passed as a parameter to
\fBTcl_CreateObjTrace\fR. The \fIdeleteProc\fR must match the type,
\fBTcl_CmdObjTraceDeleteProc\fR:
.CS
typedef void \fBTcl_CmdObjTraceDeleteProc\fR(
\fBClientData\fR \fIclientData\fR
);
.CE
The \fIclientData\fR parameter will be the same as the
\fIclientData\fR parameter that was originally passed to
\fBTcl_CreateObjTrace\fR.
.PP
\fBTcl_CreateTrace\fR is an alternative interface for command tracing,
\fInot recommended for new applications\fR. It is provided for backward
compatibility with code that was developed for older versions of the
Tcl interpreter. It is similar to \fBTcl_CreateObjTrace\fR, except
that its \fIproc\fR parameter should have arguments and result that
match the type \fBTcl_CmdTraceProc\fR:
.CS
typedef void Tcl_CmdTraceProc(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIlevel\fR,
char *\fIcommand\fR,
Tcl_CmdProc *\fIcmdProc\fR,
ClientData \fIcmdClientData\fR,
int \fIargc\fR,
CONST char *\fIargv\fR[]);
.CE
The parameters to the \fIproc\fR callback are similar to those of the
\fIobjProc\fR callback above. The \fIcommandToken\fR is
replaced with \fIcmdProc\fR, a pointer to the (string-based) command
procedure that will be invoked; and \fIcmdClientData\fR, the client
data that will be passed to the procedure. The \fIobjc\fR parameter
is replaced with an \fIargv\fR parameter, that gives the arguments to
the command as character strings.
\fIProc\fR must not modify the \fIcommand\fR or \fIargv\fR strings.
.PP
If a trace created with \fBTcl_CreateTrace\fR is in effect, inline
compilation of Tcl commands such as \fBif\fR and \fBwhile\fR is always
disabled. There is no notification when a trace created with
\fBTcl_CreateTrace\fR is deleted.
There is no way to be notified when the trace created by
\fBTcl_CreateTrace\fR is deleted. There is no way for the \fIproc\fR
associated with a call to \fBTcl_CreateTrace\fR to abort execution of
\fIcommand\fR.
.SH KEYWORDS
command, create, delete, interpreter, trace
tcl8.4.20/doc/SetResult.3 0000644 0036047 0045461 00000022725 11737050674 013512 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-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.
'\"
.so man.macros
.TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_SetObjResult\fR(\fIinterp, objPtr\fR)
.sp
Tcl_Obj *
\fBTcl_GetObjResult\fR(\fIinterp\fR)
.sp
\fBTcl_SetResult\fR(\fIinterp, string, freeProc\fR)
.sp
CONST char *
\fBTcl_GetStringResult\fR(\fIinterp\fR)
.sp
\fBTcl_AppendResult\fR(\fIinterp, string, string, ... , \fB(char *) NULL\fR)
.sp
\fBTcl_AppendResultVA\fR(\fIinterp, argList\fR)
.sp
\fBTcl_AppendElement\fR(\fIinterp, string\fR)
.sp
\fBTcl_ResetResult\fR(\fIinterp\fR)
.sp
\fBTcl_FreeResult\fR(\fIinterp\fR)
.SH ARGUMENTS
.AS Tcl_FreeProc freeProc
.AP Tcl_Interp *interp out
Interpreter whose result is to be modified or read.
.AP Tcl_Obj *objPtr in
Object value to become result for \fIinterp\fR.
.AP char *string in
String value to become result for \fIinterp\fR or to be
appended to the existing result.
.AP Tcl_FreeProc *freeProc in
Address of procedure to call to release storage at
\fIstring\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or
\fBTCL_VOLATILE\fR.
.AP va_list argList in
An argument list which must have been initialised using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.BE
.SH DESCRIPTION
.PP
The procedures described here are utilities for manipulating the
result value in a Tcl interpreter.
The interpreter result may be either a Tcl object or a string.
For example, \fBTcl_SetObjResult\fR and \fBTcl_SetResult\fR
set the interpreter result to, respectively, an object and a string.
Similarly, \fBTcl_GetObjResult\fR and \fBTcl_GetStringResult\fR
return the interpreter result as an object and as a string.
The procedures always keep the string and object forms
of the interpreter result consistent.
For example, if \fBTcl_SetObjResult\fR is called to set
the result to an object,
then \fBTcl_GetStringResult\fR is called,
it will return the object's string value.
.PP
\fBTcl_SetObjResult\fR
arranges for \fIobjPtr\fR to be the result for \fIinterp\fR,
replacing any existing result.
The result is left pointing to the object
referenced by \fIobjPtr\fR.
\fIobjPtr\fR's reference count is incremented
since there is now a new reference to it from \fIinterp\fR.
The reference count for any old result object
is decremented and the old result object is freed if no
references to it remain.
.PP
\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as an object.
The object's reference count is not incremented;
if the caller needs to retain a long-term pointer to the object
they should use \fBTcl_IncrRefCount\fR to increment its reference count
in order to keep it from being freed too early or accidently changed.
.PP
\fBTcl_SetResult\fR
arranges for \fIstring\fR to be the result for the current Tcl
command in \fIinterp\fR, replacing any existing result.
The \fIfreeProc\fR argument specifies how to manage the storage
for the \fIstring\fR argument;
it is discussed in the section
\fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below.
If \fIstring\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored
and \fBTcl_SetResult\fR
re-initializes \fIinterp\fR's result to point to an empty string.
.PP
\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as an string.
If the result was set to an object by a \fBTcl_SetObjResult\fR call,
the object form will be converted to a string and returned.
If the object's string representation contains null bytes,
this conversion will lose information.
For this reason, programmers are encouraged to
write their code to use the new object API procedures
and to call \fBTcl_GetObjResult\fR instead.
.PP
\fBTcl_ResetResult\fR clears the result for \fIinterp\fR
and leaves the result in its normal empty initialized state.
If the result is an object,
its reference count is decremented and the result is left
pointing to an unshared object representing an empty string.
If the result is a dynamically allocated string, its memory is free*d
and the result is left as a empty string.
\fBTcl_ResetResult\fR also clears the error state managed by
\fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR,
and \fBTcl_SetErrorCode\fR.
.SH "OLD STRING PROCEDURES"
.PP
Use of the following procedures is deprecated
since they manipulate the Tcl result as a string.
Procedures such as \fBTcl_SetObjResult\fR
that manipulate the result as an object
can be significantly more efficient.
.PP
\fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces.
It takes each of its \fIstring\fR arguments and appends them in order
to the current result associated with \fIinterp\fR.
If the result is in its initialized empty state (e.g. a command procedure
was just invoked or \fBTcl_ResetResult\fR was just called),
then \fBTcl_AppendResult\fR sets the result to the concatenation of
its \fIstring\fR arguments.
\fBTcl_AppendResult\fR may be called repeatedly as additional pieces
of the result are produced.
\fBTcl_AppendResult\fR takes care of all the
storage management issues associated with managing \fIinterp\fR's
result, such as allocating a larger result area if necessary.
It also converts the current interpreter result from an object
to a string, if necessary, before appending the argument strings.
Any number of \fIstring\fR arguments may be passed in a single
call; the last argument in the list must be a NULL pointer.
.PP
\fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that
instead of taking a variable number of arguments it takes an argument list.
.PP
\fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in
that it allows results to be built up in pieces.
However, \fBTcl_AppendElement\fR takes only a single \fIstring\fR
argument and it appends that argument to the current result
as a proper Tcl list element.
\fBTcl_AppendElement\fR adds backslashes or braces if necessary
to ensure that \fIinterp\fR's result can be parsed as a list and that
\fIstring\fR will be extracted as a single element.
Under normal conditions, \fBTcl_AppendElement\fR will add a space
character to \fIinterp\fR's result just before adding the new
list element, so that the list elements in the result are properly
separated.
However if the new list element is the first in a list or sub-list
(i.e. \fIinterp\fR's current result is empty, or consists of the
single character ``{'', or ends in the characters `` {'') then no
space is added.
.PP
\fBTcl_FreeResult\fR performs part of the work
of \fBTcl_ResetResult\fR.
It frees up the memory associated with \fIinterp\fR's result.
It also sets \fIinterp->freeProc\fR to zero, but doesn't
change \fIinterp->result\fR or clear error state.
\fBTcl_FreeResult\fR is most commonly used when a procedure
is about to replace one result value with another.
.SH "DIRECT ACCESS TO INTERP->RESULT IS DEPRECATED"
.PP
It used to be legal for programs to
directly read and write \fIinterp->result\fR
to manipulate the interpreter result.
Direct access to \fIinterp->result\fR is now strongly deprecated
because it can make the result's string and object forms inconsistent.
Programs should always read the result
using the procedures \fBTcl_GetObjResult\fR or \fBTcl_GetStringResult\fR,
and write the result using \fBTcl_SetObjResult\fR or \fBTcl_SetResult\fR.
.SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT"
.PP
\fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how
the Tcl system is to manage the storage for the \fIstring\fR argument.
If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called
at a time when \fIinterp\fR holds a string result,
they do whatever is necessary to dispose of the old string result
(see the \fBTcl_Interp\fR manual entry for details on this).
.PP
If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIstring\fR
refers to an area of static storage that is guaranteed not to be
modified until at least the next call to \fBTcl_Eval\fR.
If \fIfreeProc\fR
is \fBTCL_DYNAMIC\fR it means that \fIstring\fR was allocated with a call
to \fBTcl_Alloc\fR and is now the property of the Tcl system.
\fBTcl_SetResult\fR will arrange for the string's storage to be
released by calling \fBTcl_Free\fR when it is no longer needed.
If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIstring\fR
points to an area of memory that is likely to be overwritten when
\fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame).
In this case \fBTcl_SetResult\fR will make a copy of the string in
dynamically allocated storage and arrange for the copy to be the
result for the current Tcl command.
.PP
If \fIfreeProc\fR isn't one of the values \fBTCL_STATIC\fR,
\fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address
of a procedure that Tcl should call to free the string.
This allows applications to use non-standard storage allocators.
When Tcl no longer needs the storage for the string, it will
call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and
result that match the type \fBTcl_FreeProc\fR:
.CS
typedef void Tcl_FreeProc(char *\fIblockPtr\fR);
.CE
When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to
the value of \fIstring\fR passed to \fBTcl_SetResult\fR.
.SH "SEE ALSO"
Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp
.SH KEYWORDS
append, command, element, list, object, result, return value, interpreter
tcl8.4.20/doc/GetIndex.3 0000644 0036047 0045461 00000010541 12052456743 013256 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_GetIndexFromObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct \- lookup string in table of keywords
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_GetIndexFromObj\fR(\fIinterp, objPtr, tablePtr, msg, flags,
indexPtr\fR)
.VS
.sp
int
\fBTcl_GetIndexFromObjStruct\fR(\fIinterp, objPtr, structTablePtr, offset,
msg, flags, indexPtr\fR)
.VE
.SH ARGUMENTS
.AS "CONST char" **tablePtr
.AP Tcl_Interp *interp in
Interpreter to use for error reporting; if NULL, then no message is
provided on errors.
.AP Tcl_Obj *objPtr in/out
The string value of this object is used to search through \fItablePtr\fR.
The internal representation is modified to hold the index of the matching
table entry.
.AP "CONST char" **tablePtr in
An array of null-terminated strings. The end of the array is marked
by a NULL string pointer.
Note that references to the \fItablePtr\fR may be retained in the
internal representation of \fIobjPtr\fR, so this should represent the
address of a statically-allocated array.
.AP "CONST VOID" *structTablePtr in
An array of arbitrary type, typically some \fBstruct\fP type.
The first member of the structure must be a null-terminated string.
The size of the structure is given by \fIoffset\fP.
Note that references to the \fIstructTablePtr\fR may be retained in the
internal representation of \fIobjPtr\fR, so this should represent the
address of a statically-allocated array of structures.
.VS
.AP int offset in
The offset to add to structTablePtr to get to the next entry.
The end of the array is marked by a NULL string pointer.
.VE
.AP "CONST char" *msg in
Null-terminated string describing what is being looked up, such as
\fBoption\fR. This string is included in error messages.
.AP int flags in
OR-ed combination of bits providing additional information for
operation. The only bit that is currently defined is \fBTCL_EXACT\fR.
.AP int *indexPtr out
The index of the string in \fItablePtr\fR that matches the value of
\fIobjPtr\fR is returned here.
.BE
.SH DESCRIPTION
.PP
These procedures provide an efficient way for looking up keywords,
switch names, option names, and similar things where the value of
an object must be one of a predefined set of values.
\fBTcl_GetIndexFromObj\fR compares \fIobjPtr\fR against each of
the strings in \fItablePtr\fR to find a match. A match occurs if
\fIobjPtr\fR's string value is identical to one of the strings in
\fItablePtr\fR, or if it is a non-empty unique abbreviation
for exactly one of the strings in \fItablePtr\fR and the
\fBTCL_EXACT\fR flag was not specified; in either case
the index of the matching entry is stored at \fI*indexPtr\fR
and TCL_OK is returned.
.PP
If there is no matching entry,
TCL_ERROR is returned and an error message is left in \fIinterp\fR's
result if \fIinterp\fR isn't NULL. \fIMsg\fR is included in the
error message to indicate what was being looked up. For example,
if \fImsg\fR is \fBoption\fR the error message will have a form like
\fBbad option "firt": must be first, second, or third\fR.
.PP
If \fBTcl_GetIndexFromObj\fR completes successfully it modifies the
internal representation of \fIobjPtr\fR to hold the address of
the table and the index of the matching entry. If \fBTcl_GetIndexFromObj\fR
is invoked again with the same \fIobjPtr\fR and \fItablePtr\fR
arguments (e.g. during a reinvocation of a Tcl command), it returns
the matching index immediately without having to redo the lookup
operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries
in \fItablePtr\fR are static: they must not change between
invocations. If the value of \fIobjPtr\fR is the empty string,
\fBTcl_GetIndexFromObj\fR will treat it as a non-matching value
and return TCL_ERROR.
.VS
.PP
\fBTcl_GetIndexFromObjStruct\fR works just like
\fBTcl_GetIndexFromObj\fR, except that instead of treating
\fItablePtr\fR as an array of string pointers, it treats it as the
first in a series of string ptrs that are spaced apart by \fIoffset\fR
bytes. This is particularly useful when processing things like
\fBTk_ConfigurationSpec\fR, whose string keys are in the same place in
each of several array elements.
.VE
.SH "SEE ALSO"
Tcl_WrongNumArgs
.SH KEYWORDS
index, object, table lookup
tcl8.4.20/doc/socket.n 0000644 0036047 0045461 00000016104 11737050674 013135 0 ustar dgp 771div '\"
'\" Copyright (c) 1996 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 by Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH socket n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
socket \- Open a TCP network connection
.SH SYNOPSIS
.sp
\fBsocket \fR?\fIoptions\fR? \fIhost port\fR
.sp
\fBsocket\fR \fB\-server \fIcommand\fR ?\fIoptions\fR? \fIport\fR
.BE
.SH DESCRIPTION
.PP
This command opens a network socket and returns a channel
identifier that may be used in future invocations of commands like
\fBread\fR, \fBputs\fR and \fBflush\fR.
At present only the TCP network protocol is supported; future
releases may include support for additional protocols.
The \fBsocket\fR command may be used to open either the client or
server side of a connection, depending on whether the \fB\-server\fR
switch is specified.
.PP
Note that the default encoding for \fIall\fR sockets is the system
encoding, as returned by \fBencoding system\fR. Most of the time, you
will need to use \fBfconfigure\fR to alter this to something else,
such as \fIutf\-8\fR (ideal for communicating with other Tcl
processes) or \fIiso8859\-1\fR (useful for many network protocols,
especially the older ones).
.SH "CLIENT SOCKETS"
.PP
If the \fB\-server\fR option is not specified, then the client side of a
connection is opened and the command returns a channel identifier
that can be used for both reading and writing.
\fIPort\fR and \fIhost\fR specify a port
to connect to; there must be a server accepting connections on
this port. \fIPort\fR is an integer port number
(or service name, where supported and understood by the host operating
system) and \fIhost\fR
is either a domain-style name such as \fBwww.tcl.tk\fR or
a numerical IP address such as \fB127.0.0.1\fR.
Use \fIlocalhost\fR to refer to the host on which the command is invoked.
.PP
The following options may also be present before \fIhost\fR
to specify additional information about the connection:
.TP
\fB\-myaddr\fI addr\fR
\fIAddr\fR gives the domain-style name or numerical IP address of
the client-side network interface to use for the connection.
This option may be useful if the client machine has multiple network
interfaces. If the option is omitted then the client-side interface
will be chosen by the system software.
.TP
\fB\-myport\fI port\fR
\fIPort\fR specifies an integer port number (or service name, where
supported and understood by the host operating system) to use for the
client's
side of the connection. If this option is omitted, the client's
port number will be chosen at random by the system software.
.TP
\fB\-async\fR
The \fB\-async\fR option will cause the client socket to be connected
asynchronously. This means that the socket will be created immediately but
may not yet be connected to the server, when the call to \fBsocket\fR
returns. When a \fBgets\fR or \fBflush\fR is done on the socket before the
connection attempt succeeds or fails, if the socket is in blocking mode, the
operation will wait until the connection is completed or fails. If the
socket is in nonblocking mode and a \fBgets\fR or \fBflush\fR is done on
the socket before the connection attempt succeeds or fails, the operation
returns immediately and \fBfblocked\fR on the socket returns 1.
.SH "SERVER SOCKETS"
.PP
If the \fB\-server\fR option is specified then the new socket
will be a server for the port given by \fIport\fR (either an integer
or a service name, where supported and understood by the host
operating system; if \fIport\fR is zero, the operating system will
allocate a free port to the server socket which may be discovered by
using \fBfconfigure\fR to read the \fB\-sockname\fR option).
Tcl will automatically accept connections to the given port.
For each connection Tcl will create a new channel that may be used to
communicate with the client. Tcl then invokes \fIcommand\fR
with three additional arguments: the name of the new channel, the
address, in network address notation, of the client's host, and
the client's port number.
.PP
The following additional option may also be specified before \fIhost\fR:
.TP
\fB\-myaddr\fI addr\fR
\fIAddr\fR gives the domain-style name or numerical IP address of
the server-side network interface to use for the connection.
This option may be useful if the server machine has multiple network
interfaces. If the option is omitted then the server socket is bound
to the special address INADDR_ANY so that it can accept connections from
any interface.
.PP
Server channels cannot be used for input or output; their sole use is to
accept new client connections. The channels created for each incoming
client connection are opened for input and output. Closing the server
channel shuts down the server so that no new connections will be
accepted; however, existing connections will be unaffected.
.PP
Server sockets depend on the Tcl event mechanism to find out when
new connections are opened. If the application doesn't enter the
event loop, for example by invoking the \fBvwait\fR command or
calling the C procedure \fBTcl_DoOneEvent\fR, then no connections
will be accepted.
.PP
If \fIport\fR is specified as zero, the operating system will allocate
an unused port for use as a server socket. The port number actually
allocated may be retrieved from the created server socket using the
\fBfconfigure\fR command to retrieve the \fB\-sockname\fR option as
described below.
.SH "CONFIGURATION OPTIONS"
The \fBfconfigure\fR command can be used to query several readonly
configuration options for socket channels:
.TP
\fB\-error\fR
This option gets the current error status of the given socket. This
is useful when you need to determine if an asynchronous connect
operation succeeded. If there was an error, the error message is
returned. If there was no error, an empty string is returned.
.TP
\fB\-sockname\fR
This option returns a list of three elements, the address, the host name
and the port number for the socket. If the host name cannot be computed,
the second element is identical to the address, the first element of the
list.
.TP
\fB\-peername\fR
This option is not supported by server sockets. For client and accepted
sockets, this option returns a list of three elements; these are the
address, the host name and the port to which the peer socket is connected
or bound. If the host name cannot be computed, the second element of the
list is identical to the address, its first element.
.PP
.SH "EXAMPLES"
Here is a very simple time server:
.CS
proc Server {channel clientaddr clientport} {
puts "Connection from $clientaddr registered"
puts $channel [clock format [clock seconds]]
close $channel
}
\fBsocket\fR -server Server 9900
vwait forever
.CE
.PP
And here is the corresponding client to talk to the server:
.CS
set server localhost
set sockChan [\fBsocket\fR $server 9900]
gets $sockChan line
close $sockChan
puts "The time on $server is $line"
.CE
.SH "SEE ALSO"
fconfigure(n), flush(n), open(n), read(n)
.SH KEYWORDS
bind, channel, connection, domain name, host, network address, socket, tcp
tcl8.4.20/doc/CrtCommand.3 0000644 0036047 0045461 00000014417 11737050674 013606 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-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.
'\"
.so man.macros
.TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateCommand \- implement new commands in C
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Command
\fBTcl_CreateCommand\fR(\fIinterp, cmdName, proc, clientData, deleteProc\fR)
.SH ARGUMENTS
.AS Tcl_CmdDeleteProc **deleteProcPtr
.AP Tcl_Interp *interp in
Interpreter in which to create new command.
.VS 8.4
.AP "CONST char" *cmdName in
.VE
Name of command.
.AP Tcl_CmdProc *proc in
Implementation of new command: \fIproc\fR will be called whenever
\fIcmdName\fR is invoked as a command.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR.
.AP Tcl_CmdDeleteProc *deleteProc in
Procedure to call before \fIcmdName\fR is deleted from the interpreter;
allows for command-specific cleanup. If NULL, then no procedure is
called before the command is deleted.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates
it with procedure \fIproc\fR such that whenever \fIcmdName\fR is
invoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter
will call \fIproc\fR to process the command.
It differs from \fBTcl_CreateObjCommand\fR in that a new string-based
command is defined;
that is, a command procedure is defined that takes an array of
argument strings instead of objects.
The object-based command procedures registered by \fBTcl_CreateObjCommand\fR
can execute significantly faster than the string-based command procedures
defined by \fBTcl_CreateCommand\fR.
This is because they take Tcl objects as arguments
and those objects can retain an internal representation that
can be manipulated more efficiently.
Also, Tcl's interpreter now uses objects internally.
In order to invoke a string-based command procedure
registered by \fBTcl_CreateCommand\fR,
it must generate and fetch a string representation
from each argument object before the call
and create a new Tcl object to hold the string result returned by the
string-based command procedure.
New commands should be defined using \fBTcl_CreateObjCommand\fR.
We support \fBTcl_CreateCommand\fR for backwards compatibility.
.PP
The procedures \fBTcl_DeleteCommand\fR, \fBTcl_GetCommandInfo\fR,
and \fBTcl_SetCommandInfo\fR are used in conjunction with
\fBTcl_CreateCommand\fR.
.PP
\fBTcl_CreateCommand\fR will delete an existing command \fIcmdName\fR,
if one is already associated with the interpreter.
It returns a token that may be used to refer
to the command in subsequent calls to \fBTcl_GetCommandName\fR.
If \fIcmdName\fR contains any \fB::\fR namespace qualifiers,
then the command is added to the specified namespace;
otherwise the command is added to the global namespace.
If \fBTcl_CreateCommand\fR is called for an interpreter that is in
the process of being deleted, then it does not create a new command
and it returns NULL.
\fIProc\fR should have arguments and result that match the type
\fBTcl_CmdProc\fR:
.CS
typedef int Tcl_CmdProc(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIargc\fR,
CONST char *\fIargv\fR[]);
.CE
When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR
parameters will be copies of the \fIclientData\fR and \fIinterp\fR
arguments given to \fBTcl_CreateCommand\fR.
Typically, \fIclientData\fR points to an application-specific
data structure that describes what to do when the command procedure
is invoked. \fIArgc\fR and \fIargv\fR describe the arguments to
the command, \fIargc\fR giving the number of arguments (including
the command name) and \fIargv\fR giving the values of the arguments
as strings. The \fIargv\fR array will contain \fIargc\fR+1 values;
the first \fIargc\fR values point to the argument strings, and the
last value is NULL.
.VS
Note that the argument strings should not be modified as they may
point to constant strings or may be shared with other parts of the
interpreter.
.VE
.PP
.VS
Note that the argument strings are encoded in normalized UTF-8 since
version 8.1 of Tcl.
.VE
.PP
\fIProc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR,
\fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page
for details on what these codes mean. Most normal commands will only
return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, \fIproc\fR must set
the interpreter result to point to a string value;
in the case of a \fBTCL_OK\fR return code this gives the result
of the command, and in the case of \fBTCL_ERROR\fR it gives an error message.
The \fBTcl_SetResult\fR procedure provides an easy interface for setting
the return value; for complete details on how the the interpreter result
field is managed, see the \fBTcl_Interp\fR man page.
Before invoking a command procedure,
\fBTcl_Eval\fR sets the interpreter result to point to an empty string,
so simple commands can return an empty result by doing nothing at all.
.PP
The contents of the \fIargv\fR array belong to Tcl and are not
guaranteed to persist once \fIproc\fR returns: \fIproc\fR should
not modify them, nor should it set the interpreter result to point
anywhere within the \fIargv\fR values.
Call \fBTcl_SetResult\fR with status \fBTCL_VOLATILE\fR if you want
to return something from the \fIargv\fR array.
.PP
\fIDeleteProc\fR will be invoked when (if) \fIcmdName\fR is deleted.
This can occur through a call to \fBTcl_DeleteCommand\fR or \fBTcl_DeleteInterp\fR,
or by replacing \fIcmdName\fR in another call to \fBTcl_CreateCommand\fR.
\fIDeleteProc\fR is invoked before the command is deleted, and gives the
application an opportunity to release any structures associated
with the command. \fIDeleteProc\fR should have arguments and
result that match the type \fBTcl_CmdDeleteProc\fR:
.CS
typedef void Tcl_CmdDeleteProc(ClientData \fIclientData\fR);
.CE
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument passed to \fBTcl_CreateCommand\fR.
.PP
.SH "SEE ALSO"
Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_GetCommandInfo, Tcl_SetCommandInfo, Tcl_GetCommandName, Tcl_SetObjResult
.SH KEYWORDS
bind, command, create, delete, interpreter, namespace
tcl8.4.20/doc/pkgMkIndex.n 0000644 0036047 0045461 00000024507 11737050674 013714 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
pkg_mkIndex \- Build an index for automatic loading of packages
.SH SYNOPSIS
.nf
.VS 8.3.0
\fBpkg_mkIndex ?\fI\-direct\fR? ?\fI\-lazy\fR? ?\fI\-load pkgPat\fR? ?\fI\-verbose\fR? \fIdir\fR ?\fIpattern pattern ...\fR?
.VE
.fi
.BE
.SH DESCRIPTION
.PP
\fBPkg_mkIndex\fR is a utility procedure that is part of the standard
Tcl library.
It is used to create index files that allow packages to be loaded
automatically when \fBpackage require\fR commands are executed.
To use \fBpkg_mkIndex\fR, follow these steps:
.IP [1]
Create the package(s).
Each package may consist of one or more Tcl script files or binary files.
Binary files must be suitable for loading with the \fBload\fR command
with a single argument; for example, if the file is \fBtest.so\fR it must
be possible to load this file with the command \fBload test.so\fR.
Each script file must contain a \fBpackage provide\fR command to declare
the package and version number, and each binary file must contain
a call to \fBTcl_PkgProvide\fR.
.IP [2]
Create the index by invoking \fBpkg_mkIndex\fR.
The \fIdir\fR argument gives the name of a directory and each
\fIpattern\fR argument is a \fBglob\fR-style pattern that selects
script or binary files in \fIdir\fR.
.VS 8.0.3
The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR.
.VE
.br
\fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR
with package information about all the files given by the \fIpattern\fR
arguments.
It does this by loading each file into a slave
interpreter and seeing what packages
and new commands appear (this is why it is essential to have
\fBpackage provide\fR commands or \fBTcl_PkgProvide\fR calls
in the files, as described above).
If you have a package split among scripts and binary files,
or if you have dependencies among files,
you may have to use the \fB\-load\fP option
or adjust the order in which \fBpkg_mkIndex\fR processes
the files. See COMPLEX CASES below.
.IP [3]
Install the package as a subdirectory of one of the directories given by
the \fBtcl_pkgPath\fR variable. If \fB$tcl_pkgPath\fR contains more
than one directory, machine-dependent packages (e.g., those that
contain binary shared libraries) should normally be installed
under the first directory and machine-independent packages (e.g.,
those that contain only Tcl scripts) should be installed under the
second directory.
The subdirectory should include
the package's script and/or binary files as well as the \fBpkgIndex.tcl\fR
file. As long as the package is installed as a subdirectory of a
directory in \fB$tcl_pkgPath\fR it will automatically be found during
\fBpackage require\fR commands.
.br
If you install the package anywhere else, then you must ensure that
the directory containing the package is in the \fBauto_path\fR global variable
or an immediate subdirectory of one of the directories in \fBauto_path\fR.
\fBAuto_path\fR contains a list of directories that are searched
by both the auto-loader and the package loader; by default it
includes \fB$tcl_pkgPath\fR.
The package loader also checks all of the subdirectories of the
directories in \fBauto_path\fR.
You can add a directory to \fBauto_path\fR explicitly in your
application, or you can add the directory to your \fBTCLLIBPATH\fR
environment variable: if this environment variable is present,
Tcl initializes \fBauto_path\fR from it during application startup.
.IP [4]
Once the above steps have been taken, all you need to do to use a
package is to invoke \fBpackage require\fR.
For example, if versions 2.1, 2.3, and 3.1 of package \fBTest\fR
have been indexed by \fBpkg_mkIndex\fR, the command
\fBpackage require Test\fR will make version 3.1 available
and the command \fBpackage require \-exact Test 2.1\fR will
make version 2.1 available.
There may be many versions of a package in the various index files
in \fBauto_path\fR, but only one will actually be loaded in a given
interpreter, based on the first call to \fBpackage require\fR.
Different versions of a package may be loaded in different
interpreters.
.SH OPTIONS
The optional switches are:
.TP 15
\fB\-direct\fR
The generated index will implement direct loading of the package
upon \fBpackage require\fR. This is the default.
.TP 15
\fB\-lazy\fR
The generated index will manage to delay loading the package until the
use of one of the commands provided by the package, instead of loading
it immediately upon \fBpackage require\fR.
.TP 15
\fB\-load \fIpkgPat\fR
The index process will pre-load any packages that exist in the
current interpreter and match \fIpkgPat\fP into the slave interpreter used to
generate the index. The pattern match uses string match rules, but without
making case distinctions.
See COMPLEX CASES below.
.TP 15
\fB\-verbose\fR
Generate output during the indexing process. Output is via
the \fBtclLog\fP procedure, which by default prints to stderr.
.TP 15
\fB\-\-\fR
End of the flags, in case \fIdir\fP begins with a dash.
.SH "PACKAGES AND THE AUTO-LOADER"
.PP
The package management facilities overlap somewhat with the auto-loader,
in that both arrange for files to be loaded on-demand.
However, package management is a higher-level mechanism that uses
the auto-loader for the last step in the loading process.
It is generally better to index a package with \fBpkg_mkIndex\fR
rather than \fBauto_mkindex\fR because the package mechanism provides
version control: several versions of a package can be made available
in the index files, with different applications using different
versions based on \fBpackage require\fR commands.
In contrast, \fBauto_mkindex\fR does not understand versions so
it can only handle a single version of each package.
It is probably not a good idea to index a given package with both
\fBpkg_mkIndex\fR and \fBauto_mkindex\fR.
If you use \fBpkg_mkIndex\fR to index a package, its commands cannot
be invoked until \fBpackage require\fR has been used to select a
version; in contrast, packages indexed with \fBauto_mkindex\fR
can be used immediately since there is no version control.
.SH "HOW IT WORKS"
.PP
\fBPkg_mkIndex\fR depends on the \fBpackage unknown\fR command,
the \fBpackage ifneeded\fR command, and the auto-loader.
The first time a \fBpackage require\fR command is invoked,
the \fBpackage unknown\fR script is invoked.
This is set by Tcl initialization to a script that
evaluates all of the \fBpkgIndex.tcl\fR files in the
\fBauto_path\fR.
The \fBpkgIndex.tcl\fR files contain \fBpackage ifneeded\fR
commands for each version of each available package; these commands
invoke \fBpackage provide\fR commands to announce the
availability of the package, and they setup auto-loader
information to load the files of the package.
.VS 8.3
If the \fI\-lazy\fR flag was provided when the \fBpkgIndex.tcl\fR
was generated,
.VE
a given file of a given version of a given package isn't
actually loaded until the first time one of its commands
is invoked.
Thus, after invoking \fBpackage require\fR you may
not see the package's commands in the interpreter, but you will be able
to invoke the commands and they will be auto-loaded.
.VS 8.3
.SH "DIRECT LOADING"
.PP
Some packages, for instance packages which use namespaces and export
commands or those which require special initialization, might select
that their package files be loaded immediately upon \fBpackage require\fR
instead of delaying the actual loading to the first use of one of the
package's command. This is the default mode when generating the package
index. It can be overridden by specifying the \fI\-lazy\fR argument.
.VE
.SH "COMPLEX CASES"
Most complex cases of dependencies among scripts
and binary files, and packages being split among scripts and
binary files are handled OK. However, you may have to adjust
the order in which files are processed by \fBpkg_mkIndex\fR.
These issues are described in detail below.
.PP
If each script or file contains one package, and packages
are only contained in one file, then things are easy.
You simply specify all files to be indexed in any order
with some glob patterns.
.PP
In general, it is OK for scripts to have dependencies on other
packages.
If scripts contain \fBpackage require\fP commands, these are
stubbed out in the interpreter used to process the scripts,
so these do not cause problems.
If scripts call into other packages in global code,
these calls are handled by a stub \fBunknown\fP command.
However, if scripts make variable references to other package's
variables in global code, these will cause errors. That is
also bad coding style.
.PP
If binary files have dependencies on other packages, things
can become tricky because it is not possible to stub out
C-level APIs such as \fBTcl_PkgRequire\fP API
when loading a binary file.
For example, suppose the BLT package requires Tk, and expresses
this with a call to \fBTcl_PkgRequire\fP in its \fBBlt_Init\fP routine.
To support this, you must run \fBpkg_mkIndex\fR in an interpreter that
has Tk loaded. You can achieve this with the
\fB\-load \fIpkgPat\fR option. If you specify this option,
\fBpkg_mkIndex\fR will load any packages listed by
\fBinfo loaded\fP and that match \fIpkgPat\fP
into the interpreter used to process files.
In most cases this will satisfy the \fBTcl_PkgRequire\fP calls
made by binary files.
.PP
If you are indexing two binary files and one depends on the other,
you should specify the one that has dependencies last.
This way the one without dependencies will get loaded and indexed,
and then the package it provides
will be available when the second file is processed.
You may also need to load the first package into the
temporary interpreter used to create the index by using
the \fB\-load\fP flag;
it won't hurt to specify package patterns that are not yet loaded.
.PP
If you have a package that is split across scripts and a binary file,
then you should avoid the \fB\-load\fP flag. The problem is that
if you load a package before computing the index it masks any
other files that provide part of the same package.
If you must use \fB\-load\fP,
then you must specify the scripts first; otherwise the package loaded from
the binary file may mask the package defined by the scripts.
.SH "SEE ALSO"
package(n)
.SH KEYWORDS
auto-load, index, package, version
tcl8.4.20/doc/Notifier.3 0000644 0036047 0045461 00000065773 11737050674 013351 0 ustar dgp 771div '\"
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH Notifier 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode \- the event queue and notifier interfaces
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
void
\fBTcl_CreateEventSource\fR(\fIsetupProc, checkProc, clientData\fR)
.sp
void
\fBTcl_DeleteEventSource\fR(\fIsetupProc, checkProc, clientData\fR)
.sp
void
\fBTcl_SetMaxBlockTime\fR(\fItimePtr\fR)
.sp
void
\fBTcl_QueueEvent\fR(\fIevPtr, position\fR)
.VS 8.1
.sp
void
\fBTcl_ThreadQueueEvent\fR(\fIthreadId, evPtr, position\fR)
.sp
void
\fBTcl_ThreadAlert\fR(\fIthreadId\fR)
.sp
Tcl_ThreadId
\fBTcl_GetCurrentThread\fR()
.sp
void
\fBTcl_DeleteEvents\fR(\fIdeleteProc, clientData\fR)
.sp
ClientData
\fBTcl_InitNotifier\fR()
.sp
void
\fBTcl_FinalizeNotifier\fR(\fIclientData\fR)
.sp
int
\fBTcl_WaitForEvent\fR(\fItimePtr\fR)
.sp
void
\fBTcl_AlertNotifier\fR(\fIclientData\fR)
.sp
void
\fBTcl_SetTimer\fR(\fItimePtr\fR)
.sp
int
\fBTcl_ServiceAll\fR()
.sp
int
\fBTcl_ServiceEvent\fR(\fIflags\fR)
.sp
int
\fBTcl_GetServiceMode\fR()
.sp
int
\fBTcl_SetServiceMode\fR(\fImode\fR)
.VE
.SH ARGUMENTS
.AS Tcl_EventDeleteProc milliseconds
.AP Tcl_EventSetupProc *setupProc in
Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR.
.AP Tcl_EventCheckProc *checkProc in
Procedure for \fBTcl_DoOneEvent\fR to invoke after waiting for
events. Checks to see if any events have occurred and, if so,
queues them.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIsetupProc\fR, \fIcheckProc\fR, or
\fIdeleteProc\fR.
.AP Tcl_Time *timePtr in
Indicates the maximum amount of time to wait for an event. This
is specified as an interval (how long to wait), not an absolute
time (when to wakeup). If the pointer passed to \fBTcl_WaitForEvent\fR
is NULL, it means there is no maximum wait time: wait forever if
necessary.
.AP Tcl_Event *evPtr in
An event to add to the event queue. The storage for the event must
have been allocated by the caller using \fBTcl_Alloc\fR or \fBckalloc\fR.
.AP Tcl_QueuePosition position in
Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR,
\fBTCL_QUEUE_HEAD\fR, or \fBTCL_QUEUE_MARK\fR.
.AP Tcl_ThreadId threadId in
A unique identifier for a thread.
.AP Tcl_EventDeleteProc *deleteProc in
Procedure to invoke for each queued event in \fBTcl_DeleteEvents\fR.
.AP int flags in
What types of events to service. These flags are the same as those
passed to \fBTcl_DoOneEvent\fR.
.VS 8.1
.AP int mode in
Indicates whether events should be serviced by \fBTcl_ServiceAll\fR.
Must be one of \fBTCL_SERVICE_NONE\fR or \fBTCL_SERVICE_ALL\fR.
.VE
.BE
.SH INTRODUCTION
.PP
The interfaces described here are used to customize the Tcl event
loop. The two most common customizations are to add new sources of
events and to merge Tcl's event loop with some other event loop, such
as one provided by an application in which Tcl is embedded. Each of
these tasks is described in a separate section below.
.PP
The procedures in this manual entry are the building blocks out of which
the Tcl event notifier is constructed. The event notifier is the lowest
layer in the Tcl event mechanism. It consists of three things:
.IP [1]
Event sources: these represent the ways in which events can be
generated. For example, there is a timer event source that implements
the \fBTcl_CreateTimerHandler\fR procedure and the \fBafter\fR
command, and there is a file event source that implements the
\fBTcl_CreateFileHandler\fR procedure on Unix systems. An event
source must work with the notifier to detect events at the right
times, record them on the event queue, and eventually notify
higher-level software that they have occurred. The procedures
\fBTcl_CreateEventSource\fR, \fBTcl_DeleteEventSource\fR,
and \fBTcl_SetMaxBlockTime\fR, \fBTcl_QueueEvent\fR, and
\fBTcl_DeleteEvents\fR are used primarily by event sources.
.IP [2]
The event queue: for non-threaded applications,
there is a single queue for the whole application,
containing events that have been detected but not yet serviced. Event
sources place events onto the queue so that they may be processed in
order at appropriate times during the event loop. The event queue
guarantees a fair discipline of event handling, so that no event
source can starve the others. It also allows events to be saved for
servicing at a future time.
.VS 8.1
Threaded applications work in a
similar manner, except that there is a separate event queue for
each thread containing a Tcl interpreter.
\fBTcl_QueueEvent\fR is used (primarily
by event sources) to add events to the event queue and
\fBTcl_DeleteEvents\fR is used to remove events from the queue without
processing them. In a threaded application, \fBTcl_QueueEvent\fR adds
an event to the current thread's queue, and \fBTcl_ThreadQueueEvent\fR
adds an event to a queue in a specific thread.
.IP [3]
The event loop: in order to detect and process events, the application
enters a loop that waits for events to occur, places them on the event
queue, and then processes them. Most applications will do this by
calling the procedure \fBTcl_DoOneEvent\fR, which is described in a
separate manual entry.
.PP
Most Tcl applications need not worry about any of the internals of
the Tcl notifier. However, the notifier now has enough flexibility
to be retargeted either for a new platform or to use an external event
loop (such as the Motif event loop, when Tcl is embedded in a Motif
application). The procedures \fBTcl_WaitForEvent\fR and
\fBTcl_SetTimer\fR are normally implemented by Tcl, but may be
replaced with new versions to retarget the notifier (the
\fBTcl_InitNotifier\fR, \fBTcl_AlertNotifier\fR,
\fBTcl_FinalizeNotifier\fR, \fBTcl_Sleep\fR,
\fBTcl_CreateFileHandler\fR, and \fBTcl_DeleteFileHandler\fR must
also be replaced; see CREATING A NEW NOTIFIER below for details).
The procedures \fBTcl_ServiceAll\fR, \fBTcl_ServiceEvent\fR,
\fBTcl_GetServiceMode\fR, and \fBTcl_SetServiceMode\fR are provided
to help connect Tcl's event loop to an external event loop such as
Motif's.
.SH "NOTIFIER BASICS"
.VE
.PP
The easiest way to understand how the notifier works is to consider
what happens when \fBTcl_DoOneEvent\fR is called.
\fBTcl_DoOneEvent\fR is passed a \fIflags\fR argument that indicates
what sort of events it is OK to process and also whether or not to
block if no events are ready. \fBTcl_DoOneEvent\fR does the following
things:
.IP [1]
Check the event queue to see if it contains any events that can
be serviced. If so, service the first possible event, remove it
.VS 8.1
from the queue, and return. It does this by calling
\fBTcl_ServiceEvent\fR and passing in the \fIflags\fR argument.
.VE
.IP [2]
Prepare to block for an event. To do this, \fBTcl_DoOneEvent\fR
invokes a \fIsetup procedure\fR in each event source.
The event source will perform event-source specific initialization and
.VS 8.1
possibly call \fBTcl_SetMaxBlockTime\fR to limit how long
.VE
\fBTcl_WaitForEvent\fR will block if no new events occur.
.IP [3]
Call \fBTcl_WaitForEvent\fR. This procedure is implemented differently
on different platforms; it waits for an event to occur, based on the
information provided by the event sources.
It may cause the application to block if \fItimePtr\fR specifies
an interval other than 0.
\fBTcl_WaitForEvent\fR returns when something has happened,
such as a file becoming readable or the interval given by \fItimePtr\fR
expiring. If there are no events for \fBTcl_WaitForEvent\fR to
wait for, so that it would block forever, then it returns immediately
and \fBTcl_DoOneEvent\fR returns 0.
.IP [4]
Call a \fIcheck procedure\fR in each event source. The check
procedure determines whether any events of interest to this source
occurred. If so, the events are added to the event queue.
.IP [5]
Check the event queue to see if it contains any events that can
be serviced. If so, service the first possible event, remove it
from the queue, and return.
.IP [6]
See if there are idle callbacks pending. If so, invoke all of them and
return.
.IP [7]
Either return 0 to indicate that no events were ready, or go back to
step [2] if blocking was requested by the caller.
.SH "CREATING A NEW EVENT SOURCE"
.PP
An event source consists of three procedures invoked by the notifier,
plus additional C procedures that are invoked by higher-level code
to arrange for event-driven callbacks. The three procedures called
by the notifier consist of the setup and check procedures described
above, plus an additional procedure that is invoked when an event
is removed from the event queue for servicing.
.PP
The procedure \fBTcl_CreateEventSource\fR creates a new event source.
Its arguments specify the setup procedure and check procedure for
the event source.
\fISetupProc\fR should match the following prototype:
.CS
typedef void Tcl_EventSetupProc(
ClientData \fIclientData\fR,
int \fIflags\fR);
.CE
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument to \fBTcl_CreateEventSource\fR; it is typically used to
point to private information managed by the event source.
The \fIflags\fR argument will be the same as the \fIflags\fR
argument passed to \fBTcl_DoOneEvent\fR except that it will never
be 0 (\fBTcl_DoOneEvent\fR replaces 0 with \fBTCL_ALL_EVENTS\fR).
\fIFlags\fR indicates what kinds of events should be considered;
if the bit corresponding to this event source isn't set, the event
source should return immediately without doing anything. For
example, the file event source checks for the \fBTCL_FILE_EVENTS\fR
bit.
.PP
\fISetupProc\fR's job is to make sure that the application wakes up
when events of the desired type occur. This is typically done in a
platform-dependent fashion. For example, under Unix an event source
might call \fBTcl_CreateFileHandler\fR; under Windows it might
request notification with a Windows event. For timer-driven event
sources such as timer events or any polled event, the event source
can call \fBTcl_SetMaxBlockTime\fR to force the application to wake
up after a specified time even if no events have occurred.
.VS 8.1
If no event source calls \fBTcl_SetMaxBlockTime\fR
then \fBTcl_WaitForEvent\fR will wait as long as necessary for an
event to occur; otherwise, it will only wait as long as the shortest
interval passed to \fBTcl_SetMaxBlockTime\fR by one of the event
sources. If an event source knows that it already has events ready to
report, it can request a zero maximum block time. For example, the
setup procedure for the X event source looks to see if there are
events already queued. If there are, it calls
\fBTcl_SetMaxBlockTime\fR with a 0 block time so that
\fBTcl_WaitForEvent\fR does not block if there is no new data on the X
connection.
.VE
The \fItimePtr\fR argument to \fBTcl_WaitForEvent\fR points to
a structure that describes a time interval in seconds and
microseconds:
.CS
typedef struct Tcl_Time {
long \fIsec\fR;
long \fIusec\fR;
} Tcl_Time;
.CE
The \fIusec\fR field should be less than 1000000.
.PP
.VS 8.1
Information provided to \fBTcl_SetMaxBlockTime\fR
is only used for the next call to \fBTcl_WaitForEvent\fR; it is
discarded after \fBTcl_WaitForEvent\fR returns.
.VE
The next time an event wait is done each of the event sources'
setup procedures will be called again, and they can specify new
information for that event wait.
.PP
.VS 8.1
If the application uses an external event loop rather than
\fBTcl_DoOneEvent\fR, the event sources may need to call
\fBTcl_SetMaxBlockTime\fR at other times. For example, if a new event
handler is registered that needs to poll for events, the event source
may call \fBTcl_SetMaxBlockTime\fR to set the block time to zero to
force the external event loop to call Tcl. In this case,
\fBTcl_SetMaxBlockTime\fR invokes \fBTcl_SetTimer\fR with the shortest
interval seen since the last call to \fBTcl_DoOneEvent\fR or
\fBTcl_ServiceAll\fR.
.PP
In addition to the generic procedure \fBTcl_SetMaxBlockTime\fR, other
platform-specific procedures may also be available for
\fIsetupProc\fR, if there is additional information needed by
\fBTcl_WaitForEvent\fR on that platform. For example, on Unix systems
the \fBTcl_CreateFileHandler\fR interface can be used to wait for file events.
.VE
.PP
The second procedure provided by each event source is its check
procedure, indicated by the \fIcheckProc\fR argument to
\fBTcl_CreateEventSource\fR. \fICheckProc\fR must match the
following prototype:
.CS
typedef void Tcl_EventCheckProc(
ClientData \fIclientData\fR,
int \fIflags\fR);
.CE
The arguments to this procedure are the same as those for \fIsetupProc\fR.
\fBCheckProc\fR is invoked by \fBTcl_DoOneEvent\fR after it has waited
for events. Presumably at least one event source is now prepared to
queue an event. \fBTcl_DoOneEvent\fR calls each of the event sources
in turn, so they all have a chance to queue any events that are ready.
The check procedure does two things. First, it must see if any events
have triggered. Different event sources do this in different ways.
.PP
If an event source's check procedure detects an interesting event, it
must add the event to Tcl's event queue. To do this, the event source
calls \fBTcl_QueueEvent\fR. The \fIevPtr\fR argument is a pointer to
a dynamically allocated structure containing the event (see below for
more information on memory management issues). Each event source can
define its own event structure with whatever information is relevant
to that event source. However, the first element of the structure
must be a structure of type \fBTcl_Event\fR, and the address of this
structure is used when communicating between the event source and the
rest of the notifier. A \fBTcl_Event\fR has the following definition:
.CS
typedef struct {
Tcl_EventProc *\fIproc\fR;
struct Tcl_Event *\fInextPtr\fR;
} Tcl_Event;
.CE
The event source must fill in the \fIproc\fR field of
the event before calling \fBTcl_QueueEvent\fR.
The \fInextPtr\fR is used to link together the events in the queue
and should not be modified by the event source.
.PP
An event may be added to the queue at any of three positions, depending
on the \fIposition\fR argument to \fBTcl_QueueEvent\fR:
.IP \fBTCL_QUEUE_TAIL\fR 24
Add the event at the back of the queue, so that all other pending
events will be serviced first. This is almost always the right
place for new events.
.IP \fBTCL_QUEUE_HEAD\fR 24
Add the event at the front of the queue, so that it will be serviced
before all other queued events.
.IP \fBTCL_QUEUE_MARK\fR 24
Add the event at the front of the queue, unless there are other
events at the front whose position is \fBTCL_QUEUE_MARK\fR; if so,
add the new event just after all other \fBTCL_QUEUE_MARK\fR events.
This value of \fIposition\fR is used to insert an ordered sequence of
events at the front of the queue, such as a series of
Enter and Leave events synthesized during a grab or ungrab operation
in Tk.
.PP
.VS 8.1
When it is time to handle an event from the queue (steps 1 and 4
above) \fBTcl_ServiceEvent\fR will invoke the \fIproc\fR specified
.VE
in the first queued \fBTcl_Event\fR structure.
\fIProc\fR must match the following prototype:
.CS
typedef int Tcl_EventProc(
Tcl_Event *\fIevPtr\fR,
int \fIflags\fR);
.CE
The first argument to \fIproc\fR is a pointer to the event, which will
be the same as the first argument to the \fBTcl_QueueEvent\fR call that
added the event to the queue.
The second argument to \fIproc\fR is the \fIflags\fR argument for the
.VS 8.1
current call to \fBTcl_ServiceEvent\fR; this is used by the event source
.VE
to return immediately if its events are not relevant.
.PP
It is up to \fIproc\fR to handle the event, typically by invoking
one or more Tcl commands or C-level callbacks.
Once the event source has finished handling the event it returns 1
to indicate that the event can be removed from the queue.
If for some reason the event source decides that the event cannot
be handled at this time, it may return 0 to indicate that the event
.VS 8.1
should be deferred for processing later; in this case \fBTcl_ServiceEvent\fR
.VE
will go on to the next event in the queue and attempt to service it.
There are several reasons why an event source might defer an event.
One possibility is that events of this type are excluded by the
\fIflags\fR argument.
For example, the file event source will always return 0 if the
\fBTCL_FILE_EVENTS\fR bit isn't set in \fIflags\fR.
Another example of deferring events happens in Tk if
\fBTk_RestrictEvents\fR has been invoked to defer certain kinds
of window events.
.PP
.VS 8.1
When \fIproc\fR returns 1, \fBTcl_ServiceEvent\fR will remove the
event from the event queue and free its storage.
Note that the storage for an event must be allocated by
the event source (using \fBTcl_Alloc\fR or the Tcl macro \fBckalloc\fR)
before calling \fBTcl_QueueEvent\fR, but it
will be freed by \fBTcl_ServiceEvent\fR, not by the event source.
.PP
Threaded applications work in a
similar manner, except that there is a separate event queue for
each thread containing a Tcl interpreter.
Calling \fBTcl_QueueEvent\fR in a multithreaded application adds
an event to the current thread's queue.
To add an event to another thread's queue, use \fBTcl_ThreadQueueEvent\fR.
\fBTcl_ThreadQueueEvent\fR accepts as an argument a Tcl_ThreadId argument,
which uniquely identifies a thread in a Tcl application. To obtain the
Tcl_ThreadID for the current thread, use the \fBTcl_GetCurrentThread\fR
procedure. (A thread would then need to pass this identifier to other
threads for those threads to be able to add events to its queue.)
After adding an event to another thread's queue, you then typically
need to call \fBTcl_ThreadAlert\fR to "wake up" that thread's notifier to
alert it to the new event.
.PP
\fBTcl_DeleteEvents\fR can be used to explicitly remove one or more
events from the event queue. \fBTcl_DeleteEvents\fR calls \fIproc\fR
for each event in the queue, deleting those for with the procedure
returns 1. Events for which the procedure returns 0 are left in the
queue. \fIProc\fR should match the following prototype:
.CS
typedef int Tcl_EventDeleteProc(
Tcl_Event *\fIevPtr\fR,
ClientData \fIclientData\fR);
.CE
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument to \fBTcl_DeleteEvents\fR; it is typically used to point to
private information managed by the event source. The \fIevPtr\fR will
point to the next event in the queue.
.PP
\fBTcl_DeleteEventSource\fR deletes an event source. The \fIsetupProc\fR,
\fIcheckProc\fR, and \fIclientData\fR arguments must exactly match those
provided to the \fBTcl_CreateEventSource\fR for the event source to be deleted.
If no such source exists, \fBTcl_DeleteEventSource\fR has no effect.
.VE
.SH "CREATING A NEW NOTIFIER"
.PP
The notifier consists of all the procedures described in this manual
entry, plus \fBTcl_DoOneEvent\fR and \fBTcl_Sleep\fR, which are
.VS 8.1
available on all platforms, and \fBTcl_CreateFileHandler\fR and
\fBTcl_DeleteFileHandler\fR, which are Unix-specific. Most of these
procedures are generic, in that they are the same for all notifiers.
However, eight of the procedures are notifier-dependent:
\fBTcl_InitNotifier\fR, \fBTcl_AlertNotifier\fR, \fBTcl_FinalizeNotifier\fR,
\fBTcl_SetTimer\fR, \fBTcl_Sleep\fR, \fBTcl_WaitForEvent\fR,
\fBTcl_CreateFileHandler\fR and \fBTcl_DeleteFileHandler\fR. To
support a new platform or to integrate Tcl with an
application-specific event loop, you must write new versions of these
procedures.
.PP
\fBTcl_InitNotifier\fR initializes the notifier state and returns
a handle to the notifier state. Tcl calls this
procedure when initializing a Tcl interpreter. Similarly,
\fBTcl_FinalizeNotifier\fR shuts down the notifier, and is
called by \fBTcl_Finalize\fR when shutting down a Tcl interpreter.
.PP
\fBTcl_WaitForEvent\fR is the lowest-level procedure in the notifier;
it is responsible for waiting for an ``interesting'' event to occur or
for a given time to elapse. Before \fBTcl_WaitForEvent\fR is invoked,
each of the event sources' setup procedure will have been invoked.
The \fItimePtr\fR argument to
\fBTcl_WaitForEvent\fR gives the maximum time to block for an event,
based on calls to \fBTcl_SetMaxBlockTime\fR made by setup procedures
and on other information (such as the \fBTCL_DONT_WAIT\fR bit in
\fIflags\fR).
.PP
Ideally, \fBTcl_WaitForEvent\fR should only wait for an event
to occur; it should not actually process the event in any way.
Later on, the
event sources will process the raw events and create Tcl_Events on
the event queue in their \fIcheckProc\fR procedures.
However, on some platforms (such as Windows) this isn't possible;
events may be processed in \fBTcl_WaitForEvent\fR, including queuing
Tcl_Events and more (for example, callbacks for native widgets may be
invoked). The return value from \fBTcl_WaitForEvent\fR must be either
0, 1, or \-1. On platforms such as Windows where events get processed in
\fBTcl_WaitForEvent\fR, a return value of 1 means that there may be more
events still pending that haven't been processed. This is a sign to the
caller that it must call \fBTcl_WaitForEvent\fR again if it wants all
pending events to be processed. A 0 return value means that calling
\fBTcl_WaitForEvent\fR again will not have any effect: either this is a
platform where \fBTcl_WaitForEvent\fR only waits without doing any event
processing, or \fBTcl_WaitForEvent\fR knows for sure that there are no
additional events to process (e.g. it returned because the time
elapsed). Finally, a return value of \-1 means that the event loop is
no longer operational and the application should probably unwind and
terminate. Under Windows this happens when a WM_QUIT message is received;
under Unix it happens when \fBTcl_WaitForEvent\fR would have waited
forever because there were no active event sources and the timeout was
infinite.
.PP
\fBTcl_AlertNotifier\fR is used in multithreaded applications to allow
any thread to "wake up" the notifier to alert it to new events on its
queue. \fBTcl_AlertNotifier\fR requires as an argument the notifier
handle returned by \fBTcl_InitNotifier\fR.
.PP
If the notifier will be used with an external event loop, then it must
also support the \fBTcl_SetTimer\fR interface. \fBTcl_SetTimer\fR is
invoked by \fBTcl_SetMaxBlockTime\fR whenever the maximum blocking
time has been reduced. \fBTcl_SetTimer\fR should arrange for the
external event loop to invoke \fBTcl_ServiceAll\fR after the specified
interval even if no events have occurred. This interface is needed
because \fBTcl_WaitForEvent\fR isn't invoked when there is an external
event loop. If the
notifier will only be used from \fBTcl_DoOneEvent\fR, then
\fBTcl_SetTimer\fR need not do anything.
.PP
On Unix systems, the file event source also needs support from the
notifier. The file event source consists of the
\fBTcl_CreateFileHandler\fR and \fBTcl_DeleteFileHandler\fR
procedures, which are described in the \fBTcl_CreateFileHandler\fR
manual page.
.PP
The \fBTcl_Sleep\fR and \fBTcl_DoOneEvent\fR interfaces are described
in their respective manual pages.
.PP
The easiest way to create a new notifier is to look at the code
for an existing notifier, such as the files \fBunix/tclUnixNotfy.c\fR
or \fBwin/tclWinNotify.c\fR in the Tcl source distribution.
.SH "EXTERNAL EVENT LOOPS"
.PP
The notifier interfaces are designed so that Tcl can be embedded into
applications that have their own private event loops. In this case,
the application does not call \fBTcl_DoOneEvent\fR except in the case
of recursive event loops such as calls to the Tcl commands \fBupdate\fR
or \fBvwait\fR. Most of the time is spent in the external event loop
of the application. In this case the notifier must arrange for the
external event loop to call back into Tcl when something
happens on the various Tcl event sources. These callbacks should
arrange for appropriate Tcl events to be placed on the Tcl event queue.
.PP
Because the external event loop is not calling \fBTcl_DoOneEvent\fR on
a regular basis, it is up to the notifier to arrange for
\fBTcl_ServiceEvent\fR to be called whenever events are pending on the
Tcl event queue. The easiest way to do this is to invoke
\fBTcl_ServiceAll\fR at the end of each callback from the external
event loop. This will ensure that all of the event sources are
polled, any queued events are serviced, and any pending idle handlers
are processed before returning control to the application. In
addition, event sources that need to poll for events can call
\fBTcl_SetMaxBlockTime\fR to force the external event loop to call
Tcl even if no events are available on the system event queue.
.PP
As a side effect of processing events detected in the main external
event loop, Tcl may invoke \fBTcl_DoOneEvent\fR to start a recursive event
loop in commands like \fBvwait\fR. \fBTcl_DoOneEvent\fR will invoke
the external event loop, which will result in callbacks as described
in the preceding paragraph, which will result in calls to
\fBTcl_ServiceAll\fR. However, in these cases it is undesirable to
service events in \fBTcl_ServiceAll\fR. Servicing events there is
unnecessary because control will immediately return to the
external event loop and hence to \fBTcl_DoOneEvent\fR, which can
service the events itself. Furthermore, \fBTcl_DoOneEvent\fR is
supposed to service only a single event, whereas \fBTcl_ServiceAll\fR
normally services all pending events. To handle this situation,
\fBTcl_DoOneEvent\fR sets a flag for \fBTcl_ServiceAll\fR
that causes it to return without servicing any events.
This flag is called the \fIservice mode\fR;
\fBTcl_DoOneEvent\fR restores it to its previous value before it returns.
.PP
In some cases, however, it may be necessary for \fBTcl_ServiceAll\fR
to service events
even when it has been invoked from \fBTcl_DoOneEvent\fR. This happens
when there is yet another recursive event loop invoked via an
event handler called by \fBTcl_DoOneEvent\fR (such as one that is
part of a native widget). In this case, \fBTcl_DoOneEvent\fR may not
have a chance to service events so \fBTcl_ServiceAll\fR must service
them all. Any recursive event loop that calls an external event
loop rather than \fBTcl_DoOneEvent\fR must reset the service mode so
that all events get processed in \fBTcl_ServiceAll\fR. This is done
by invoking the \fBTcl_SetServiceMode\fR procedure. If
\fBTcl_SetServiceMode\fR is passed \fBTCL_SERVICE_NONE\fR, then calls
to \fBTcl_ServiceAll\fR will return immediately without processing any
events. If \fBTcl_SetServiceMode\fR is passed \fBTCL_SERVICE_ALL\fR,
then calls to \fBTcl_ServiceAll\fR will behave normally.
\fBTcl_SetServiceMode\fR returns the previous value of the service
mode, which should be restored when the recursive loop exits.
\fBTcl_GetServiceMode\fR returns the current value of the service
mode.
.VE
.SH "SEE ALSO"
\fBTcl_CreateFileHandler\fR, \fBTcl_DeleteFileHandler\fR, \fBTcl_Sleep\fR,
\fBTcl_DoOneEvent\fR, \fBThread(3)\fR
.SH KEYWORDS
event, notifier, event queue, event sources, file events, timer, idle, service mode, threads
tcl8.4.20/doc/registry.n 0000644 0036047 0045461 00000016306 11737050674 013521 0 ustar dgp 771div '\"
'\" Copyright (c) 1997 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.
'\"
.so man.macros
.TH registry n 1.1 registry "Tcl Bundled Packages"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
registry \- Manipulate the Windows registry
.SH SYNOPSIS
.sp
\fBpackage require registry 1.1\fR
.sp
\fBregistry \fIoption\fR \fIkeyName\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBregistry\fR package provides a general set of operations for
manipulating the Windows registry. The package implements the
\fBregistry\fR Tcl command. This command is only supported on the
Windows platform. Warning: this command should be used with caution
as a corrupted registry can leave your system in an unusable state.
.PP
\fIKeyName\fR is the name of a registry key. Registry keys must be
one of the following forms:
.IP
\fB\e\e\fIhostname\fB\e\fIrootname\fB\e\fIkeypath\fR
.IP
\fIrootname\fB\e\fIkeypath\fR
.IP
\fIrootname\fR
.PP
\fIHostname\fR specifies the name of any valid Windows
host that exports its registry. The \fIrootname\fR component must be
one of \fBHKEY_LOCAL_MACHINE\fR, \fBHKEY_USERS\fR,
.VS
\fBHKEY_CLASSES_ROOT\fR, \fBHKEY_CURRENT_USER\fR,
\fBHKEY_CURRENT_CONFIG\fR, \fBHKEY_PERFORMANCE_DATA\fR, or
\fBHKEY_DYN_DATA\fR. The \fIkeypath\fR can be one or more
.VE
registry key names separated by backslash (\fB\e\fR) characters.
.PP
\fIOption\fR indicates what to do with the registry key name. Any
unique abbreviation for \fIoption\fR is acceptable. The valid options
are:
.VS 8.4
.TP
\fBregistry broadcast \fIkeyName\fR ?\fI-timeout milliseconds\fR?
.
Sends a broadcast message to the system and running programs to notify them
of certain updates. This is necessary to propagate changes to key registry
keys like Environment. The timeout specifies the amount of time, in
milliseconds, to wait for applications to respond to the broadcast message.
It defaults to 3000. The following example demonstrates how to add a path
to the global Environment and notify applications of the change without
requiring a logoff/logon step (assumes admin privileges):
.CS
set regPath {HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment}
set curPath [registry get $regPath "Path"]
registry set $regPath "Path" "$curPath;$addPath"
registry broadcast "Environment"
.CE
.VE 8.4
.TP
\fBregistry delete \fIkeyName\fR ?\fIvalueName\fR?
.
If the optional \fIvalueName\fR argument is present, the specified
value under \fIkeyName\fR will be deleted from the registry. If the
optional \fIvalueName\fR is omitted, the specified key and any subkeys
or values beneath it in the registry hierarchy will be deleted. If
the key could not be deleted then an error is generated. If the key
did not exist, the command has no effect.
.TP
\fBregistry get \fIkeyName valueName\fR
.
Returns the data associated with the value \fIvalueName\fR under the key
\fIkeyName\fR. If either the key or the value does not exist, then an
error is generated. For more details on the format of the returned
data, see SUPPORTED TYPES, below.
.TP
\fBregistry keys \fIkeyName\fR ?\fIpattern\fR?
.
If \fIpattern\fR isn't specified, returns a list of names of all the
subkeys of \fIkeyName\fR. If \fIpattern\fR is specified, only those
names matching \fIpattern\fR are returned. Matching is determined
using the same rules as for \fBstring\fR \fBmatch\fR. If the
specified \fIkeyName\fR does not exist, then an error is generated.
.TP
\fBregistry set \fIkeyName\fR ?\fIvalueName data \fR?\fItype\fR??
.
If \fIvalueName\fR isn't specified, creates the key \fIkeyName\fR if
it doesn't already exist. If \fIvalueName\fR is specified, creates
the key \fIkeyName\fR and value \fIvalueName\fR if necessary. The
contents of \fIvalueName\fR are set to \fIdata\fR with the type
indicated by \fItype\fR. If \fItype\fR isn't specified, the type
\fBsz\fR is assumed. For more details on the data and type arguments,
see SUPPORTED TYPES below.
.TP
\fBregistry type \fIkeyName valueName\fR
.
Returns the type of the value \fIvalueName\fR in the key
\fIkeyName\fR. For more information on the possible types, see
SUPPORTED TYPES, below.
.TP
\fBregistry values \fIkeyName\fR ?\fIpattern\fR?
.
If \fIpattern\fR isn't specified, returns a list of names of all the
values of \fIkeyName\fR. If \fIpattern\fR is specified, only those
names matching \fIpattern\fR are returned. Matching is determined
using the same rules as for \fBstring\fR \fBmatch\fR.
.SH "SUPPORTED TYPES"
Each value under a key in the registry contains some data of a
particular type in a type-specific representation. The \fBregistry\fR
command converts between this internal representation and one that can
be manipulated by Tcl scripts. In most cases, the data is simply
returned as a Tcl string. The type indicates the intended use for the
data, but does not actually change the representation. For some
types, the \fBregistry\fR command returns the data in a different form to
make it easier to manipulate. The following types are recognized by the
registry command:
.TP 17
\fBbinary\fR
.
The registry value contains arbitrary binary data. The data is represented
exactly in Tcl, including any embedded nulls.
.TP
\fBnone\fR
.
The registry value contains arbitrary binary data with no defined
type. The data is represented exactly in Tcl, including any embedded
nulls.
.TP
\fBsz\fR
.
The registry value contains a null-terminated string. The data is
represented in Tcl as a string.
.TP
\fBexpand_sz\fR
.
The registry value contains a null-terminated string that contains
unexpanded references to environment variables in the normal Windows
style (for example, "%PATH%"). The data is represented in Tcl as a
string.
.TP
\fBdword\fR
.
The registry value contains a little-endian 32-bit number. The data is
represented in Tcl as a decimal string.
.TP
\fBdword_big_endian\fR
.
The registry value contains a big-endian 32-bit number. The data is
represented in Tcl as a decimal string.
.TP
\fBlink\fR
.
The registry value contains a symbolic link. The data is represented
exactly in Tcl, including any embedded nulls.
.TP
\fBmulti_sz\fR
.
The registry value contains an array of null-terminated strings. The
data is represented in Tcl as a list of strings.
.TP
\fBresource_list\fR
.
The registry value contains a device-driver resource list. The data
is represented exactly in Tcl, including any embedded nulls.
.PP
In addition to the symbolically named types listed above, unknown
types are identified using a 32-bit integer that corresponds to the
type code returned by the system interfaces. In this case, the data
is represented exactly in Tcl, including any embedded nulls.
.SH "PORTABILITY ISSUES"
The registry command is only available on Windows.
.SH EXAMPLE
Print out how double-clicking on a Tcl script file will invoke a Tcl
interpreter:
.CS
package require registry
set ext .tcl
# Read the type name
set type [\fBregistry get\fR HKEY_CLASSES_ROOT\e\e$ext {}]
# Work out where to look for the command
set path HKEY_CLASSES_ROOT\e\e$type\e\eShell\e\eOpen\e\ecommand
# Read the command!
set command [\fBregistry get\fR $path {}]
puts "$ext opens with $command"
.CE
.SH KEYWORDS
registry
tcl8.4.20/doc/fcopy.n 0000644 0036047 0045461 00000012121 11737050674 012760 0 ustar dgp 771div '\"
'\" Copyright (c) 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.
'\"
.so man.macros
.TH fcopy n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
fcopy \- Copy data from one channel to another.
.SH SYNOPSIS
\fBfcopy \fIinchan\fR \fIoutchan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR?
.BE
.SH DESCRIPTION
.PP
The \fBfcopy\fP command copies data from one I/O channel, \fIinchan\fR to another I/O channel, \fIoutchan\fR.
The \fBfcopy\fP command leverages the buffering in the Tcl I/O system to
avoid extra copies and to avoid buffering too much data in
main memory when copying large files to slow destinations like
network sockets.
.PP
The \fBfcopy\fP
command transfers data from \fIinchan\fR until end of file
or \fIsize\fP bytes have been
transferred. If no \fB\-size\fP argument is given,
then the copy goes until end of file.
All the data read from \fIinchan\fR is copied to \fIoutchan\fR.
Without the \fB\-command\fP option, \fBfcopy\fP blocks until the copy is complete
and returns the number of bytes written to \fIoutchan\fR.
.PP
The \fB\-command\fP argument makes \fBfcopy\fP work in the background.
In this case it returns immediately and the \fIcallback\fP is invoked
later when the copy completes.
The \fIcallback\fP is called with
one or two additional
arguments that indicates how many bytes were written to \fIoutchan\fR.
If an error occurred during the background copy, the second argument is the
error string associated with the error.
With a background copy,
it is not necessary to put \fIinchan\fR or \fIoutchan\fR into
non-blocking mode; the \fBfcopy\fP command takes care of that automatically.
However, it is necessary to enter the event loop by using
the \fBvwait\fP command or by using Tk.
.PP
You are not allowed to do other I/O operations with
\fIinchan\fR or \fIoutchan\fR during a background fcopy.
If either \fIinchan\fR or \fIoutchan\fR get closed
while the copy is in progress, the current copy is stopped
and the command callback is \fInot\fP made.
If \fIinchan\fR is closed,
then all data already queued for \fIoutchan\fR is written out.
.PP
Note that \fIinchan\fR can become readable during a background copy.
You should turn off any \fBfileevent\fP handlers during a background
copy so those handlers do not interfere with the copy.
Any I/O attempted by a \fBfileevent\fP handler will get a "channel busy" error.
.PP
\fBFcopy\fR translates end-of-line sequences in \fIinchan\fR and \fIoutchan\fR
according to the \fB\-translation\fR option
for these channels.
See the manual entry for \fBfconfigure\fR for details on the
\fB\-translation\fR option.
The translations mean that the number of bytes read from \fIinchan\fR
can be different than the number of bytes written to \fIoutchan\fR.
Only the number of bytes written to \fIoutchan\fR is reported,
either as the return value of a synchronous \fBfcopy\fP or
as the argument to the callback for an asynchronous \fBfcopy\fP.
.PP
\fBFcopy\fR obeys the encodings configured for the channels. This
means that the incoming characters are converted internally first
UTF-8 and then into the encoding of the channel \fBfcopy\fR writes
to. See the manual entry for \fBfconfigure\fR for details on the
\fB\-encoding\fR option. No conversion is done if both channels are
set to encoding "binary". If only the output channel is set to
encoding "binary" the system will write the internal UTF-8
representation of the incoming characters. If only the input channel
is set to encoding "binary" the system will assume that the incoming
bytes are valid UTF-8 characters and convert them according to the
output encoding. The behaviour of the system for bytes which are not
valid UTF-8 characters is undefined in this case.
.SH EXAMPLE
.PP
This first example shows how the callback gets
passed the number of bytes transferred.
It also uses vwait to put the application into the event loop.
Of course, this simplified example could be done without the command
callback.
.DS
proc Cleanup {in out bytes {error {}}} {
global total
set total $bytes
close $in
close $out
if {[string length $error] != 0} {
# error occurred during the copy
}
}
set in [open $file1]
set out [socket $server $port]
fcopy $in $out -command [list Cleanup $in $out]
vwait total
.DE
.PP
The second example copies in chunks and tests for end of file
in the command callback
.DS
proc CopyMore {in out chunk bytes {error {}}} {
global total done
incr total $bytes
if {([string length $error] != 0) || [eof $in]} {
set done $total
close $in
close $out
} else {
fcopy $in $out -command [list CopyMore $in $out $chunk] \\
-size $chunk
}
}
set in [open $file1]
set out [socket $server $port]
set chunk 1024
set total 0
fcopy $in $out -command [list CopyMore $in $out $chunk] -size $chunk
vwait done
.DE
.SH "SEE ALSO"
eof(n), fblocked(n), fconfigure(n)
.SH KEYWORDS
blocking, channel, end of line, end of file, nonblocking, read, translation
tcl8.4.20/doc/DoWhenIdle.3 0000644 0036047 0045461 00000006370 11737050674 013540 0 ustar dgp 771div '\"
'\" Copyright (c) 1990 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_DoWhenIdle 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_DoWhenIdle, Tcl_CancelIdleCall \- invoke a procedure when there are no pending events
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_DoWhenIdle\fR(\fIproc, clientData\fR)
.sp
\fBTcl_CancelIdleCall\fR(\fIproc, clientData\fR)
.SH ARGUMENTS
.AS Tcl_IdleProc clientData
.AP Tcl_IdleProc *proc in
Procedure to invoke.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_DoWhenIdle\fR arranges for \fIproc\fR to be invoked
when the application becomes idle. The application is
considered to be idle when \fBTcl_DoOneEvent\fR has been
called, couldn't find any events to handle, and is about
to go to sleep waiting for an event to occur. At this
point all pending \fBTcl_DoWhenIdle\fR handlers are
invoked. For each call to \fBTcl_DoWhenIdle\fR there will
be a single call to \fIproc\fR; after \fIproc\fR is
invoked the handler is automatically removed.
\fBTcl_DoWhenIdle\fR is only usable in programs that
use \fBTcl_DoOneEvent\fR to dispatch events.
.PP
\fIProc\fR should have arguments and result that match the
type \fBTcl_IdleProc\fR:
.CS
typedef void Tcl_IdleProc(ClientData \fIclientData\fR);
.CE
The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR
argument given to \fBTcl_DoWhenIdle\fR. Typically, \fIclientData\fR
points to a data structure containing application-specific information about
what \fIproc\fR should do.
.PP
\fBTcl_CancelIdleCall\fR
may be used to cancel one or more previous
calls to \fBTcl_DoWhenIdle\fR: if there is a \fBTcl_DoWhenIdle\fR
handler registered for \fIproc\fR and \fIclientData\fR, then it
is removed without invoking it. If there is more than one
handler on the idle list that refers to \fIproc\fR and \fIclientData\fR,
all of the handlers are removed. If no existing handlers match
\fIproc\fR and \fIclientData\fR then nothing happens.
.PP
\fBTcl_DoWhenIdle\fR is most useful in situations where
(a) a piece of work will have to be done but (b) it's
possible that something will happen in the near future
that will change what has to be done or require something
different to be done. \fBTcl_DoWhenIdle\fR allows the
actual work to be deferred until all pending events have
been processed. At this point the exact work to be done
will presumably be known and it can be done exactly once.
.PP
For example, \fBTcl_DoWhenIdle\fR might be used by an editor
to defer display updates until all pending commands have
been processed. Without this feature, redundant redisplays
might occur in some situations, such as the processing of
a command file.
.SH BUGS
.PP
At present it is not safe for an idle callback to reschedule itself
continuously. This will interact badly with certain features of Tk
that attempt to wait for all idle callbacks to complete. If you would
like for an idle callback to reschedule itself continuously, it is
better to use a timer handler with a zero timeout period.
.SH KEYWORDS
callback, defer, idle callback
tcl8.4.20/doc/WrongNumArgs.3 0000644 0036047 0045461 00000005452 11737050674 014147 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_WrongNumArgs 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_WrongNumArgs \- generate standard error message for wrong number of arguments
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR)
.SH ARGUMENTS
.AS Tcl_Interp "*CONST objv[]"
.AP Tcl_Interp interp in
Interpreter in which error will be reported: error message gets stored
in its result object.
.AP int objc in
Number of leading arguments from \fIobjv\fR to include in error
message.
.AP Tcl_Obj "*CONST\ objv[]" in
Arguments to command that had the wrong number of arguments.
.AP "CONST char" *message in
Additional error information to print after leading arguments
from \fIobjv\fR. This typically gives the acceptable syntax
of the command. This argument may be NULL.
.BE
.SH DESCRIPTION
.PP
\fBTcl_WrongNumArgs\fR is a utility procedure that is invoked by
command procedures when they discover that they have received the
wrong number of arguments. \fBTcl_WrongNumArgs\fR generates a
standard error message and stores it in the result object of
\fIinterp\fR. The message includes the \fIobjc\fR initial
elements of \fIobjv\fR plus \fImessage\fR. For example, if
\fIobjv\fR consists of the values \fBfoo\fR and \fBbar\fR,
\fIobjc\fR is 1, and \fImessage\fR is ``\fBfileName count\fR''
then \fIinterp\fR's result object will be set to the following
string:
.CS
wrong # args: should be "foo fileName count"
.CE
If \fIobjc\fR is 2, the result will be set to the following string:
.CS
wrong # args: should be "foo bar fileName count"
.CE
\fIObjc\fR is usually 1, but may be 2 or more for commands like
\fBstring\fR and the Tk widget commands, which use the first argument
as a subcommand.
.PP
Some of the objects in the \fIobjv\fR array may be abbreviations for
a subcommand. The command
\fBTcl_GetIndexFromObj\fR will convert the abbreviated string object
into an \fIindexObject\fR. If an error occurs in the parsing of the
subcommand we would like to use the full subcommand name rather than
the abbreviation. If the \fBTcl_WrongNumArgs\fR command finds any
\fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand
name in the error message instead of the abbreviated name that was
originally passed in. Using the above example, lets assume that
\fIbar\fR is actually an abbreviation for \fIbarfly\fR and the object
is now an indexObject because it was passed to
\fBTcl_GetIndexFromObj\fR. In this case the error message would be:
.CS
wrong # args: should be "foo barfly fileName count"
.CE
.SH "SEE ALSO"
Tcl_GetIndexFromObj
.SH KEYWORDS
command, error message, wrong number of arguments
tcl8.4.20/doc/puts.n 0000644 0036047 0045461 00000006540 12052456743 012641 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH puts n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
puts \- Write to a channel
.SH SYNOPSIS
\fBputs \fR?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR
.BE
.SH DESCRIPTION
.PP
Writes the characters given by \fIstring\fR to the channel given
by \fIchannelId\fR.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return
value from an invocation of \fBopen\fR or \fBsocket\fR, or the result
of a channel creation command provided by a Tcl extension. The channel
must have been opened for output.
.VE
.PP
If no \fIchannelId\fR is specified then it defaults to
\fBstdout\fR. \fBPuts\fR normally outputs a newline character after
\fIstring\fR, but this feature may be suppressed by specifying the
\fB\-nonewline\fR switch.
.PP
Newline characters in the output are translated by \fBputs\fR to
platform-specific end-of-line sequences according to the current
value of the \fB\-translation\fR option for the channel (for example,
on PCs newlines are normally replaced with carriage-return-linefeed
sequences).
See the \fBfconfigure\fR manual entry for a discussion on ways in
which \fBfconfigure\fR will alter output.
.PP
Tcl buffers output internally, so characters written with \fBputs\fR
may not appear immediately on the output file or device; Tcl will
normally delay output until the buffer is full or the channel is
closed.
You can force output to appear immediately with the \fBflush\fR
command.
.PP
When the output buffer fills up, the \fBputs\fR command will normally
block until all the buffered data has been accepted for output by the
operating system.
If \fIchannelId\fR is in nonblocking mode then the \fBputs\fR command
will not block even if the operating system cannot accept the data.
Instead, Tcl continues to buffer the data and writes it in the
background as fast as the underlying file or device can accept it.
The application must use the Tcl event loop for nonblocking output
to work; otherwise Tcl never finds out that the file or device is
ready for more output data.
It is possible for an arbitrarily large amount of data to be
buffered for a channel in nonblocking mode, which could consume a
large amount of memory.
To avoid wasting memory, nonblocking I/O should normally
be used in an event-driven fashion with the \fBfileevent\fR command
(don't invoke \fBputs\fR unless you have recently been notified
via a file event that the channel is ready for more output data).
.SH EXAMPLES
Write a short message to the console (or wherever \fBstdout\fR is
directed):
.CS
\fBputs\fR "Hello, World!"
.CE
.PP
Print a message in several parts:
.CS
\fBputs\fR -nonewline "Hello, "
\fBputs\fR "World!"
.CE
.PP
Print a message to the standard error channel:
.CS
\fBputs\fR stderr "Hello, World!"
.CE
.PP
Append a log message to a file:
.CS
set chan [open my.log a]
set timestamp [clock format [clock seconds]]
\fBputs\fR $chan "$timestamp - Hello, World!"
close $chan
.CE
.SH "SEE ALSO"
file(n), fileevent(n), Tcl_StandardChannels(3)
.SH KEYWORDS
channel, newline, output, write
tcl8.4.20/doc/after.n 0000644 0036047 0045461 00000012512 11737050674 012745 0 ustar dgp 771div '\"
'\" Copyright (c) 1990-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH after n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
after \- Execute a command after a time delay
.SH SYNOPSIS
\fBafter \fIms\fR
.sp
\fBafter \fIms \fR?\fIscript script script ...\fR?
.sp
\fBafter cancel \fIid\fR
.sp
\fBafter cancel \fIscript script script ...\fR
.sp
\fBafter idle \fR?\fIscript script script ...\fR?
.sp
\fBafter info \fR?\fIid\fR?
.BE
.SH DESCRIPTION
.PP
This command is used to delay execution of the program or to execute
a command in background sometime in the future. It has several forms,
depending on the first argument to the command:
.TP
\fBafter \fIms\fR
\fIMs\fR must be an integer giving a time in milliseconds.
The command sleeps for \fIms\fR milliseconds and then returns.
While the command is sleeping the application does not respond to
events.
.TP
\fBafter \fIms \fR?\fIscript script script ...\fR?
In this form the command returns immediately, but it arranges
for a Tcl command to be executed \fIms\fR milliseconds later as an
event handler.
The command will be executed exactly once, at the given time.
The delayed command is formed by concatenating all the \fIscript\fR
arguments in the same fashion as the \fBconcat\fR command.
The command will be executed at global level (outside the context
of any Tcl procedure).
If an error occurs while executing the delayed command then the
\fBbgerror\fR mechanism is used to report the error.
The \fBafter\fR command returns an identifier that can be used
to cancel the delayed command using \fBafter cancel\fR.
.TP
\fBafter cancel \fIid\fR
Cancels the execution of a delayed command that
was previously scheduled.
\fIId\fR indicates which command should be canceled; it must have
been the return value from a previous \fBafter\fR command.
If the command given by \fIid\fR has already been executed then
the \fBafter cancel\fR command has no effect.
.TP
\fBafter cancel \fIscript script ...\fR
This command also cancels the execution of a delayed command.
The \fIscript\fR arguments are concatenated together with space
separators (just as in the \fBconcat\fR command).
If there is a pending command that matches the string, it is
cancelled and will never be executed; if no such command is
currently pending then the \fBafter cancel\fR command has no effect.
.TP
\fBafter idle \fIscript \fR?\fIscript script ...\fR?
Concatenates the \fIscript\fR arguments together with space
separators (just as in the \fBconcat\fR command), and arranges
for the resulting script to be evaluated later as an idle callback.
The script will be run exactly once, the next time the event
loop is entered and there are no events to process.
The command returns an identifier that can be used
to cancel the delayed command using \fBafter cancel\fR.
If an error occurs while executing the script then the
\fBbgerror\fR mechanism is used to report the error.
.TP
\fBafter info \fR?\fIid\fR?
This command returns information about existing event handlers.
If no \fIid\fR argument is supplied, the command returns
a list of the identifiers for all existing
event handlers created by the \fBafter\fR command for this
interpreter.
If \fIid\fR is supplied, it specifies an existing handler;
\fIid\fR must have been the return value from some previous call
to \fBafter\fR and it must not have triggered yet or been cancelled.
In this case the command returns a list with two elements.
The first element of the list is the script associated
with \fIid\fR, and the second element is either
\fBidle\fR or \fBtimer\fR to indicate what kind of event
handler it is.
.LP
The \fBafter \fIms\fR and \fBafter idle\fR forms of the command
assume that the application is event driven: the delayed commands
will not be executed unless the application enters the event loop.
In applications that are not normally event-driven, such as
\fBtclsh\fR, the event loop can be entered with the \fBvwait\fR
and \fBupdate\fR commands.
.SH "EXAMPLES"
This defines a command to make Tcl do nothing at all for \fIN\fR
seconds:
.CS
proc sleep {N} {
\fBafter\fR [expr {int($N * 1000)}]
}
.CE
.PP
This arranges for the command \fIwake_up\fR to be run in eight hours
(providing the event loop is active at that time):
.CS
\fBafter\fR [expr {1000 * 60 * 60 * 8}] wake_up
.CE
.PP
The following command can be used to do long-running calculations (as
represented here by \fI::my_calc::one_step\fR, which is assumed to
return a boolean indicating whether another step should be performed)
in a step-by-step fashion, though the calculation itself needs to be
arranged so it can work step-wise. This technique is extra careful to
ensure that the event loop is not starved by the rescheduling of
processing steps (arranging for the next step to be done using an
already-triggered timer event only when the event queue has been
drained) and is useful when you want to ensure that a Tk GUI remains
responsive during a slow task.
.CS
proc doOneStep {} {
if {[::my_calc::one_step]} {
\fBafter idle\fR [list \fBafter\fR 0 doOneStep]
}
}
doOneStep
.CE
.SH "SEE ALSO"
bgerror(n), concat(n), update(n), vwait(n)
.SH KEYWORDS
cancel, delay, idle callback, sleep, time
tcl8.4.20/doc/linsert.n 0000644 0036047 0045461 00000003341 11737050674 013324 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH linsert n 8.2 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
linsert \- Insert elements into a list
.SH SYNOPSIS
\fBlinsert \fIlist index element \fR?\fIelement element ...\fR?
.BE
.SH DESCRIPTION
.PP
This command produces a new list from \fIlist\fR by inserting all of the
\fIelement\fR arguments just before the \fIindex\fR'th element of
\fIlist\fR. Each \fIelement\fR argument will become a separate element of
the new list. If \fIindex\fR is less than or equal to zero, then the new
elements are inserted at the beginning of the list. If \fIindex\fR has the
value \fBend\fR, or if it is greater than or equal to the number of
elements in the list, then the new elements are appended to the list.
\fBend\-\fIinteger\fR refers to the last element in the list minus the
specified integer offset.
.SH EXAMPLE
Putting some values into a list, first indexing from the start and
then indexing from the end, and then chaining them together:
.CS
set oldList {the fox jumps over the dog}
set midList [\fBlinsert\fR $oldList 1 quick]
set newList [\fBlinsert\fR $midList end-1 lazy]
# The old lists still exist though...
set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy]
.CE
.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), llength(n), lsearch(n),
lset(n), lsort(n), lrange(n), lreplace(n)
.VE
.SH KEYWORDS
element, insert, list
tcl8.4.20/doc/fconfigure.n 0000644 0036047 0045461 00000027024 12052456743 013775 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH fconfigure n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
fconfigure \- Set and get options on a channel
.SH SYNOPSIS
.nf
\fBfconfigure \fIchannelId\fR
\fBfconfigure \fIchannelId\fR \fIname\fR
\fBfconfigure \fIchannelId\fR \fIname value \fR?\fIname value ...\fR?
.fi
.BE
.SH DESCRIPTION
.PP
The \fBfconfigure\fR command sets and retrieves options for channels.
.PP
\fIChannelId\fR identifies the channel for which to set or query an
option and must refer to an open channel such as a Tcl standard
channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return
value from an invocation of \fBopen\fR or \fBsocket\fR, or the result
of a channel creation command provided by a Tcl extension.
.PP
If no \fIname\fR or \fIvalue\fR arguments are supplied, the command
returns a list containing alternating option names and values for the channel.
If \fIname\fR is supplied but no \fIvalue\fR then the command returns
the current value of the given option.
If one or more pairs of \fIname\fR and \fIvalue\fR are supplied, the
command sets each of the named options to the corresponding \fIvalue\fR;
in this case the return value is an empty string.
.PP
The options described below are supported for all channels. In addition,
each channel type may add options that only it supports. See the manual
entry for the command that creates each type of channels for the options
that that specific type of channel supports. For example, see the manual
entry for the \fBsocket\fR command for its additional options.
.TP
\fB\-blocking\fR \fIboolean\fR
The \fB\-blocking\fR option determines whether I/O operations on the
channel can cause the process to block indefinitely.
The value of the option must be a proper boolean value.
Channels are normally in blocking mode; if a channel is placed into
nonblocking mode it will affect the operation of the \fBgets\fR,
\fBread\fR, \fBputs\fR, \fBflush\fR, and \fBclose\fR commands;
see the documentation for those commands for details.
For nonblocking mode to work correctly, the application must be
using the Tcl event loop (e.g. by calling \fBTcl_DoOneEvent\fR or
invoking the \fBvwait\fR command).
.TP
\fB\-buffering\fR \fInewValue\fR
.
If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output
until its internal buffer is full or until the \fBflush\fR command is
invoked. If \fInewValue\fR is \fBline\fR, then the I/O system will
automatically flush output for the channel whenever a newline character
is output. If \fInewValue\fR is \fBnone\fR, the I/O system will flush
automatically after every output operation. The default is for
\fB\-buffering\fR to be set to \fBfull\fR except for channels that
connect to terminal-like devices; for these channels the initial setting
is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are
initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR.
.TP
\fB\-buffersize\fR \fInewSize\fR
.
\fINewvalue\fR must be an integer; its value is used to set the size of
buffers, in bytes, subsequently allocated for this channel to store input
or output. \fINewvalue\fR must be between ten and one million, allowing
buffers of ten to one million bytes in size.
.TP
\fB\-encoding\fR \fIname\fR
.
This option is used to specify the encoding of the channel, so that the data
can be converted to and from Unicode for use in Tcl. For instance, in
order for Tcl to read characters from a Japanese file in \fBshiftjis\fR
and properly process and display the contents, the encoding would be set
to \fBshiftjis\fR. Thereafter, when reading from the channel, the bytes in
the Japanese file would be converted to Unicode as they are read.
Writing is also supported \- as Tcl strings are written to the channel they
will automatically be converted to the specified encoding on output.
.RS
.PP
If a file contains pure binary data (for instance, a JPEG image), the
encoding for the channel should be configured to be \fBbinary\fR. Tcl
will then assign no interpretation to the data in the file and simply read or
write raw bytes. The Tcl \fBbinary\fR command can be used to manipulate this
byte-oriented data.
.PP
The default encoding for newly opened channels is the same platform- and
locale-dependent system encoding used for interfacing with the operating
system.
.RE
.TP
\fB\-eofchar\fR \fIchar\fR
.TP
\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR
.
This option supports DOS file systems that use Control-z (\ex1a) as an
end of file marker. If \fIchar\fR is not an empty string, then this
character signals end-of-file when it is encountered during input. For
output, the end-of-file character is output when the channel is closed.
If \fIchar\fR is the empty string, then there is no special end of file
character marker. For read-write channels, a two-element list specifies
the end of file marker for input and output, respectively. As a
convenience, when setting the end-of-file character for a read-write
channel you can specify a single value that will apply to both reading
and writing. When querying the end-of-file character of a read-write
channel, a two-element list will always be returned. The default value
for \fB\-eofchar\fR is the empty string in all cases except for files
under Windows. In that case the \fB\-eofchar\fR is Control-z (\ex1a) for
reading and the empty string for writing.
.TP
\fB\-translation\fR \fImode\fR
.TP
\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR
.
In Tcl scripts the end of a line is always represented using a single
newline character (\en). However, in actual files and devices the end of
a line may be represented differently on different platforms, or even for
different devices on the same platform. For example, under UNIX newlines
are used in files, whereas carriage-return-linefeed sequences are
normally used in network connections. On input (i.e., with \fBgets\fP
and \fBread\fP) the Tcl I/O system automatically translates the external
end-of-line representation into newline characters. Upon output (i.e.,
with \fBputs\fP), the I/O system translates newlines to the external
end-of-line representation. The default translation mode, \fBauto\fP,
handles all the common cases automatically, but the \fB\-translation\fR
option provides explicit control over the end of line translations.
.RS
.PP
The value associated with \fB\-translation\fR is a single item for
read-only and write-only channels. The value is a two-element list for
read-write channels; the read translation mode is the first element of
the list, and the write translation mode is the second element. As a
convenience, when setting the translation mode for a read-write channel
you can specify a single value that will apply to both reading and
writing. When querying the translation mode of a read-write channel, a
two-element list will always be returned. The following values are
currently supported:
.TP
\fBauto\fR
.
As the input translation mode, \fBauto\fR treats any of newline
(\fBlf\fP), carriage return (\fBcr\fP), or carriage return followed by a
newline (\fBcrlf\fP) as the end of line representation. The end of line
representation can even change from line-to-line, and all cases are
translated to a newline. As the output translation mode, \fBauto\fR
chooses a platform specific representation; for sockets on all platforms
Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses \fBlf\fR and for
the various flavors of
Windows it chooses \fBcrlf\fR. The default setting for
\fB\-translation\fR is \fBauto\fR for both input and output.
.TP
\fBbinary\fR
.
No end-of-line translations are performed. This is nearly identical to
\fBlf\fP mode, except that in addition \fBbinary\fP mode also sets the
end-of-file character to the empty string (which disables it) and sets the
encoding to \fBbinary\fR (which disables encoding filtering). See the
description of \fB\-eofchar\fR and \fB\-encoding\fR for more information.
.PP
.RS
Internally, i.e. when it comes to the actual behaviour of the
translator this value \fBis\fR identical to \fBlf\fR and is therefore
reported as such when queried. Even if \fBbinary\fR was used to set
the translation.
.RE
.TP
\fBcr\fR
.
The end of a line in the underlying file or device is represented by a
single carriage return character. As the input translation mode,
\fBcr\fP mode converts carriage returns to newline characters. As the
output translation mode, \fBcr\fP mode translates newline characters to
carriage returns. This mode is typically used on Macintosh platforms.
.TP
\fBcrlf\fR
.
The end of a line in the underlying file or device is represented by a
carriage return character followed by a linefeed character. As the input
translation mode, \fBcrlf\fP mode converts carriage-return-linefeed
sequences to newline characters. As the output translation mode,
\fBcrlf\fP mode translates newline characters to carriage-return-linefeed
sequences. This mode is typically used on Windows platforms and for
network connections.
.TP
\fBlf\fR
.
The end of a line in the underlying file or device is represented by a
single newline (linefeed) character. In this mode no translations occur
during either input or output. This mode is typically used on UNIX
platforms.
.RE
.PP
.SH "STANDARD CHANNELS"
.PP
The Tcl standard channels (\fBstdin\fR, \fBstdout\fR, and \fBstderr\fR)
can be configured through this command like every other channel opened
by the Tcl library. Beyond the standard options described above they
will also support any special option according to their current type.
If, for example, a Tcl application is started by the \fBinet\fR
super-server common on Unix system its Tcl standard channels will be
sockets and thus support the socket options.
.SH EXAMPLES
Instruct Tcl to always send output to \fBstdout\fR immediately,
whether or not it is to a terminal:
.CS
\fBfconfigure\fR stdout -buffering none
.CE
.PP
Open a socket and read lines from it without ever blocking the
processing of other events:
.CS
set s [socket some.where.com 12345]
\fBfconfigure\fR $s -blocking 0
fileevent $s readable "readMe $s"
proc readMe chan {
if {[gets $chan line] < 0} {
if {[eof $chan]} {
close $chan
return
}
# Could not read a complete line this time; Tcl's
# internal buffering will hold the partial line for us
# until some more data is available over the socket.
} else {
puts stdout $line
}
}
.CE
.PP
Read a PPM-format image from a file:
.CS
# Open the file and put it into Unix ASCII mode
set f [open teapot.ppm]
\fBfconfigure\fR $f \-encoding ascii \-translation lf
# Get the header
if {[gets $f] ne "P6"} {
error "not a raw\-bits PPM"
}
# Read lines until we have got non-comment lines
# that supply us with three decimal values.
set words {}
while {[llength $words] < 3} {
gets $f line
if {[string match "#*" $line]} continue
lappend words [eval concat [scan $line %d%d%d]]
}
# Those words supply the size of the image and its
# overall depth per channel. Assign to variables.
foreach {xSize ySize depth} $words {break}
# Now switch to binary mode to pull in the data,
# one byte per channel (red,green,blue) per pixel.
\fBfconfigure\fR $f \-translation binary
set numDataBytes [expr {3 * $xSize * $ySize}]
set data [read $f $numDataBytes]
close $f
.CE
.SH "SEE ALSO"
close(n), flush(n), gets(n), open(n), puts(n), read(n), socket(n),
Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, buffering, carriage return, end of line, flushing, linemode,
newline, nonblocking, platform, translation, encoding, filter, byte array,
binary
tcl8.4.20/doc/AddErrInfo.3 0000644 0036047 0045461 00000017731 11737050674 013536 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-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.
'\"
.so man.macros
.TH Tcl_AddErrorInfo 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_AddObjErrorInfo, Tcl_AddErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- record information about errors
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR)
.sp
\fBTcl_AddErrorInfo\fR(\fIinterp, message\fR)
.sp
\fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR)
.sp
\fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *) NULL\fR)
.sp
\fBTcl_SetErrorCodeVA\fR(\fIinterp, argList\fR)
.sp
CONST char *
\fBTcl_PosixError\fR(\fIinterp\fR)
.sp
void
\fBTcl_LogCommandInfo\fR(\fIinterp, script, command, commandLength\fR)
.SH ARGUMENTS
.AS Tcl_Interp *message
.AP Tcl_Interp *interp in
Interpreter in which to record information.
.AP char *message in
For \fBTcl_AddObjErrorInfo\fR,
this points to the first byte of an array of bytes
containing a string to record in the \fBerrorInfo\fR variable.
This byte array may contain embedded null bytes
unless \fIlength\fR is negative.
For \fBTcl_AddErrorInfo\fR,
this is a conventional C string to record in the \fBerrorInfo\fR variable.
.AP int length in
The number of bytes to copy from \fImessage\fR when
setting the \fBerrorInfo\fR variable.
If negative, all bytes up to the first null byte are used.
.AP Tcl_Obj *errorObjPtr in
This variable \fBerrorCode\fR will be set to this value.
.AP char *element in
String to record as one element of \fBerrorCode\fR variable.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.AP "CONST char" *script in
Pointer to first character in script containing command (must be <= command)
.AP "CONST char" *command in
Pointer to first character in command that generated the error
.AP int commandLength in
Number of bytes in command; -1 means use all bytes up to first null byte
.BE
.SH DESCRIPTION
.PP
These procedures are used to manipulate two Tcl global variables
that hold information about errors.
The variable \fBerrorInfo\fR holds a stack trace of the
operations that were in progress when an error occurred,
and is intended to be human-readable.
The variable \fBerrorCode\fR holds a list of items that
are intended to be machine-readable.
The first item in \fBerrorCode\fR identifies the class of
error that occurred
(e.g. POSIX means an error occurred in a POSIX system call)
and additional elements in \fBerrorCode\fR hold additional pieces
of information that depend on the class.
See the Tcl overview manual entry for details on the various
formats for \fBerrorCode\fR.
.PP
The \fBerrorInfo\fR variable is gradually built up as an
error unwinds through the nested operations.
Each time an error code is returned to \fBTcl_EvalObjEx\fR
(or \fBTcl_Eval\fR, which calls \fBTcl_EvalObjEx\fR)
it calls the procedure \fBTcl_AddObjErrorInfo\fR to add
additional text to \fBerrorInfo\fR describing the
command that was being executed when the error occurred.
By the time the error has been passed all the way back
to the application, it will contain a complete trace
of the activity in progress when the error occurred.
.PP
It is sometimes useful to add additional information to
\fBerrorInfo\fR beyond what can be supplied automatically
by \fBTcl_EvalObjEx\fR.
\fBTcl_AddObjErrorInfo\fR may be used for this purpose:
its \fImessage\fR and \fIlength\fR arguments describe an additional
string to be appended to \fBerrorInfo\fR.
For example, the \fBsource\fR command calls \fBTcl_AddObjErrorInfo\fR
to record the name of the file being processed and the
line number on which the error occurred;
for Tcl procedures, the procedure name and line number
within the procedure are recorded, and so on.
The best time to call \fBTcl_AddObjErrorInfo\fR is just after
\fBTcl_EvalObjEx\fR has returned \fBTCL_ERROR\fR.
In calling \fBTcl_AddObjErrorInfo\fR, you may find it useful to
use the \fBerrorLine\fR field of the interpreter (see the
\fBTcl_Interp\fR manual entry for details).
.PP
\fBTcl_AddErrorInfo\fR resembles \fBTcl_AddObjErrorInfo\fR
but differs in initializing \fBerrorInfo\fR from the string
value of the interpreter's result
if the error is just starting to be logged.
It does not use the result as a Tcl object
so any embedded null characters in the result
will cause information to be lost.
It also takes a conventional C string in \fImessage\fR
instead of \fBTcl_AddObjErrorInfo\fR's counted string.
.PP
The procedure \fBTcl_SetObjErrorCode\fR is used to set the
\fBerrorCode\fR variable. \fIerrorObjPtr\fR contains a list object
built up by the caller. \fBerrorCode\fR is set to this
value. \fBTcl_SetObjErrorCode\fR is typically invoked just
before returning an error in an object command. If an error is
returned without calling \fBTcl_SetObjErrorCode\fR or
\fBTcl_SetErrorCode\fR the Tcl interpreter automatically sets
\fBerrorCode\fR to \fBNONE\fR.
.PP
The procedure \fBTcl_SetErrorCode\fR is also used to set the
\fBerrorCode\fR variable. However, it takes one or more strings to
record instead of an object. Otherwise, it is similar to
\fBTcl_SetObjErrorCode\fR in behavior.
.PP
\fBTcl_SetErrorCodeVA\fR is the same as \fBTcl_SetErrorCode\fR except that
instead of taking a variable number of arguments it takes an argument list.
.PP
\fBTcl_PosixError\fR
sets the \fBerrorCode\fR variable after an error in a POSIX kernel call.
It reads the value of the \fBerrno\fR C variable and calls
\fBTcl_SetErrorCode\fR to set \fBerrorCode\fR in the \fBPOSIX\fR format.
The caller must previously have called \fBTcl_SetErrno\fR to set
\fBerrno\fR; this is necessary on some platforms (e.g. Windows) where Tcl
is linked into an application as a shared library, or when the error
occurs in a dynamically loaded extension. See the manual entry for
\fBTcl_SetErrno\fR for more information.
.PP
\fBTcl_PosixError\fR returns a human-readable diagnostic message
for the error
(this is the same value that will appear as the third element
in \fBerrorCode\fR).
It may be convenient to include this string as part of the
error message returned to the application in
the interpreter's result.
.PP
\fBTcl_LogCommandInfo\fR is invoked after an error occurs in an
interpreter. It adds information about the command that was being
executed when the error occurred to the \fBerrorInfo\fR variable, and
the line number stored internally in the interpreter is set. On the
first call to \fBTcl_LogCommandInfo\fR or \fBTcl_AddObjErrorInfo\fR
since an error occurred, the old information in \fBerrorInfo\fR is
deleted.
.PP
It is important to call the procedures described here rather than
setting \fBerrorInfo\fR or \fBerrorCode\fR directly with
\fBTcl_ObjSetVar2\fR.
The reason for this is that the Tcl interpreter keeps information
about whether these procedures have been called.
For example, the first time \fBTcl_AddObjErrorInfo\fR is called
for an error, it clears the existing value of \fBerrorInfo\fR
and adds the error message in the interpreter's result to the variable
before appending \fImessage\fR;
in subsequent calls, it just appends the new \fImessage\fR.
When \fBTcl_SetErrorCode\fR is called, it sets a flag indicating
that \fBerrorCode\fR has been set;
this allows the Tcl interpreter to set \fBerrorCode\fR to \fBNONE\fR
if it receives an error return
when \fBTcl_SetErrorCode\fR hasn't been called.
.PP
If the procedure \fBTcl_ResetResult\fR is called,
it clears all of the state associated with
\fBerrorInfo\fR and \fBerrorCode\fR
(but it doesn't actually modify the variables).
If an error had occurred, this will clear the error state to
make it appear as if no error had occurred after all.
.SH "SEE ALSO"
Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_Interp, Tcl_ResetResult, Tcl_SetErrno
.SH KEYWORDS
error, object, object result, stack, trace, variable
tcl8.4.20/doc/Backslash.3 0000644 0036047 0045461 00000002676 11737050674 013456 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Backslash \- parse a backslash sequence
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
char
\fBTcl_Backslash\fR(\fIsrc, countPtr\fR)
.SH ARGUMENTS
.AS char *countPtr
.AP char *src in
Pointer to a string starting with a backslash.
.AP int *countPtr out
If \fIcountPtr\fR isn't NULL, \fI*countPtr\fR gets filled
in with number of characters in the backslash sequence, including
the backslash character.
.BE
.SH DESCRIPTION
.PP
.VS 8.1
The use of \fBTcl_Backslash\fR is deprecated in favor of
\fBTcl_UtfBackslash\fR.
.PP
This is a utility procedure provided for backwards compatibility with
non-internationalized Tcl extensions. It parses a backslash sequence and
returns the low byte of the Unicode character corresponding to the sequence.
.VE
\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of
characters in the backslash sequence.
.PP
See the Tcl manual entry for information on the valid backslash sequences.
All of the sequences described in the Tcl manual entry are supported by
\fBTcl_Backslash\fR.
.VS 8.1 br
.SH "SEE ALSO"
Tcl(n), Tcl_UtfBackslash(3)
.VE
.SH KEYWORDS
backslash, parse
tcl8.4.20/doc/man.macros 0000644 0036047 0045461 00000011416 11737050674 013450 0 ustar dgp 771div '\" The definitions below are for supplemental macros used in Tcl/Tk
'\" manual entries.
'\"
'\" .AP type name in/out ?indent?
'\" Start paragraph describing an argument to a library procedure.
'\" type is type of argument (int, etc.), in/out is either "in", "out",
'\" or "in/out" to describe whether procedure reads or modifies arg,
'\" and indent is equivalent to second arg of .IP (shouldn't ever be
'\" needed; use .AS below instead)
'\"
'\" .AS ?type? ?name?
'\" Give maximum sizes of arguments for setting tab stops. Type and
'\" name are examples of largest possible arguments that will be passed
'\" to .AP later. If args are omitted, default tab stops are used.
'\"
'\" .BS
'\" Start box enclosure. From here until next .BE, everything will be
'\" enclosed in one large box.
'\"
'\" .BE
'\" End of box enclosure.
'\"
'\" .CS
'\" Begin code excerpt.
'\"
'\" .CE
'\" End code excerpt.
'\"
'\" .VS ?version? ?br?
'\" Begin vertical sidebar, for use in marking newly-changed parts
'\" of man pages. The first argument is ignored and used for recording
'\" the version when the .VS was added, so that the sidebars can be
'\" found and removed when they reach a certain age. If another argument
'\" is present, then a line break is forced before starting the sidebar.
'\"
'\" .VE
'\" End of vertical sidebar.
'\"
'\" .DS
'\" Begin an indented unfilled display.
'\"
'\" .DE
'\" End of indented unfilled display.
'\"
'\" .SO
'\" Start of list of standard options for a Tk widget. The
'\" options follow on successive lines, in four columns separated
'\" by tabs.
'\"
'\" .SE
'\" End of list of standard options for a Tk widget.
'\"
'\" .OP cmdName dbName dbClass
'\" Start of description of a specific option. cmdName gives the
'\" option's name as specified in the class command, dbName gives
'\" the option's name in the option database, and dbClass gives
'\" the option's class in the option database.
'\"
'\" .UL arg1 arg2
'\" Print arg1 underlined, then print arg2 normally.
'\"
'\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
.nr ^l \n(.l
.ad b
'\" # Start an argument description
.de AP
.ie !"\\$4"" .TP \\$4
.el \{\
. ie !"\\$2"" .TP \\n()Cu
. el .TP 15
.\}
.ta \\n()Au \\n()Bu
.ie !"\\$3"" \{\
\&\\$1 \\fI\\$2\\fP (\\$3)
.\".b
.\}
.el \{\
.br
.ie !"\\$2"" \{\
\&\\$1 \\fI\\$2\\fP
.\}
.el \{\
\&\\fI\\$1\\fP
.\}
.\}
..
'\" # define tabbing values for .AP
.de AS
.nr )A 10n
.if !"\\$1"" .nr )A \\w'\\$1'u+3n
.nr )B \\n()Au+15n
.\"
.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
.nr )C \\n()Bu+\\w'(in/out)'u+2n
..
.AS Tcl_Interp Tcl_CreateInterp in/out
'\" # BS - start boxed text
'\" # ^y = starting y location
'\" # ^b = 1
.de BS
.br
.mk ^y
.nr ^b 1u
.if n .nf
.if n .ti 0
.if n \l'\\n(.lu\(ul'
.if n .fi
..
'\" # BE - end boxed text (draw box now)
.de BE
.nf
.ti 0
.mk ^t
.ie n \l'\\n(^lu\(ul'
.el \{\
.\" Draw four-sided box normally, but don't draw top of
.\" box if the box started on an earlier page.
.ie !\\n(^b-1 \{\
\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.el \}\
\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.\}
.fi
.br
.nr ^b 0
..
'\" # VS - start vertical sidebar
'\" # ^Y = starting y location
'\" # ^v = 1 (for troff; for nroff this doesn't matter)
.de VS
.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
..
'\" # VE - end of vertical sidebar
.de VE
.ie n 'mc
.el \{\
.ev 2
.nf
.ti 0
.mk ^t
\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
.sp -1
.fi
.ev
.\}
.nr ^v 0
..
'\" # Special macro to handle page bottom: finish off current
'\" # box/sidebar if in box/sidebar mode, then invoked standard
'\" # page bottom macro.
.de ^B
.ev 2
'ti 0
'nf
.mk ^t
.if \\n(^b \{\
.\" Draw three-sided box if this is the box's first page,
.\" draw two sides but no top otherwise.
.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.\}
.if \\n(^v \{\
.nr ^x \\n(^tu+1v-\\n(^Yu
\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
.\}
.bp
'fi
.ev
.if \\n(^b \{\
.mk ^y
.nr ^b 2
.\}
.if \\n(^v \{\
.mk ^Y
.\}
..
'\" # DS - begin display
.de DS
.RS
.nf
.sp
..
'\" # DE - end display
.de DE
.fi
.RE
.sp
..
'\" # SO - start of list of standard options
.de SO
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 5.5c 11c
.ft B
..
'\" # SE - end of list of standard options
.de SE
.fi
.ft R
.LP
See the \\fBoptions\\fR manual entry for details on the standard options.
..
'\" # OP - start of full description for a single option
.de OP
.LP
.nf
.ta 4c
Command-Line Name: \\fB\\$1\\fR
Database Name: \\fB\\$2\\fR
Database Class: \\fB\\$3\\fR
.fi
.IP
..
'\" # CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
..
'\" # CE - end code excerpt
.de CE
.fi
.RE
..
.de UL
\\$1\l'|0\(ul'\\$2
..
tcl8.4.20/doc/fileevent.n 0000644 0036047 0045461 00000012500 11737050674 013622 0 ustar dgp 771div '\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH fileevent n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
fileevent \- Execute a script when a channel becomes readable or writable
.SH SYNOPSIS
\fBfileevent \fIchannelId \fBreadable \fR?\fIscript\fR?
.sp
\fBfileevent \fIchannelId \fBwritable \fR?\fIscript\fR?
.BE
.SH DESCRIPTION
.PP
This command is used to create \fIfile event handlers\fR. A file event
handler is a binding between a channel and a script, such that the script
is evaluated whenever the channel becomes readable or writable. File event
handlers are most commonly used to allow data to be received from another
process on an event-driven basis, so that the receiver can continue to
interact with the user while waiting for the data to arrive. If an
application invokes \fBgets\fR or \fBread\fR on a blocking channel when
there is no input data available, the process will block; until the input
data arrives, it will not be able to service other events, so it will
appear to the user to ``freeze up''. With \fBfileevent\fR, the process can
tell when data is present and only invoke \fBgets\fR or \fBread\fR when
they won't block.
.PP
.VS
The \fIchannelId\fR argument to \fBfileevent\fR refers to an open
channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR,
or \fBstderr\fR), the return value from an invocation of \fBopen\fR
or \fBsocket\fR, or the result of a channel creation command provided
by a Tcl extension.
.VE
.PP
If the \fIscript\fR argument is specified, then \fBfileevent\fR
creates a new event handler: \fIscript\fR will be evaluated
whenever the channel becomes readable or writable (depending on the
second argument to \fBfileevent\fR).
In this case \fBfileevent\fR returns an empty string.
The \fBreadable\fR and \fBwritable\fR event handlers for a file
are independent, and may be created and deleted separately.
However, there may be at most one \fBreadable\fR and one \fBwritable\fR
handler for a file at a given time in a given interpreter.
If \fBfileevent\fR is called when the specified handler already
exists in the invoking interpreter, the new script replaces the old one.
.PP
If the \fIscript\fR argument is not specified, \fBfileevent\fR
returns the current script for \fIchannelId\fR, or an empty string
if there is none.
If the \fIscript\fR argument is specified as an empty string
then the event handler is deleted, so that no script will be invoked.
A file event handler is also deleted automatically whenever
its channel is closed or its interpreter is deleted.
.PP
A channel is considered to be readable if there is unread data
available on the underlying device.
A channel is also considered to be readable if there is unread
data in an input buffer, except in the special case where the
most recent attempt to read from the channel was a \fBgets\fR
call that could not find a complete line in the input buffer.
This feature allows a file to be read a line at a time in nonblocking mode
using events.
A channel is also considered to be readable if an end of file or
error condition is present on the underlying file or device.
It is important for \fIscript\fR to check for these conditions
and handle them appropriately; for example, if there is no special
check for end of file, an infinite loop may occur where \fIscript\fR
reads no data, returns, and is immediately invoked again.
.PP
A channel is considered to be writable if at least one byte of data
can be written to the underlying file or device without blocking,
or if an error condition is present on the underlying file or device.
.PP
Event-driven I/O works best for channels that have been
placed into nonblocking mode with the \fBfconfigure\fR command.
In blocking mode, a \fBputs\fR command may block if you give it
more data than the underlying file or device can accept, and a
\fBgets\fR or \fBread\fR command will block if you attempt to read
more data than is ready; no events will be processed while the
commands block.
In nonblocking mode \fBputs\fR, \fBread\fR, and \fBgets\fR never block.
See the documentation for the individual commands for information
on how they handle blocking and nonblocking channels.
.PP
The script for a file event is executed at global level (outside the
context of any Tcl procedure) in the interpreter in which the
\fBfileevent\fR command was invoked.
If an error occurs while executing the script then the
\fBbgerror\fR mechanism is used to report the error.
In addition, the file event handler is deleted if it ever returns
an error; this is done in order to prevent infinite loops due to
buggy handlers.
.SH EXAMPLE
In this setup \fBGetData\fR will be called with the channel as an
argument whenever $chan becomes readable.
.CS
proc GetData {chan} {
if {![eof $chan]} {
puts [gets $chan]
}
}
\fBfileevent\fR $chan readable [list GetData $chan]
.CE
.SH CREDITS
.PP
\fBfileevent\fR is based on the \fBaddinput\fR command created
by Mark Diekhans.
.SH "SEE ALSO"
bgerror(n), fconfigure(n), gets(n), puts(n), read(n), Tcl_StandardChannels(3)
.SH KEYWORDS
asynchronous I/O, blocking, channel, event handler, nonblocking, readable,
script, writable.
tcl8.4.20/doc/StdChannels.3 0000644 0036047 0045461 00000011077 11737050674 013764 0 ustar dgp 771div '\"
'\" Copyright (c) 2001 by ActiveState Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH "Standard Channels" 3 7.5 Tcl "Tcl Library Procedures"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_StandardChannels \- How the Tcl library deals with the standard channels
.BE
.SH DESCRIPTION
.PP
This page explains the initialization and use of standard channels in
the Tcl library.
.PP
The term \fIstandard channels\fR comes out of the Unix world and
refers to the three channels automatically opened by the OS for
each new application. They are \fBstdin\fR, \fBstdout\fR and
\fBstderr\fR. The first is the standard input an application can read
from, the other two refer to writable channels, one for regular
output and the other for error messages.
.PP
Tcl generalizes this concept in a cross-platform way and
exposes standard channels to the script level.
.SH APIs
.PP
The public API procedures dealing directly with standard channels are
\fBTcl_GetStdChannel\fR and \fBTcl_SetStdChannel\fR. Additional public
APIs to consider are \fBTcl_RegisterChannel\fR,
\fBTcl_CreateChannel\fR and \fBTcl_GetChannel\fR.
.SH "INITIALIZATION OF TCL STANDARD CHANNELS"
.PP
Standard channels are initialized by the Tcl library in three cases:
when explicitly requested, when implicitly required before returning
channel information, or when implicitly required during registration
of a new channel.
.PP
These cases differ in how they handle unavailable platform- specific
standard channels. (A channel is not ``available'' if it could not be
successfully opened; for example, in a Tcl application run as a
Windows NT service.)
.TP
1)
A single standard channel is initialized when it is explicitly
specified in a call to \fBTcl_SetStdChannel\fR. The state of the
other standard channels are unaffected.
.sp
Missing platform-specific standard channels do not matter here. This
approach is not available at the script level.
.TP
2)
All uninitialized standard channels are initialized to
platform-specific default values:
.RS
.TP
(a)
when open channels are listed with \fBTcl_GetChannelNames\fR (or the
\fBfile channels\fR script command), or
.TP
(b)
when information about any standard channel is requested with a call
to \fBTcl_GetStdChannel\fR, or with a call to \fBTcl_GetChannel\fR
which specifies one of the standard names (\fBstdin\fR, \fBstdout\fR
and \fBstderr\fR).
.RE
.sp
.RS
In case of missing platform-specific standard channels, the Tcl
standard channels are considered as initialized and then immediately
closed. This means that the first three Tcl channels then opened by
the application are designated as the Tcl standard channels.
.RE
.TP
3)
All uninitialized standard channels are initialized to
platform-specific default values when a user-requested channel is
registered with \fBTcl_RegisterChannel\fR.
.sp
In case of unavailable platform-specific standard channels the channel
whose creation caused the initialization of the Tcl standard channels
is made a normal channel. The next three Tcl channels opened by the
application are designated as the Tcl standard channels. In other
words, of the first four Tcl channels opened by the application the
second to fourth are designated as the Tcl standard channels.
.PP
.SH "RE-INITIALIZATION OF TCL STANDARD CHANNELS"
.PP
Once a Tcl standard channel is initialized through one of the methods
above, closing this Tcl standard channel will cause the next call to
\fBTcl_CreateChannel\fR to make the new channel the new standard
channel, too. If more than one Tcl standard channel was closed
\fBTcl_CreateChannel\fR will fill the empty slots in the order
\fBstdin\fR, \fBstdout\fR and \fBstderr\fR.
.PP
\fBTcl_CreateChannel\fR will not try to reinitialize an empty slot if
that slot was not initialized before. It is this behavior which
enables an application to employ method 1 of initialization, i.e. to
create and designate their own Tcl standard channels.
.SH tclsh
.PP
The Tcl shell (or rather \fBTcl_Main\fR) uses method 2 to initialize
the standard channels.
.SH wish
.PP
The windowing shell (or rather \fBTk_MainEx\fR) uses method 1 to
initialize the standard channels (See \fBTk_InitConsoleChannels\fR)
on non-Unix platforms. On Unix platforms, \fBTk_MainEx\fR implicitly
uses method 2 to initialize the standard channels.
.SH "SEE ALSO"
Tcl_CreateChannel(3), Tcl_RegisterChannel(3), Tcl_GetChannel(3), Tcl_GetStdChannel(3), Tcl_SetStdChannel(3), Tk_InitConsoleChannels(3), tclsh(1), wish(1), Tcl_Main(3), Tk_MainEx(3)
.SH KEYWORDS
standard channels
tcl8.4.20/doc/llength.n 0000644 0036047 0045461 00000002411 11737050674 013276 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH llength n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
llength \- Count the number of elements in a list
.SH SYNOPSIS
\fBllength \fIlist\fR
.BE
.SH DESCRIPTION
.PP
Treats \fIlist\fR as a list and returns a decimal string giving
the number of elements in it.
.SH EXAMPLES
The result is the number of elements:
.CS
% \fBllength\fR {a b c d e}
5
% \fBllength\fR {a b c}
3
% \fBllength\fR {}
0
.CE
.PP
Elements are not guaranteed to be exactly words in a dictionary sense
of course, especially when quoting is used:
.CS
% \fBllength\fR {a b {c d} e}
4
% \fBllength\fR {a b { } c d e}
6
.CE
.PP
An empty list is not necessarily an empty string:
.CS
% set var { }; puts "[string length $var],[\fBllength\fR $var]"
1,0
.CE
.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), linsert(n), lsearch(n),
lset(n), lsort(n), lrange(n), lreplace(n)
.VE
.SH KEYWORDS
element, list, length
tcl8.4.20/doc/GetStdChan.3 0000644 0036047 0045461 00000007023 11737050674 013536 0 ustar dgp 771div '\"
'\" Copyright (c) 1996 by Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_GetStdChannel 3 7.5 Tcl "Tcl Library Procedures"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_GetStdChannel, Tcl_SetStdChannel \- procedures for retrieving and replacing the standard channels
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Channel
\fBTcl_GetStdChannel\fR(\fItype\fR)
.sp
\fBTcl_SetStdChannel\fR(\fIchannel, type\fR)
.sp
.SH ARGUMENTS
.AS Tcl_Channel channel in
.AP int type in
The identifier for the standard channel to retrieve or modify. Must be one of
\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, or \fBTCL_STDERR\fR.
.AP Tcl_Channel channel in
The channel to use as the new value for the specified standard channel.
.BE
.SH DESCRIPTION
.PP
Tcl defines three special channels that are used by various I/O related
commands if no other channels are specified. The standard input channel
has a channel name of \fBstdin\fR and is used by \fBread\fR and \fBgets\fR.
The standard output channel is named \fBstdout\fR and is used by
\fBputs\fR. The standard error channel is named \fBstderr\fR and is used for
reporting errors. In addition, the standard channels are inherited by any
child processes created using \fBexec\fR or \fBopen\fR in the absence of any
other redirections.
.PP
The standard channels are actually aliases for other normal channels. The
current channel associated with a standard channel can be retrieved by calling
\fBTcl_GetStdChannel\fR with one of
\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, or \fBTCL_STDERR\fR as the \fItype\fR. The
return value will be a valid channel, or NULL.
.PP
A new channel can be set for the standard channel specified by \fItype\fR
by calling \fBTcl_SetStdChannel\fR with a new channel or NULL in the
\fIchannel\fR argument. If the specified channel is closed by a later call to
\fBTcl_Close\fR, then the corresponding standard channel will automatically be
set to NULL.
.PP
If a non-NULL value for \fIchannel\fR is passed to \fBTcl_SetStdChannel\fR,
then that same value should be passed to \fBTcl_RegisterChannel\fR, like so:
.CS
Tcl_RegisterChannel(NULL, channel);
.CE
This is a workaround for a misfeature in \fBTcl_SetStdChannel\fR that it
fails to do some reference counting housekeeping. This misfeature cannot
be corrected without contradicting the assumptions of some existing
code that calls \fBTcl_SetStdChannel\fR.
.PP
If \fBTcl_GetStdChannel\fR is called before \fBTcl_SetStdChannel\fR, Tcl will
construct a new channel to wrap the appropriate platform-specific standard
file handle. If \fBTcl_SetStdChannel\fR is called before
\fBTcl_GetStdChannel\fR, then the default channel will not be created.
.PP
If one of the standard channels is set to NULL, either by calling
\fBTcl_SetStdChannel\fR with a NULL \fIchannel\fR argument, or by calling
\fBTcl_Close\fR on the channel, then the next call to \fBTcl_CreateChannel\fR
will automatically set the standard channel with the newly created channel. If
more than one standard channel is NULL, then the standard channels will be
assigned starting with standard input, followed by standard output, with
standard error being last.
.PP
See \fBTcl_StandardChannels\fR for a general treatise about standard
channels and the behaviour of the Tcl library with regard to them.
.PP
.SH "SEE ALSO"
Tcl_Close(3), Tcl_CreateChannel(3), Tcl_Main(3), tclsh(1)
.SH KEYWORDS
standard channel, standard input, standard output, standard error
tcl8.4.20/doc/SetErrno.3 0000644 0036047 0045461 00000004051 11737050674 013311 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_SetErrno 3 8.3 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetErrno, Tcl_GetErrno, Tcl_ErrnoId, Tcl_ErrnoMsg \- manipulate errno to store and retrieve error codes
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
void
\fBTcl_SetErrno\fR(\fIerrorCode\fR)
.sp
int
\fBTcl_GetErrno\fR()
.sp
CONST char *
\fBTcl_ErrnoId\fR()
.sp
CONST char *
\fBTcl_ErrnoMsg\fR(\fIerrorCode\fR)
.sp
.SH ARGUMENTS
.AS int errorCode in
.AP int errorCode in
A POSIX error code such as \fBENOENT\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_SetErrno\fR and \fBTcl_GetErrno\fR provide portable access
to the \fBerrno\fR variable, which is used to record a POSIX error
code after system calls and other operations such as \fBTcl_Gets\fR.
These procedures are necessary because global variable accesses cannot
be made across module boundaries on some platforms.
.PP
\fBTcl_SetErrno\fR sets the \fBerrno\fR variable to the value of the
\fIerrorCode\fR argument
C procedures that wish to return error information to their callers
via \fBerrno\fR should call \fBTcl_SetErrno\fR rather than setting
\fBerrno\fR directly.
.PP
\fBTcl_GetErrno\fR returns the current value of \fBerrno\fR.
Procedures wishing to access \fBerrno\fR should call this procedure
instead of accessing \fBerrno\fR directly.
.PP
\fBTcl_ErrnoId\fR and \fBTcl_ErrnoMsg\fR return string
representations of \fBerrno\fR values. \fBTcl_ErrnoId\fR
returns a machine-readable textual identifier such as
"EACCES" that corresponds to the current value of \fBerrno\fR.
\fBTcl_ErrnoMsg\fR returns a human-readable string such as
"permission denied" that corresponds to the value of its
\fIerrorCode\fR argument. The \fIerrorCode\fR argument is
typically the value returned by \fBTcl_GetErrno\fR.
The strings returned by these functions are
statically allocated and the caller must not free or modify them.
.SH KEYWORDS
errno, error code, global variables
tcl8.4.20/doc/rename.n 0000644 0036047 0045461 00000002636 11737050674 013121 0 ustar dgp 771div '\"
'\" Copyright (c) 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.
'\"
.so man.macros
.TH rename n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
rename \- Rename or delete a command
.SH SYNOPSIS
\fBrename \fIoldName newName\fR
.BE
.SH DESCRIPTION
.PP
Rename the command that used to be called \fIoldName\fR so that it
is now called \fInewName\fR.
If \fInewName\fR is an empty string then \fIoldName\fR is deleted.
\fIoldName\fR and \fInewName\fR may include namespace qualifiers
(names of containing namespaces).
If a command is renamed into a different namespace,
future invocations of it will execute in the new namespace.
The \fBrename\fR command returns an empty string as result.
.SH EXAMPLE
The \fBrename\fR command can be used to wrap the standard Tcl commands
with your own monitoring machinery. For example, you might wish to
count how often the \fBsource\fR command is called:
.CS
\fBrename\fR ::source ::theRealSource
set sourceCount 0
proc ::source args {
global sourceCount
puts "called source for the [incr sourceCount]'th time"
uplevel 1 ::theRealSource $args
}
.CE
.SH "SEE ALSO"
namespace(n), proc(n)
.SH KEYWORDS
command, delete, namespace, rename
tcl8.4.20/doc/return.n 0000644 0036047 0045461 00000011027 11737050674 013163 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH return n 7.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
return \- Return from a procedure
.SH SYNOPSIS
\fBreturn \fR?\fB\-code \fIcode\fR? ?\fB\-errorinfo \fIinfo\fR? ?\fB\-errorcode\fI code\fR? ?\fIstring\fR?
.BE
.SH DESCRIPTION
.PP
Return immediately from the current procedure
(or top-level command or \fBsource\fR command),
with \fIstring\fR as the return value. If \fIstring\fR is not specified then
an empty string will be returned as result.
.SH "EXCEPTIONAL RETURN CODES"
.PP
In addition to the result of a procedure, the return
code of a procedure may also be set by \fBreturn\fR
through use of the \fB-code\fR option.
In the usual case where the \fB\-code\fR option isn't
specified the procedure will return normally.
However, the \fB\-code\fR option may be used to generate an
exceptional return from the procedure.
\fICode\fR may have any of the following values:
.TP 13
\fBok (or 0)\fR
Normal return: same as if the option is omitted. The return code
of the procedure is 0 (\fBTCL_OK\fR).
.TP 13
\fBerror (1)\fR
Error return: the return code of the procedure is 1 (\fBTCL_ERROR\fR).
The procedure command behaves in its calling context as if it
were the command \fBerror \fIresult\fR. See below for additional
options.
.TP 13
\fBreturn (2)\fR
The return code of the procedure is 2 (\fBTCL_RETURN\fR). The
procedure command behaves in its calling context as if it
were the command \fBreturn\fR (with no arguments).
.TP 13
\fBbreak (3)\fR
The return code of the procedure is 3 (\fBTCL_BREAK\fR). The
procedure command behaves in its calling context as if it
were the command \fBbreak\fR.
.TP 13
\fBcontinue (4)\fR
The return code of the procedure is 4 (\fBTCL_CONTINUE\fR). The
procedure command behaves in its calling context as if it
were the command \fBcontinue\fR.
.TP 13
\fIvalue\fR
\fIValue\fR must be an integer; it will be returned as the
return code for the current procedure.
.LP
The \fB\-code\fR option is rarely used.
It is provided so that procedures that implement
new control structures can reflect exceptional conditions back to
their callers.
.PP
Two additional options, \fB\-errorinfo\fR and \fB\-errorcode\fR,
may be used to provide additional information during error
returns.
These options are ignored unless \fIcode\fR is \fBerror\fR.
.PP
The \fB\-errorinfo\fR option specifies an initial stack
trace for the \fBerrorInfo\fR variable; if it is not specified then
the stack trace left in \fBerrorInfo\fR will include the call to
the procedure and higher levels on the stack but it will not include
any information about the context of the error within the procedure.
Typically the \fIinfo\fR value is supplied from the value left
in \fBerrorInfo\fR after a \fBcatch\fR command trapped an error within
the procedure.
.PP
If the \fB\-errorcode\fR option is specified then \fIcode\fR provides
a value for the \fBerrorCode\fR variable.
If the option is not specified then \fBerrorCode\fR will
default to \fBNONE\fR.
.SH EXAMPLES
First, a simple example of using \fBreturn\fR to return from a
procedure, interrupting the procedure body.
.CS
proc printOneLine {} {
puts "line 1" ;# This line will be printed.
\fBreturn\fR
puts "line 2" ;# This line will not be printed.
}
.CE
.PP
Next, an example of using \fBreturn\fR to set the value
returned by the procedure.
.CS
proc returnX {} {\fBreturn\fR X}
puts [returnX] ;# prints "X"
.CE
.PP
Next, a more complete example, using \fBreturn -code error\fR
to report invalid arguments.
.CS
proc factorial {n} {
if {![string is integer $n] || ($n < 0)} {
\fBreturn\fR -code error \\
"expected non-negative integer,\\
but got \\"$n\\""
}
if {$n < 2} {
\fBreturn\fR 1
}
set m [expr {$n - 1}]
set code [catch {factorial $m} factor]
if {$code != 0} {
\fBreturn\fR -code $code $factor
}
set product [expr {$n * $factor}]
if {$product < 0} {
\fBreturn\fR -code error \\
"overflow computing factorial of $n"
}
\fBreturn\fR $product
}
.CE
.PP
Next, a procedure replacement for \fBbreak\fR.
.CS
proc myBreak {} {
\fBreturn\fR -code break
}
.CE
.SH "SEE ALSO"
break(n), catch(n), continue(n), error(n), proc(n), source(n), tclvars(n)
.SH KEYWORDS
break, catch, continue, error, procedure, return
tcl8.4.20/doc/dde.n 0000644 0036047 0045461 00000015051 12052456743 012377 0 ustar dgp 771div '\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Copyright (c) 2001 ActiveState Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH dde n 1.2 dde "Tcl Bundled Packages"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
dde \- Execute a Dynamic Data Exchange command
.SH SYNOPSIS
.sp
\fBpackage require dde 1.2\fR
.sp
\fBdde eval\fR ?\fB\-async\fR? \fIservice cmd\fR ?\fIarg ...\fR?
.sp
\fBdde execute\fR ?\fB\-async\fR? \fIservice topic data\fR
.sp
\fBdde poke \fIservice topic item data\fR
.sp
\fBdde request\fR ?\fB\-binary\fR? \fIservice topic data\fR
.sp
\fBdde servername\fR ?\fItopic\fR?
.sp
\fBdde services \fIservice topic\fR
.BE
.SH DESCRIPTION
.PP
This command allows an application to send Dynamic Data Exchange (DDE)
command when running under Microsoft Windows. Dynamic Data Exchange is
a mechanism where applications can exchange raw data. Each DDE
transaction needs a \fIservice name\fR and a \fItopic\fR. Both the
\fIservice name\fR and \fItopic\fR are application defined; Tcl uses
the service name \fBTclEval\fR, while the topic name is the name of the
interpreter given by \fBdde servername\fR. Other applications have their
own \fIservice name\fRs and \fItopic\fRs. For instance, Microsoft Excel
has the service name \fBExcel\fR.
.PP
The \fBeval\fR and \fBexecute\fR commands accept the option \fB\-async\fR:
.SH "DDE COMMANDS"
.PP
The following commands are a subset of the full Dynamic Data Exchange
set of commands.
.TP
\fBdde servername \fR?\fItopic\fR?
\fBdde servername\fR registers the interpreter as a DDE server with
the service name \fBTclEval\fR and the topic name specified by \fItopic\fR.
If no \fItopic\fR is given, \fBdde servername\fR returns the name
of the current topic or the empty string if it is not registered as a service.
.TP
\fBdde execute\fR ?\fB\-async\fR? \fIservice topic data\fR
\fBdde execute\fR takes the \fIdata\fR and sends it to the server indicated
by \fIservice\fR with the topic indicated by \fItopic\fR. Typically,
\fIservice\fR is the name of an application, and \fItopic\fR is a file to
work on. The \fIdata\fR field is given to the remote application.
Typically, the application treats the \fIdata\fR field as a script, and the
script is run in the application. The \fB\-async\fR option requests
asynchronous invocation. The command returns an error message if the
script did not run, unless the \fB\-async\fR flag was used, in which case
the command returns immediately with no error.
.TP
\fBdde poke \fIservice topic item data\fR
\fBdde poke\fR passes the \fIdata\fR to the server indicated by
\fIservice\fR using the \fItopic\fR and \fIitem\fR specified. Typically,
\fIservice\fR is the name of an application. \fItopic\fR is application
specific but can be a command to the server or the name of a file to work
on. The \fIitem\fR is also application specific and is often not used, but
it must always be non-null. The \fIdata\fR field is given to the remote
application.
.TP
\fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR
\fBdde request\fR is typically used to get the value of something; the
value of a cell in Microsoft Excel or the text of a selection in
Microsoft Word. \fIservice\fR is typically the name of an application,
\fItopic\fR is typically the name of the file, and \fIitem\fR is
application-specific. The command returns the value of \fIitem\fR as
defined in the application. Normally this is interpreted to be a
string with terminating null. If \fB\-binary\fR is specified, the
result is returned as a byte array.
.TP
\fBdde services \fIservice topic\fR
\fBdde services\fR returns a list of service-topic pairs that
currently exist on the machine. If \fIservice\fR and \fItopic\fR are
both null strings ({}), then all service-topic pairs currently
available on the system are returned. If \fIservice\fR is null and
\fItopic\fR is not, then all services with the specified topic are
returned. If \fIservice\fR is not null and \fItopic\fR is, all topics
for a given service are returned. If both are not null, if that
service-topic pair currently exists, it is returned; otherwise, null
is returned.
.TP
\fBdde eval\fR ?\fB\-async\fR? \fItopic cmd \fR?\fIarg arg ...\fR?
\fBdde eval\fR evaluates a command and its arguments using the interpreter
specified by \fItopic\fR. The DDE service must be the \fBTclEval\fR
service. The \fB\-async\fR option requests asynchronous invocation. The
command returns an error message if the script did not run, unless the
\fB\-async\fR flag was used, in which case the command returns immediately
with no error. This command can be used to replace \fBsend\fR on Windows.
.SH "DDE AND TCL"
A Tcl interpreter always has a service name of \fBTclEval\fR. Each
different interpreter of all running Tcl applications must be
given a unique
name specified by \fBdde servername\fR. Each interp is available as a
DDE topic only if the \fBdde servername\fR command was used to set the
name of the topic for each interp. So a \fBdde services TclEval {}\fR
command will return a list of service-topic pairs, where each of the
currently running interps will be a topic.
.PP
When Tcl processes a \fBdde execute\fR command, the data for the
execute is run as a script in the interp named by the topic of the
\fBdde execute\fR command.
.PP
When Tcl processes a \fBdde request\fR command, it returns the value of the
variable given in the dde command in the context of the interp named by the
dde topic. Tcl reserves the variable \fB$TCLEVAL$EXECUTE$RESULT\fR for
internal use, and \fBdde request\fR commands for that variable will give
unpredictable results.
.PP
An external application which wishes to run a script in Tcl should have
that script store its result in a variable, run the \fBdde execute\fR
command, and then run \fBdde request\fR to get the value of the
variable.
.PP
When using DDE, be careful to ensure that the event queue is flushed
using either \fBupdate\fR or \fBvwait\fR. This happens by default
when using \fBwish\fR unless a blocking command is called (such as \fBexec\fR
without adding the \fB&\fR to place the process in the background).
If for any reason the event queue is not flushed, DDE commands may
hang until the event queue is flushed. This can create a deadlock
situation.
.SH EXAMPLE
This asks Internet Explorer (which must already be running) to go to a
particularly important website:
.CS
package require dde
\fBdde execute\fR -async iexplore WWW_OpenURL http://www.tcl.tk/
.CE
.SH "SEE ALSO"
tk(n), winfo(n), send(n)
.SH KEYWORDS
application, dde, name, remote execution
tcl8.4.20/doc/StringObj.3 0000644 0036047 0045461 00000027376 11737050674 013470 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Obj *
\fBTcl_NewStringObj\fR(\fIbytes, length\fR)
.sp
Tcl_Obj *
\fBTcl_NewUnicodeObj\fR(\fIunicode, numChars\fR)
.sp
void
\fBTcl_SetStringObj\fR(\fIobjPtr, bytes, length\fR)
.sp
void
\fBTcl_SetUnicodeObj\fR(\fIobjPtr, unicode, numChars\fR)
.sp
char *
\fBTcl_GetStringFromObj\fR(\fIobjPtr, lengthPtr\fR)
.sp
char *
\fBTcl_GetString\fR(\fIobjPtr\fR)
.sp
Tcl_UniChar *
\fBTcl_GetUnicodeFromObj\fR(\fIobjPtr, lengthPtr\fR)
.sp
Tcl_UniChar *
\fBTcl_GetUnicode\fR(\fIobjPtr\fR)
.sp
Tcl_UniChar
\fBTcl_GetUniChar\fR(\fIobjPtr, index\fR)
.sp
int
\fBTcl_GetCharLength\fR(\fIobjPtr\fR)
.sp
Tcl_Obj *
\fBTcl_GetRange\fR(\fIobjPtr, first, last\fR)
.sp
void
\fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR)
.sp
void
\fBTcl_AppendUnicodeToObj\fR(\fIobjPtr, unicode, numChars\fR)
.sp
void
\fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR)
.sp
void
\fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *) NULL\fR)
.sp
void
\fBTcl_AppendStringsToObjVA\fR(\fIobjPtr, argList\fR)
.sp
void
\fBTcl_SetObjLength\fR(\fIobjPtr, newLength\fR)
.sp
int
\fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR)
.sp
Tcl_Obj *
\fBTcl_ConcatObj\fR(\fIobjc, objv\fR)
.SH ARGUMENTS
.AS "CONST Tcl_UniChar" *appendObjPtr in/out
.AP "CONST char" *bytes in
.VS 8.1
Points to the first byte of an array of UTF-8-encoded bytes
used to set or append to a string object.
This byte array should not contain embedded null bytes
unless \fIlength\fR is negative. (Applications needing null bytes
should represent them as the two-byte sequence \fI\\700\\600\fR, use
\fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if
the string is a collection of uninterpreted bytes.)
.VE 8.1
.AP int length in
The number of bytes to copy from \fIbytes\fR when
initializing, setting, or appending to a string object.
If negative, all bytes up to the first null are used.
.AP "CONST Tcl_UniChar" *unicode in
Points to the first byte of an array of Unicode characters
used to set or append to a string object.
This byte array may contain embedded null characters
unless \fInumChars\fR is negative.
.AP int numChars in
The number of Unicode characters to copy from \fIunicode\fR when
initializing, setting, or appending to a string object.
If negative, all characters up to the first null character are used.
.AP int index in
The index of the Unicode character to return.
.AP int first in
The index of the first Unicode character in the Unicode range to be
returned as a new object.
.AP int last in
The index of the last Unicode character in the Unicode range to be
returned as a new object.
.AP Tcl_Obj *objPtr in/out
Points to an object to manipulate.
.AP Tcl_Obj *appendObjPtr in
The object to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR.
.AP int *lengthPtr out
If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store
the the length of an object's string representation.
.AP "CONST char" *string in
Null-terminated string value to append to \fIobjPtr\fR.
.AP va_list argList in
An argument list which must have been initialised using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.AP int newLength in
New length for the string value of \fIobjPtr\fR, not including the
final null character.
.AP int objc in
The number of elements to concatenate.
.AP Tcl_Obj *objv[] in
The array of objects to concatenate.
.BE
.SH DESCRIPTION
.PP
The procedures described in this manual entry allow Tcl objects to
be manipulated as string values. They use the internal representation
of the object to store additional information to make the string
manipulations more efficient. In particular, they make a series of
append operations efficient by allocating extra storage space for the
string so that it doesn't have to be copied for each append.
Also, indexing and length computations are optimized because the
Unicode string representation is calculated and cached as needed.
When using the \fBTcl_Append*\fR family of functions where the
interpreter's result is the object being appended to, it is important
to call Tcl_ResetResult first to ensure you are not unintentionally
appending to existing data in the result object.
.PP
\fBTcl_NewStringObj\fR and \fBTcl_SetStringObj\fR create a new object
or modify an existing object to hold a copy of the string given by
\fIbytes\fR and \fIlength\fR. \fBTcl_NewUnicodeObj\fR and
\fBTcl_SetUnicodeObj\fR create a new object or modify an existing
object to hold a copy of the Unicode string given by \fIunicode\fR and
\fInumChars\fR. \fBTcl_NewStringObj\fR and \fBTcl_NewUnicodeObj\fR
return a pointer to a newly created object with reference count zero.
All four procedures set the object to hold a copy of the specified
string. \fBTcl_SetStringObj\fR and \fBTcl_SetUnicodeObj\fR free any
old string representation as well as any old internal representation
of the object.
.PP
\fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR return an object's
string representation. This is given by the returned byte pointer and
(for \fBTcl_GetStringFromObj\fR) length, which is stored in
\fIlengthPtr\fR if it is non-NULL. If the object's UTF string
representation is invalid (its byte pointer is NULL), the string
representation is regenerated from the object's internal
representation. The storage referenced by the returned byte pointer
is owned by the object manager. It is passed back as a writable
pointer so that extension author creating their own \fBTcl_ObjType\fR
will be able to modify the string representation within the
\fBTcl_UpdateStringProc\fR of their \fBTcl_ObjType\fR. Except for that
limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR
or \fBTcl_GetString\fR should be treated as read-only. It is
recommended that this pointer be assigned to a (CONST char *) variable.
Even in the limited situations where writing to this pointer is
acceptable, one should take care to respect the copy-on-write
semantics required by \fBTcl_Obj\fR's, with appropriate calls
to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any
in-place modification of the string representation.
The procedure \fBTcl_GetString\fR is used in the common case
where the caller does not need the length of the string
representation.
.PP
\fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return an object's
value as a Unicode string. This is given by the returned pointer and
(for \fBTcl_GetUnicodeFromObj\fR) length, which is stored in
\fIlengthPtr\fR if it is non-NULL. The storage referenced by the returned
byte pointer is owned by the object manager and should not be modified by
the caller. The procedure \fBTcl_GetUnicode\fR is used in the common case
where the caller does not need the length of the unicode string
representation.
.PP
\fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the
object's Unicode representation.
.PP
\fBTcl_GetRange\fR returns a newly created object comprised of the
characters between \fIfirst\fR and \fIlast\fR (inclusive) in the
object's Unicode representation. If the object's Unicode
representation is invalid, the Unicode representation is regenerated
from the object's string representation.
.PP
\fBTcl_GetCharLength\fR returns the number of characters (as opposed
to bytes) in the string object.
.PP
\fBTcl_AppendToObj\fR appends the data given by \fIbytes\fR and
\fIlength\fR to the string representation of the object specified by
\fIobjPtr\fR. If the object has an invalid string representation,
then an attempt is made to convert \fIbytes\fR is to the Unicode
format. If the conversion is successful, then the converted form of
\fIbytes\fR is appended to the object's Unicode representation.
Otherwise, the object's Unicode representation is invalidated and
converted to the UTF format, and \fIbytes\fR is appended to the
object's new string representation.
.PP
\fBTcl_AppendUnicodeToObj\fR appends the Unicode string given by
\fIunicode\fR and \fInumChars\fR to the object specified by
\fIobjPtr\fR. If the object has an invalid Unicode representation,
then \fIunicode\fR is converted to the UTF format and appended to the
object's string representation. Appends are optimized to handle
repeated appends relatively efficiently (it overallocates the string
or Unicode space to avoid repeated reallocations and copies of
object's string value).
.PP
\fBTcl_AppendObjToObj\fR is similar to \fBTcl_AppendToObj\fR, but it
appends the string or Unicode value (whichever exists and is best
suited to be appended to \fIobjPtr\fR) of \fIappendObjPtr\fR to
\fIobjPtr\fR.
.PP
\fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR
except that it can be passed more than one value to append and
each value must be a null-terminated string (i.e. none of the
values may contain internal null characters). Any number of
\fIstring\fR arguments may be provided, but the last argument
must be a NULL pointer to indicate the end of the list.
.PP
\fBTcl_AppendStringsToObjVA\fR is the same as \fBTcl_AppendStringsToObj\fR
except that instead of taking a variable number of arguments it takes an
argument list.
.PP
The \fBTcl_SetObjLength\fR procedure changes the length of the
string value of its \fIobjPtr\fR argument. If the \fInewLength\fR
argument is greater than the space allocated for the object's
string, then the string space is reallocated and the old value
is copied to the new space; the bytes between the old length of
the string and the new length may have arbitrary values.
If the \fInewLength\fR argument is less than the current length
of the object's string, with \fIobjPtr->length\fR is reduced without
reallocating the string space; the original allocated size for the
string is recorded in the object, so that the string length can be
enlarged in a subsequent call to \fBTcl_SetObjLength\fR without
reallocating storage. In all cases \fBTcl_SetObjLength\fR leaves
a null character at \fIobjPtr->bytes[newLength]\fR.
.PP
\fBTcl_AttemptSetObjLength\fR is identical in function to
\fBTcl_SetObjLength\fR except that if sufficient memory to satisfy the
request cannot be allocated, it does not cause the Tcl interpreter to
\fBpanic\fR. Thus, if \fInewLength\fR is greater than the space
allocated for the object's string, and there is not enough memory
available to satisfy the request, \fBTcl_AttemptSetObjLength\fR will take
no action and return 0 to indicate failure. If there is enough memory
to satisfy the request, \fBTcl_AttemptSetObjLength\fR behaves just like
\fBTcl_SetObjLength\fR and returns 1 to indicate success.
.PP
The \fBTcl_ConcatObj\fR function returns a new string object whose
value is the space-separated concatenation of the string
representations of all of the objects in the \fIobjv\fR
array. \fBTcl_ConcatObj\fR eliminates leading and trailing white space
as it copies the string representations of the \fIobjv\fR array to the
result. If an element of the \fIobjv\fR array consists of nothing but
white space, then that object is ignored entirely. This white-space
removal was added to make the output of the \fBconcat\fR command
cleaner-looking. \fBTcl_ConcatObj\fR returns a pointer to a
newly-created object whose ref count is zero.
.SH "SEE ALSO"
Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount
.SH KEYWORDS
append, internal representation, object, object type, string object,
string type, string representation, concat, concatenate, unicode
tcl8.4.20/doc/Alloc.3 0000644 0036047 0045461 00000005556 11737050674 012615 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
char *
\fBTcl_Alloc\fR(\fIsize\fR)
.sp
void
\fBTcl_Free\fR(\fIptr\fR)
.sp
char *
\fBTcl_Realloc\fR(\fIptr, size\fR)
.sp
char *
\fBTcl_AttemptAlloc\fR(\fIsize\fR)
.sp
char *
\fBTcl_AttemptRealloc\fR(\fIptr, size\fR)
.sp
char *
\fBckalloc\fR(\fIsize\fR)
.sp
void
\fBckfree\fR(\fIptr\fR)
.sp
char *
\fBckrealloc\fR(\fIptr, size\fR)
.sp
char *
\fBattemptckalloc\fR(\fIsize\fR)
.sp
char *
\fBattemptckrealloc\fR(\fIptr, size\fR)
.SH ARGUMENTS
.AS char *size
.AP "unsigned int" size in
Size in bytes of the memory block to allocate.
.AP char *ptr in
Pointer to memory block to free or realloc.
.BE
.SH DESCRIPTION
.PP
These procedures provide a platform and compiler independent interface
for memory allocation. Programs that need to transfer ownership of
memory blocks between Tcl and other modules should use these routines
rather than the native \fBmalloc()\fR and \fBfree()\fR routines
provided by the C run-time library.
.PP
\fBTcl_Alloc\fR returns a pointer to a block of at least \fIsize\fR
bytes suitably aligned for any use.
.PP
\fBTcl_Free\fR makes the space referred to by \fIptr\fR available for
further allocation.
.PP
\fBTcl_Realloc\fR changes the size of the block pointed to by
\fIptr\fR to \fIsize\fR bytes and returns a pointer to the new block.
The contents will be unchanged up to the lesser of the new and old
sizes. The returned location may be different from \fIptr\fR.
.PP
\fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR are identical in
function to \fBTcl_Alloc\fR and \fBTcl_Realloc\fR, except that
\fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR will not cause the Tcl
interpreter to \fBpanic\fR if the memory allocation fails. If the
allocation fails, these functions will return NULL. Note that on some
platforms, attempting to allocate a block of memory will also cause
these functions to return NULL.
.PP
The procedures \fBckalloc\fR, \fBckfree\fR, \fBckrealloc\fR,
\fBattemptckalloc\fR, and \fBattemptckrealloc\fR are implemented
as macros. Normally, they are synonyms for the corresponding
procedures documented on this page. When Tcl and all modules
calling Tcl are compiled with \fBTCL_MEM_DEBUG\fR defined, however,
these macros are redefined to be special debugging versions of
of these procedures. To support Tcl's memory debugging within a
module, use the macros rather than direct calls to \fBTcl_Alloc\fR, etc.
.SH KEYWORDS
alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG
tcl8.4.20/doc/bgerror.n 0000644 0036047 0045461 00000010020 11737050674 013276 0 ustar dgp 771div '\"
'\" Copyright (c) 1990-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH bgerror n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
bgerror \- Command invoked to process background errors
.SH SYNOPSIS
\fBbgerror \fImessage\fR
.BE
.SH DESCRIPTION
.PP
The \fBbgerror\fR command doesn't exist as built-in part of Tcl. Instead,
individual applications or users can define a \fBbgerror\fR
command (e.g. as a Tcl procedure) if they wish to handle background
errors.
.PP
A background error is one that occurs in an event handler or some
other command that didn't originate with the application.
For example, if an error occurs while executing a command specified
with the \fBafter\fR command, then it is a background error.
For a non-background error, the error can simply be returned up
through nested Tcl command evaluations until it reaches the top-level
code in the application; then the application can report the error
in whatever way it wishes. When a background error occurs, the
unwinding ends in the Tcl library and there is no obvious way for Tcl
to report the error.
.PP
When Tcl detects a background error, it saves information about the
error and invokes the \fBbgerror\fR command later as an idle event
handler. Before invoking \fBbgerror\fR, Tcl restores the
\fBerrorInfo\fR and \fBerrorCode\fR variables to their values at the
time the error occurred, then it invokes \fBbgerror\fR with the error
message as its only argument. Tcl assumes that the application has
implemented the \fBbgerror\fR command, and that the command will
report the error in a way that makes sense for the application. Tcl
will ignore any result returned by the \fBbgerror\fR command as long
as no error is generated.
.PP
If another Tcl error occurs within the \fBbgerror\fR command (for
example, because no \fBbgerror\fR command has been defined) then Tcl
reports the error itself by writing a message to stderr.
.PP
If several background errors accumulate before \fBbgerror\fR is
invoked to process them, \fBbgerror\fR will be invoked once for each
error, in the order they occurred. However, if \fBbgerror\fR returns
with a break exception, then any remaining errors are skipped without
calling \fBbgerror\fR.
.PP
Tcl has no default implementation for \fBbgerror\fR. However, in
applications using Tk there is a default \fBbgerror\fR procedure which
posts a dialog box containing the error message and offers the user a
chance to see a stack trace showing where the error occurred. In
addition to allowing the user to view the stack trace, the dialog
provides an additional application configurable button which may be
used, for example, to save the stack trace to a file. By default,
this is the behavior associated with that button. This behavior can
be redefined by setting the option database values
\fB*ErrorDialog.function.text\fR, to specify the caption for the
function button, and \fB*ErrorDialog.function.command\fR, to specify
the command to be run. The text of the stack trace is appended to the
command when it is evaluated. If either of these options is set to
the empty string, then the additional button will not be displayed in
the dialog.
.PP
If you are writing code that will be used by others as part of a
package or other kind of library, consider avoiding \fBbgerror\fR.
The reason for this is that the application programmer may also want
to define a \fBbgerror\fR, or use other code that does and thus will
have trouble integrating your code.
.SH "EXAMPLE"
This \fBbgerror\fR procedure appends errors to a file, with a timestamp.
.CS
proc bgerror {message} {
set timestamp [clock format [clock seconds]]
set fl [open mylog.txt {WRONLY CREAT APPEND}]
puts $fl "$timestamp: bgerror in $::argv '$message'"
close $fl
}
.CE
.SH "SEE ALSO"
after(n), tclvars(n)
.SH KEYWORDS
background error, reporting
tcl8.4.20/doc/CrtSlave.3 0000644 0036047 0045461 00000023666 11737050674 013310 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands.
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_IsSafe\fR(\fIinterp\fR)
.sp
int
\fBTcl_MakeSafe\fR(\fIinterp\fR)
.sp
Tcl_Interp *
\fBTcl_CreateSlave\fR(\fIinterp, slaveName, isSafe\fR)
.sp
Tcl_Interp *
\fBTcl_GetSlave\fR(\fIinterp, slaveName\fR)
.sp
Tcl_Interp *
\fBTcl_GetMaster\fR(\fIinterp\fR)
.sp
int
\fBTcl_GetInterpPath\fR(\fIaskingInterp, slaveInterp\fR)
.sp
.VS
int
\fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv\fR)
.sp
int
\fBTcl_CreateAliasObj\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv\fR)
.VE
.sp
int
\fBTcl_GetAlias\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr\fR)
.sp
.VS
int
\fBTcl_GetAliasObj\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, objcPtr, objvPtr\fR)
.sp
int
\fBTcl_ExposeCommand\fR(\fIinterp, hiddenCmdName, cmdName\fR)
.sp
int
\fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR)
.SH ARGUMENTS
.AS Tcl_InterpDeleteProc **hiddenCmdName
.AP Tcl_Interp *interp in
Interpreter in which to execute the specified command.
.AP "CONST char" *slaveName in
Name of slave interpreter to create or manipulate.
.AP int isSafe in
If non-zero, a ``safe'' slave that is suitable for running untrusted code
is created, otherwise a trusted slave is created.
.AP Tcl_Interp *slaveInterp in
Interpreter to use for creating the source command for an alias (see
below).
.AP "CONST char" *slaveCmd in
Name of source command for alias.
.AP Tcl_Interp *targetInterp in
Interpreter that contains the target command for an alias.
.AP "CONST char" *targetCmd in
Name of target command for alias in \fItargetInterp\fR.
.AP int argc in
Count of additional arguments to pass to the alias command.
.AP "CONST char * CONST" *argv in
Vector of strings, the additional arguments to pass to the alias command.
This storage is owned by the caller.
.AP int objc in
Count of additional object arguments to pass to the alias object command.
.AP Tcl_Object **objv in
Vector of Tcl_Obj structures, the additional object arguments to pass to
the alias object command.
This storage is owned by the caller.
.AP Tcl_Interp **targetInterpPtr in
Pointer to location to store the address of the interpreter where a target
command is defined for an alias.
.AP "CONST char" **targetCmdPtr out
Pointer to location to store the address of the name of the target command
for an alias.
.AP int *argcPtr out
Pointer to location to store count of additional arguments to be passed to
the alias. The location is in storage owned by the caller.
.AP "CONST char" ***argvPtr out
Pointer to location to store a vector of strings, the additional arguments
to pass to an alias. The location is in storage owned by the caller, the
vector of strings is owned by the called function.
.AP int *objcPtr out
Pointer to location to store count of additional object arguments to be
passed to the alias. The location is in storage owned by the caller.
.AP Tcl_Obj ***objvPtr out
Pointer to location to store a vector of Tcl_Obj structures, the additional
arguments to pass to an object alias command. The location is in storage
owned by the caller, the vector of Tcl_Obj structures is owned by the
called function.
.VS
.VS 8.4
.AP "CONST char" *cmdName in
.VE
Name of an exposed command to hide or create.
.VS 8.4
.AP "CONST char" *hiddenCmdName in
.VE
Name under which a hidden command is stored and with which it can be
exposed or invoked.
.VE
.BE
.SH DESCRIPTION
.PP
These procedures are intended for access to the multiple interpreter
facility from inside C programs. They enable managing multiple interpreters
in a hierarchical relationship, and the management of aliases, commands
that when invoked in one interpreter execute a command in another
interpreter. The return value for those procedures that return an \fBint\fR
is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned
then the \fBresult\fR field of the interpreter contains an error message.
.PP
\fBTcl_CreateSlave\fR creates a new interpreter as a slave of \fIinterp\fR.
It also creates a slave command named \fIslaveName\fR in \fIinterp\fR which
allows \fIinterp\fR to manipulate the new slave.
If \fIisSafe\fR is zero, the command creates a trusted slave in which Tcl
code has access to all the Tcl commands.
If it is \fB1\fR, the command creates a ``safe'' slave in which Tcl code
has access only to set of Tcl commands defined as ``Safe Tcl''; see the
manual entry for the Tcl \fBinterp\fR command for details.
If the creation of the new slave interpreter failed, \fBNULL\fR is returned.
.PP
\fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is ``safe'' (was created
with the \fBTCL_SAFE_INTERPRETER\fR flag specified),
\fB0\fR otherwise.
.PP
\fBTcl_MakeSafe\fR marks \fIinterp\fR as ``safe'', so that future
calls to \fBTcl_IsSafe\fR will return 1. It also removes all known
potentially-unsafe core functionality (both commands and variables)
from \fIinterp\fR. However, it cannot know what parts of an extension
or application are safe and does not make any attempt to remove those
parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR.
Callers will want to take care with their use of \fBTcl_MakeSafe\fR
to avoid false claims of safety. For many situations, \fBTcl_CreateSlave\fR
may be a better choice, since it creates interpreters in a known-safe state.
.PP
\fBTcl_GetSlave\fR returns a pointer to a slave interpreter of
\fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR.
If no such slave interpreter exists, \fBNULL\fR is returned.
.PP
\fBTcl_GetMaster\fR returns a pointer to the master interpreter of
\fIinterp\fR. If \fIinterp\fR has no master (it is a
top-level interpreter) then \fBNULL\fR is returned.
.PP
\fBTcl_GetInterpPath\fR sets the \fIresult\fR field in \fIaskingInterp\fR
to the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR;
\fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation
of the relative path succeeds, \fBTCL_OK\fR is returned, else
\fBTCL_ERROR\fR is returned and the \fIresult\fR field in
\fIaskingInterp\fR contains the error message.
.PP
.VS
\fBTcl_CreateAlias\fR creates an object command named \fIslaveCmd\fR in
\fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR
to be invoked in \fItargetInterp\fR. The arguments specified by the strings
contained in \fIargv\fR are always prepended to any arguments supplied in the
invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR.
This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if
it fails; in that case, an error message is left in the object result
of \fIslaveInterp\fR.
Note that there are no restrictions on the ancestry relationship (as
created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\fR and
\fItargetInterp\fR. Any two interpreters can be used, without any
restrictions on how they are related.
.PP
\fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except
that it takes a vector of objects to pass as additional arguments instead
of a vector of strings.
.VE
.PP
\fBTcl_GetAlias\fR returns information about an alias \fIaliasName\fR
in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in
which case the corresponding datum is not returned. If a result field is
non\-\fBNULL\fR, the address indicated is set to the corresponding datum.
For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a
pointer to the string containing the name of the target command.
.VS
.PP
\fBTcl_GetAliasObj\fR is similar to \fBTcl_GetAlias\fR except that it
returns a pointer to a vector of Tcl_Obj structures instead of a vector of
strings.
.PP
\fBTcl_ExposeCommand\fR moves the command named \fIhiddenCmdName\fR from
the set of hidden commands to the set of exposed commands, putting
it under the name
\fIcmdName\fR.
\fIHiddenCmdName\fR must be the name of an existing hidden
command, or the operation will return \fBTCL_ERROR\fR and leave an error
message in the \fIresult\fR field in \fIinterp\fR.
If an exposed command named \fIcmdName\fR already exists,
the operation returns \fBTCL_ERROR\fR and leaves an error message in the
object result of \fIinterp\fR.
If the operation succeeds, it returns \fBTCL_OK\fR.
After executing this command, attempts to use \fIcmdName\fR in a call to
\fBTcl_Eval\fR or with the Tcl \fBeval\fR command will again succeed.
.PP
\fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of
exposed commands to the set of hidden commands, under the name
\fIhiddenCmdName\fR.
\fICmdName\fR must be the name of an existing exposed
command, or the operation will return \fBTCL_ERROR\fR and leave an error
message in the object result of \fIinterp\fR.
Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain
namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and
leave an error message in the object result of \fIinterp\fR.
The \fICmdName\fR will be looked up in the global namespace, and not
relative to the current namespace, even if the current namespace is not the
global one.
If a hidden command whose name is \fIhiddenCmdName\fR already
exists, the operation also returns \fBTCL_ERROR\fR and the \fIresult\fR
field in \fIinterp\fR contains an error message.
If the operation succeeds, it returns \fBTCL_OK\fR.
After executing this command, attempts to use \fIcmdName\fR in a call to
\fBTcl_Eval\fR or with the Tcl \fBeval\fR command will fail.
.PP
For a description of the Tcl interface to multiple interpreters, see
\fIinterp(n)\fR.
.SH "SEE ALSO"
interp
.SH KEYWORDS
alias, command, exposed commands, hidden commands, interpreter, invoke,
master, slave
tcl8.4.20/doc/variable.n 0000644 0036047 0045461 00000006006 11737050674 013432 0 ustar dgp 771div '\"
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" 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.
'\"
.so man.macros
.TH variable n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
variable \- create and initialize a namespace variable
.SH SYNOPSIS
\fBvariable \fR?\fIname value...\fR? \fIname \fR?\fIvalue\fR?
.BE
.SH DESCRIPTION
.PP
This command is normally used within a
\fBnamespace eval\fR command to create one or more variables
within a namespace.
Each variable \fIname\fR is initialized with \fIvalue\fR.
The \fIvalue\fR for the last variable is optional.
.PP
If a variable \fIname\fR does not exist, it is created.
In this case, if \fIvalue\fR is specified,
it is assigned to the newly created variable.
If no \fIvalue\fR is specified, the new variable is left undefined.
If the variable already exists,
it is set to \fIvalue\fR if \fIvalue\fR is specified
or left unchanged if no \fIvalue\fR is given.
Normally, \fIname\fR is unqualified
(does not include the names of any containing namespaces),
and the variable is created in the current namespace.
If \fIname\fR includes any namespace qualifiers,
the variable is created in the specified namespace. If the variable
is not defined, it will be visible to the \fBnamespace which\fR
command, but not to the \fBinfo exists\fR command.
.PP
If the \fBvariable\fR command is executed inside a Tcl procedure,
it creates local variables
linked to the corresponding namespace variables (and therefore these
variables are listed by \fBinfo vars\fR.)
In this way the \fBvariable\fR command resembles the \fBglobal\fR command,
although the \fBglobal\fR command
only links to variables in the global namespace.
If any \fIvalue\fRs are given,
they are used to modify the values of the associated namespace variables.
If a namespace variable does not exist,
it is created and optionally initialized.
.PP
A \fIname\fR argument cannot reference an element within an array.
Instead, \fIname\fR should reference the entire array,
and the initialization \fIvalue\fR should be left off.
After the variable has been declared,
elements within the array can be set using ordinary
\fBset\fR or \fBarray\fR commands.
.SH EXAMPLES
Create a variable in a namespace:
.CS
namespace eval foo {
\fBvariable\fR bar 12345
}
.CE
.PP
Create an array in a namespace:
.CS
namespace eval someNS {
\fBvariable\fR someAry
array set someAry {
someName someValue
otherName otherValue
}
}
.CE
.PP
Access variables in namespaces from a procedure:
.CS
namespace eval foo {
proc spong {} {
# Variable in this namespace
\fBvariable\fR bar
puts "bar is $bar"
# Variable in another namespace
\fBvariable\fR ::someNS::someAry
parray someAry
}
}
.CE
.SH "SEE ALSO"
global(n), namespace(n), upvar(n)
.SH KEYWORDS
global, namespace, procedure, variable
tcl8.4.20/doc/CmdCmplt.3 0000644 0036047 0045461 00000001713 11737050674 013255 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_CommandComplete 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CommandComplete \- Check for unmatched braces in a Tcl command
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_CommandComplete\fR(\fIcmd\fR)
.SH ARGUMENTS
.AS "CONST char" *cmd
.AP "CONST char" *cmd in
Command string to test for completeness.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CommandComplete\fR takes a Tcl command string
as argument and determines whether it contains one or more
complete commands (i.e. there are no unclosed quotes, braces,
brackets, or variable references).
If the command string is complete then it returns 1; otherwise it returns 0.
.SH KEYWORDS
complete command, partial command
tcl8.4.20/doc/Access.3 0000644 0036047 0045461 00000005352 11737050674 012756 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_Access 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Access, Tcl_Stat \- check file permissions and other attributes
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_Access\fR(\fIpath\fR, \fImode\fR)
.sp
int
\fBTcl_Stat\fR(\fIpath\fR, \fIstatPtr\fR)
.SH ARGUMENTS
.AS "struct stat" *statPtr in
.AP char *path in
Native name of the file to check the attributes of.
.AP int mode in
Mask consisting of one or more of R_OK, W_OK, X_OK and F_OK. R_OK,
W_OK and X_OK request checking whether the file exists and has read,
write and execute permissions, respectively. F_OK just requests
checking for the existence of the file.
.AP "struct stat" *statPtr out
The structure that contains the result.
.BE
.SH DESCRIPTION
.PP
As of Tcl 8.4, the object-based APIs \fBTcl_FSAccess\fR and
\fBTcl_FSStat\fR should be used in preference to \fBTcl_Access\fR and
\fBTcl_Stat\fR, wherever possible.
.PP
There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR
rather than calling system level functions \fBaccess\fR and \fBstat\fR
directly. First, the Windows implementation of both functions fixes
some bugs in the system level calls. Second, both \fBTcl_Access\fR
and \fBTcl_Stat\fR (as well as \fBTcl_OpenFileChannelProc\fR) hook
into a linked list of functions. This allows the possibility to reroute
file access to alternative media or access methods.
.PP
\fBTcl_Access\fR checks whether the process would be allowed to read,
write or test for existence of the file (or other file system object)
whose name is pathname. If pathname is a symbolic link on Unix,
then permissions of the file referred by this symbolic link are
tested.
.PP
On success (all requested permissions granted), zero is returned. On
error (at least one bit in mode asked for a permission that is denied,
or some other error occurred), -1 is returned.
.PP
\fBTcl_Stat\fR fills the stat structure \fIstatPtr\fR with information
about the specified file. You do not need any access rights to the
file to get this information but you need search rights to all
directories named in the path leading to the file. The stat structure
includes info regarding device, inode (always 0 on Windows),
privilege mode, nlink (always 1 on Windows), user id (always 0 on
Windows), group id (always 0 on Windows), rdev (same as device on
Windows), size, last access time, last modification time, and creation
time.
.PP
If \fIpath\fR exists, \fBTcl_Stat\fR returns 0 and the stat structure
is filled with data. Otherwise, -1 is returned, and no stat info is
given.
.SH KEYWORDS
stat, access
tcl8.4.20/doc/list.n 0000644 0036047 0045461 00000003005 11737050674 012614 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH list n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
list \- Create a list
.SH SYNOPSIS
\fBlist \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command returns a list comprised of all the \fIarg\fRs,
or an empty string if no \fIarg\fRs are specified.
Braces and backslashes get added as necessary, so that the \fBlindex\fR command
may be used on the result to re-extract the original arguments, and also
so that \fBeval\fR may be used to execute the resulting list, with
\fIarg1\fR comprising the command's name and the other \fIarg\fRs comprising
its arguments. \fBList\fR produces slightly different results than
\fBconcat\fR: \fBconcat\fR removes one level of grouping before forming
the list, while \fBlist\fR works directly from the original arguments.
.SH EXAMPLE
The command
.CS
\fBlist\fR a b "c d e " " f {g h}"
.CE
will return
.CS
\fBa b {c d e } { f {g h}}\fR
.CE
while \fBconcat\fR with the same arguments will return
.CS
\fBa b c d e f {g h}\fR
.CE
.SH "SEE ALSO"
lappend(n), lindex(n), linsert(n), llength(n), lrange(n),
lreplace(n), lsearch(n),
.VS 8.4
lset(n),
.VE 8.4
lsort(n)
.SH KEYWORDS
element, list
tcl8.4.20/doc/seek.n 0000644 0036047 0045461 00000005374 11737050674 012603 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH seek n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
seek \- Change the access position for an open channel
.SH SYNOPSIS
\fBseek \fIchannelId offset \fR?\fIorigin\fR?
.BE
.SH DESCRIPTION
.PP
Changes the current access position for \fIchannelId\fR.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.VE
.PP
The \fIoffset\fR and \fIorigin\fR
arguments specify the position at which the next read or write will occur
for \fIchannelId\fR. \fIOffset\fR must be an integer (which may be
negative) and \fIorigin\fR must be one of the following:
.TP 10
\fBstart\fR
The new access position will be \fIoffset\fR bytes from the start
of the underlying file or device.
.TP 10
\fBcurrent\fR
The new access position will be \fIoffset\fR bytes from the current
access position; a negative \fIoffset\fR moves the access position
backwards in the underlying file or device.
.TP 10
\fBend\fR
The new access position will be \fIoffset\fR bytes from the end of
the file or device. A negative \fIoffset\fR places the access position
before the end of file, and a positive \fIoffset\fR places the access
position after the end of file.
.LP
The \fIorigin\fR argument defaults to \fBstart\fR.
.PP
The command flushes all buffered output for the channel before the command
returns, even if the channel is in nonblocking mode.
It also discards any buffered and unread input.
This command returns an empty string.
An error occurs if this command is applied to channels whose underlying
file or device does not support seeking.
.PP
.VS 8.1
Note that \fIoffset\fR values are byte offsets, not character
offsets. Both \fBseek\fR and \fBtell\fR operate in terms of bytes,
not characters, unlike \fBread\fR.
.VE 8.1
.SH EXAMPLES
Read a file twice:
.CS
set f [open file.txt]
set data1 [read $f]
\fBseek\fR $f 0
set data2 [read $f]
close $f
# $data1 == $data2 if the file wasn't updated
.CE
.PP
Read the last 10 bytes from a file:
.CS
set f [open file.data]
# This is guaranteed to work with binary data but
# may fail with other encodings...
fconfigure $f -translation binary
\fBseek\fR $f -10 end
set data [read $f 10]
close $f
.CE
.SH "SEE ALSO"
file(n), open(n), close(n), gets(n), tell(n), Tcl_StandardChannels(3)
.SH KEYWORDS
access position, file, seek
tcl8.4.20/doc/open.n 0000644 0036047 0045461 00000044207 12052456743 012611 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH open n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
open \- Open a file-based or command pipeline channel
.SH SYNOPSIS
.sp
\fBopen \fIfileName\fR
.br
\fBopen \fIfileName access\fR
.br
\fBopen \fIfileName access permissions\fR
.BE
.SH DESCRIPTION
.PP
This command opens a file, serial port, or command pipeline and returns a
channel identifier that may be used in future invocations of commands like
\fBread\fR, \fBputs\fR, and \fBclose\fR.
If the first character of \fIfileName\fR is not \fB|\fR then
the command opens a file:
\fIfileName\fR gives the name of the file to open, and it must conform to the
conventions described in the \fBfilename\fR manual entry.
.PP
The \fIaccess\fR argument, if present, indicates the way in which the file
(or command pipeline) is to be accessed.
In the first form \fIaccess\fR may have any of the following values:
.TP 15
\fBr\fR
Open the file for reading only; the file must already exist. This is the
default value if \fIaccess\fR is not specified.
.TP 15
\fBr+\fR
Open the file for both reading and writing; the file must
already exist.
.TP 15
\fBw\fR
Open the file for writing only. Truncate it if it exists. If it doesn't
exist, create a new file.
.TP 15
\fBw+\fR
Open the file for reading and writing. Truncate it if it exists.
If it doesn't exist, create a new file.
.TP 15
\fBa\fR
Open the file for writing only. If the file doesn't exist,
create a new empty file.
Set the file pointer to the end of the file prior to each write.
.TP 15
\fBa+\fR
Open the file for reading and writing. If the file doesn't exist,
create a new empty file.
Set the initial access position to the end of the file.
.PP
In the second form, \fIaccess\fR consists of a list of any of the
following flags, all of which have the standard POSIX meanings.
One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR.
.TP 15
\fBRDONLY\fR
Open the file for reading only.
.TP 15
\fBWRONLY\fR
Open the file for writing only.
.TP 15
\fBRDWR\fR
Open the file for both reading and writing.
.TP 15
\fBAPPEND\fR
Set the file pointer to the end of the file prior to each write.
.TP 15
\fBCREAT\fR
Create the file if it doesn't already exist (without this flag it
is an error for the file not to exist).
.TP 15
\fBEXCL\fR
If \fBCREAT\fR is also specified, an error is returned if the
file already exists.
.TP 15
\fBNOCTTY\fR
If the file is a terminal device, this flag prevents the file from
becoming the controlling terminal of the process.
.TP 15
\fBNONBLOCK\fR
Prevents the process from blocking while opening the file, and
possibly in subsequent I/O operations. The exact behavior of
this flag is system- and device-dependent; its use is discouraged
(it is better to use the \fBfconfigure\fR command to put a file
in nonblocking mode).
For details refer to your system documentation on the \fBopen\fR system
call's \fBO_NONBLOCK\fR flag.
.TP 15
\fBTRUNC\fR
If the file exists it is truncated to zero length.
.PP
If a new file is created as part of opening it, \fIpermissions\fR
(an integer) is used to set the permissions for the new file in
conjunction with the process's file mode creation mask.
\fIPermissions\fR defaults to 0666.
.PP
Note that if you are going to be reading or writing binary data from
the channel created by this command, you should use the
\fBfconfigure\fR command to change the \fB-translation\fR option of
the channel to \fBbinary\fR before transferring any binary data. This
is in contrast to the ``b'' character passed as part of the equivalent
of the \fIaccess\fR parameter to some versions of the C library
\fIfopen()\fR function.
.SH "COMMAND PIPELINES"
.PP
If the first character of \fIfileName\fR is ``|'' then the
remaining characters of \fIfileName\fR are treated as a list of arguments
that describe a command pipeline to invoke, in the same style as the
arguments for \fBexec\fR.
In this case, the channel identifier returned by \fBopen\fR may be used
to write to the command's input pipe or read from its output pipe,
depending on the value of \fIaccess\fR.
If write-only access is used (e.g. \fIaccess\fR is \fBw\fR), then
standard output for the pipeline is directed to the current standard
output unless overridden by the command.
If read-only access is used (e.g. \fIaccess\fR is \fBr\fR),
standard input for the pipeline is taken from the current standard
input unless overridden by the command.
The id of the spawned process is accessible through the \fBpid\fR
command, using the channel id returned by \fBopen\fR as argument.
.PP
If the command (or one of the commands) executed in the command
pipeline returns an error (according to the definition in \fBexec\fR),
a Tcl error is generated when \fBclose\fR is called on the channel
unless the pipeline is in non-blocking mode then no exit status is
returned (a silent \fBclose\fR with -blocking 0).
.PP
It is often useful to use the \fBfileevent\fR command with pipelines
so other processing may happen at the same time as running the command
in the background.
.VS 8.4
.SH "SERIAL COMMUNICATIONS"
.PP
If \fIfileName\fR refers to a serial port, then the specified serial port
is opened and initialized in a platform-dependent manner. Acceptable
values for the \fIfileName\fR to use to open a serial port are described in
the PORTABILITY ISSUES section.
.PP
The \fBfconfigure\fR command can be used to query and set additional
configuration options specific to serial ports (where supported):
.TP
\fB\-mode\fR \fIbaud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR
This option is a set of 4 comma-separated values: the baud rate, parity,
number of data bits, and number of stop bits for this serial port. The
\fIbaud\fR rate is a simple integer that specifies the connection speed.
\fIParity\fR is one of the following letters: \fBn\fR, \fBo\fR, \fBe\fR,
\fBm\fR, \fBs\fR; respectively signifying the parity options of ``none'',
``odd'', ``even'', ``mark'', or ``space''. \fIData\fR is the number of
data bits and should be an integer from 5 to 8, while \fIstop\fR is the
number of stop bits and should be the integer 1 or 2.
.TP
\fB\-handshake\fR \fItype\fR
(Windows and Unix). This option is used to setup automatic handshake
control. Note that not all handshake types maybe supported by your operating
system. The \fItype\fR parameter is case-independent.
.sp
If \fItype\fR is \fBnone\fR then any handshake is switched off.
\fBrtscts\fR activates hardware handshake. Hardware handshake signals
are described below.
For software handshake \fBxonxoff\fR the handshake characters can be redefined
with \fB-xchar\fR.
An additional hardware handshake \fBdtrdsr\fR is available only under Windows.
There is no default handshake configuration, the initial value depends
on your operating system settings.
The \fB-handshake\fR option cannot be queried.
.TP
\fB\-queue\fR
(Windows and Unix). The \fB-queue\fR option can only be queried.
It returns a list of two integers representing the current number
of bytes in the input and output queue respectively.
.TP
\fB\-timeout\fR \fImsec\fR
(Windows and Unix). This option is used to set the timeout for blocking
read operations. It specifies the maximum interval between the
reception of two bytes in milliseconds.
For Unix systems the granularity is 100 milliseconds.
The \fB-timeout\fR option does not affect write operations or
nonblocking reads.
This option cannot be queried.
.TP
\fB\-ttycontrol\fR \fI{signal boolean signal boolean ...}\fR
(Windows and Unix). This option is used to setup the handshake
output lines (see below) permanently or to send a BREAK over the serial line.
The \fIsignal\fR names are case-independent.
\fB{RTS 1 DTR 0}\fR sets the RTS output to high and the DTR output to low.
The BREAK condition (see below) is enabled and disabled with \fB{BREAK 1}\fR and
\fB{BREAK 0}\fR respectively.
It's not a good idea to change the \fBRTS\fR (or \fBDTR\fR) signal
with active hardware handshake \fBrtscts\fR (or \fBdtrdsr\fR).
The result is unpredictable.
The \fB-ttycontrol\fR option cannot be queried.
.TP
\fB\-ttystatus\fR
(Windows and Unix). The \fB-ttystatus\fR option can only be
queried. It returns the current modem status and handshake input signals
(see below).
The result is a list of signal,value pairs with a fixed order,
e.g. \fB{CTS 1 DSR 0 RING 1 DCD 0}\fR.
The \fIsignal\fR names are returned upper case.
.TP
\fB\-xchar\fR \fI{xonChar xoffChar}\fR
(Windows and Unix). This option is used to query or change the software
handshake characters. Normally the operating system default should be
DC1 (0x11) and DC3 (0x13) representing the ASCII standard
XON and XOFF characters.
.TP
\fB\-pollinterval\fR \fImsec\fR
(Windows only). This option is used to set the maximum time between
polling for fileevents.
This affects the time interval between checking for events throughout the Tcl
interpreter (the smallest value always wins). Use this option only if
you want to poll the serial port more or less often than 10 msec
(the default).
.TP
\fB\-sysbuffer\fR \fIinSize\fR
.TP
\fB\-sysbuffer\fR \fI{inSize outSize}\fR
(Windows only). This option is used to change the size of Windows
system buffers for a serial channel. Especially at higher communication
rates the default input buffer size of 4096 bytes can overrun
for latent systems. The first form specifies the input buffer size,
in the second form both input and output buffers are defined.
.TP
\fB\-lasterror\fR
(Windows only). This option is query only.
In case of a serial communication error, \fBread\fR or \fBputs\fR
returns a general Tcl file I/O error.
\fBfconfigure -lasterror\fR can be called to get a list of error details.
See below for an explanation of the various error codes.
.SH "SERIAL PORT SIGNALS"
.PP
RS-232 is the most commonly used standard electrical interface for serial
communications. A negative voltage (-3V..-12V) define a mark (on=1) bit and
a positive voltage (+3..+12V) define a space (off=0) bit (RS-232C). The
following signals are specified for incoming and outgoing data, status
lines and handshaking. Here we are using the terms \fIworkstation\fR for
your computer and \fImodem\fR for the external device, because some signal
names (DCD, RI) come from modems. Of course your external device may use
these signal lines for other purposes.
.IP \fBTXD(output)\fR
\fBTransmitted Data:\fR Outgoing serial data.
.IP \fBRXD(input)\fR
\fBReceived Data:\fRIncoming serial data.
.IP \fBRTS(output)\fR
\fBRequest To Send:\fR This hardware handshake line informs the modem that
your workstation is ready to receive data. Your workstation may
automatically reset this signal to indicate that the input buffer is full.
.IP \fBCTS(input)\fR
\fBClear To Send:\fR The complement to RTS. Indicates that the modem is
ready to receive data.
.IP \fBDTR(output)\fR
\fBData Terminal Ready:\fR This signal tells the modem that the workstation
is ready to establish a link. DTR is often enabled automatically whenever a
serial port is opened.
.IP \fBDSR(input)\fR
\fBData Set Ready:\fR The complement to DTR. Tells the workstation that the
modem is ready to establish a link.
.IP \fBDCD(input)\fR
\fBData Carrier Detect:\fR This line becomes active when a modem detects
a "Carrier" signal.
.IP \fBRI(input)\fR
\fBRing Indicator:\fR Goes active when the modem detects an incoming call.
.IP \fBBREAK\fR
A BREAK condition is not a hardware signal line, but a logical zero on the
TXD or RXD lines for a long period of time, usually 250 to 500
milliseconds. Normally a receive or transmit data signal stays at the mark
(on=1) voltage until the next character is transferred. A BREAK is sometimes
used to reset the communications line or change the operating mode of
communications hardware.
.SH "ERROR CODES (Windows only)"
.PP
A lot of different errors may occur during serial read operations or during
event polling in background. The external device may have been switched
off, the data lines may be noisy, system buffers may overrun or your mode
settings may be wrong. That's why a reliable software should always
\fBcatch\fR serial read operations. In cases of an error Tcl returns a
general file I/O error. Then \fBfconfigure -lasterror\fR may help to
locate the problem. The following error codes may be returned.
.TP 10
\fBRXOVER\fR
Windows input buffer overrun. The data comes faster than your scripts reads
it or your system is overloaded. Use \fBfconfigure -sysbuffer\fR to avoid a
temporary bottleneck and/or make your script faster.
.TP 10
\fBTXFULL\fR
Windows output buffer overrun. Complement to RXOVER. This error should
practically not happen, because Tcl cares about the output buffer status.
.TP 10
\fBOVERRUN\fR
UART buffer overrun (hardware) with data lost.
The data comes faster than the system driver receives it.
Check your advanced serial port settings to enable the FIFO (16550) buffer
and/or setup a lower(1) interrupt threshold value.
.TP 10
\fBRXPARITY\fR
A parity error has been detected by your UART.
Wrong parity settings with \fBfconfigure -mode\fR or a noisy data line (RXD)
may cause this error.
.TP 10
\fBFRAME\fR
A stop-bit error has been detected by your UART.
Wrong mode settings with \fBfconfigure -mode\fR or a noisy data line (RXD)
may cause this error.
.TP 10
\fBBREAK\fR
A BREAK condition has been detected by your UART (see above).
.VE
.SH "PORTABILITY ISSUES"
.TP
\fBWindows \fR(all versions)
Valid values for \fIfileName\fR to open a serial port are of the form
\fBcom\fIX\fB:\fR, where \fIX\fR is a number, generally from 1 to 4.
This notation only works for serial ports from 1 to 9, if the system
happens to have more than four. An attempt to open a serial port that
does not exist or has a number greater than 9 will fail. An alternate
form of opening serial ports is to use the filename \fB\e\e.\ecomX\fR,
where X is any number that corresponds to a serial port; please note
that this method is considerably slower on Windows 95 and Windows 98.
.TP
\fBWindows NT\fR
When running Tcl interactively, there may be some strange interactions
between the real console, if one is present, and a command pipeline that uses
standard input or output. If a command pipeline is opened for reading, some
of the lines entered at the console will be sent to the command pipeline and
some will be sent to the Tcl evaluator. If a command pipeline is opened for
writing, keystrokes entered into the console are not visible until the
pipe is closed. This behavior occurs whether the command pipeline is
executing 16-bit or 32-bit applications. These problems only occur because
both Tcl and the child application are competing for the console at
the same time. If the command pipeline is started from a script, so that Tcl
is not accessing the console, or if the command pipeline does not use
standard input or output, but is redirected from or to a file, then the
above problems do not occur.
.TP
\fBWindows 95\fR
A command pipeline that executes a 16-bit DOS application cannot be opened
for both reading and writing, since 16-bit DOS applications that receive
standard input from a pipe and send standard output to a pipe run
synchronously. Command pipelines that do not execute 16-bit DOS
applications run asynchronously and can be opened for both reading and
writing.
.sp
When running Tcl interactively, there may be some strange interactions
between the real console, if one is present, and a command pipeline that uses
standard input or output. If a command pipeline is opened for reading from
a 32-bit application, some of the keystrokes entered at the console will be
sent to the command pipeline and some will be sent to the Tcl evaluator. If
a command pipeline is opened for writing to a 32-bit application, no output
is visible on the console until the pipe is closed. These problems only
occur because both Tcl and the child application are competing for the
console at the same time. If the command pipeline is started from a script,
so that Tcl is not accessing the console, or if the command pipeline does
not use standard input or output, but is redirected from or to a file, then
the above problems do not occur.
.sp
Whether or not Tcl is running interactively, if a command pipeline is opened
for reading from a 16-bit DOS application, the call to \fBopen\fR will not
return until end-of-file has been received from the command pipeline's
standard output. If a command pipeline is opened for writing to a 16-bit DOS
application, no data will be sent to the command pipeline's standard output
until the pipe is actually closed. This problem occurs because 16-bit DOS
applications are run synchronously, as described above.
.TP
\fBUnix\fR\0\0\0\0\0\0\0
Valid values for \fIfileName\fR to open a serial port are generally of the
form \fB/dev/tty\fIX\fR, where \fIX\fR is \fBa\fR or \fBb\fR, but the name
of any pseudo-file that maps to a serial port may be used.
.VS 8.4
Advanced configuration options are only supported for serial ports
when Tcl is built to use the POSIX serial interface.
.VE 8.4
.sp
When running Tcl interactively, there may be some strange interactions
between the console, if one is present, and a command pipeline that uses
standard input. If a command pipeline is opened for reading, some
of the lines entered at the console will be sent to the command pipeline and
some will be sent to the Tcl evaluator. This problem only occurs because
both Tcl and the child application are competing for the console at the
same time. If the command pipeline is started from a script, so that Tcl is
not accessing the console, or if the command pipeline does not use standard
input, but is redirected from a file, then the above problem does not occur.
.LP
See the PORTABILITY ISSUES section of the \fBexec\fR command for additional
information not specific to command pipelines about executing
applications on the various platforms
.SH "EXAMPLE"
Open a command pipeline and catch any errors:
.CS
set fl [\fBopen\fR "| ls this_file_does_not_exist"]
set data [read $fl]
if {[catch {close $fl} err]} {
puts "ls command failed: $err"
}
.CE
.SH "SEE ALSO"
file(n), close(n), filename(n), fconfigure(n), gets(n), read(n),
puts(n), exec(n), pid(n), fopen(3)
.SH KEYWORDS
access mode, append, create, file, non-blocking, open, permissions,
pipeline, process, serial
tcl8.4.20/doc/UniCharIsAlpha.3 0000644 0036047 0045461 00000005052 11737050674 014345 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_UniCharIsAlpha 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_UniCharIsAlnum, Tcl_UniCharIsAlpha, Tcl_UniCharIsControl, Tcl_UniCharIsDigit, Tcl_UniCharIsGraph, Tcl_UniCharIsLower, Tcl_UniCharIsPrint, Tcl_UniCharIsPunct, Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsWordChar \- routines for classification of Tcl_UniChar characters
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_UniCharIsAlnum\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsAlpha\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsControl\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsDigit\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsGraph\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsLower\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsPrint\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsPunct\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsSpace\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsUpper\fR(\fIch\fR)
.sp
int
\fBTcl_UniCharIsWordChar\fR(\fIch\fR)
.SH ARGUMENTS
.AP int ch in
The Tcl_UniChar to be examined.
.BE
.SH DESCRIPTION
.PP
All of the routines described examine Tcl_UniChars and return a
boolean value. A non-zero return value means that the character does
belong to the character class associated with the called routine. The
rest of this document just describes the character classes associated
with the various routines.
.PP
Note: A Tcl_UniChar is a Unicode character represented as an unsigned,
fixed-size quantity.
.SH CHARACTER CLASSES
.PP
\fBTcl_UniCharIsAlnum\fR tests if the character is an alphanumeric Unicode character.
.PP
\fBTcl_UniCharIsAlpha\fR tests if the character is an alphabetic Unicode character.
.PP
\fBTcl_UniCharIsControl\fR tests if the character is a Unicode control character.
.PP
\fBTcl_UniCharIsDigit\fR tests if the character is a numeric Unicode character.
.PP
\fBTcl_UniCharIsGraph\fR tests if the character is any Unicode print character except space.
.PP
\fBTcl_UniCharIsLower\fR tests if the character is a lowercase Unicode character.
.PP
\fBTcl_UniCharIsPrint\fR tests if the character is a Unicode print character.
.PP
\fBTcl_UniCharIsPunct\fR tests if the character is a Unicode punctuation character.
.PP
\fBTcl_UniCharIsSpace\fR tests if the character is a whitespace Unicode character.
.PP
\fBTcl_UniCharIsUpper\fR tests if the character is an uppercase Unicode character.
.PP
\fBTcl_UniCharIsWordChar\fR tests if the character is alphanumeric or
a connector punctuation mark.
.SH KEYWORDS
unicode, classification
tcl8.4.20/doc/DoOneEvent.3 0000644 0036047 0045461 00000010006 11737050674 013553 0 ustar dgp 771div '\"
'\" Copyright (c) 1990-1992 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_DoOneEvent 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_DoOneEvent \- wait for events and invoke event handlers
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_DoOneEvent\fR(\fIflags\fR)
.SH ARGUMENTS
.AS int flags
.AP int flags in
This parameter is normally zero. It may be an OR-ed combination
of any of the following flag bits:
TCL_WINDOW_EVENTS,
TCL_FILE_EVENTS, TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, TCL_ALL_EVENTS, or
TCL_DONT_WAIT.
.BE
.SH DESCRIPTION
.PP
This procedure is the entry point to Tcl's event loop; it is responsible for
waiting for events and dispatching event handlers created with
procedures such as \fBTk_CreateEventHandler\fR, \fBTcl_CreateFileHandler\fR,
\fBTcl_CreateTimerHandler\fR, and \fBTcl_DoWhenIdle\fR.
\fBTcl_DoOneEvent\fR checks to see if
events are already present on the Tcl event queue; if so,
it calls the handler(s) for the first (oldest) event, removes it from
the queue, and returns.
If there are no events ready to be handled, then \fBTcl_DoOneEvent\fR
checks for new events from all possible sources.
If any are found, it puts all of them on Tcl's event queue, calls
handlers for the first event on the queue, and returns.
If no events are found, \fBTcl_DoOneEvent\fR checks for \fBTcl_DoWhenIdle\fR
callbacks; if any are found, it invokes all of them and returns.
Finally, if no events or idle callbacks have been found, then
\fBTcl_DoOneEvent\fR sleeps until an event occurs; then it adds any
new events to the Tcl event queue, calls handlers for the first event,
and returns.
The normal return value is 1 to signify that some event
was processed (see below for other alternatives).
.PP
If the \fIflags\fR argument to \fBTcl_DoOneEvent\fR is non-zero,
it restricts the kinds of events that will be processed by
\fBTcl_DoOneEvent\fR.
\fIFlags\fR may be an OR-ed combination of any of the following bits:
.TP 27
\fBTCL_WINDOW_EVENTS\fR \-
Process window system events.
.TP 27
\fBTCL_FILE_EVENTS\fR \-
Process file events.
.TP 27
\fBTCL_TIMER_EVENTS\fR \-
Process timer events.
.TP 27
\fBTCL_IDLE_EVENTS\fR \-
Process idle callbacks.
.TP 27
\fBTCL_ALL_EVENTS\fR \-
Process all kinds of events: equivalent to OR-ing together all of the
above flags or specifying none of them.
.TP 27
\fBTCL_DONT_WAIT\fR \-
Don't sleep: process only events that are ready at the time of the
call.
.LP
If any of the flags \fBTCL_WINDOW_EVENTS\fR, \fBTCL_FILE_EVENTS\fR,
\fBTCL_TIMER_EVENTS\fR, or \fBTCL_IDLE_EVENTS\fR is set, then the only
events that will be considered are those for which flags are set.
Setting none of these flags is equivalent to the value
\fBTCL_ALL_EVENTS\fR, which causes all event types to be processed.
If an application has defined additional event sources with
\fBTcl_CreateEventSource\fR, then additional \fIflag\fR values
may also be valid, depending on those event sources.
.PP
The \fBTCL_DONT_WAIT\fR flag causes \fBTcl_DoOneEvent\fR not to put
the process to sleep: it will check for events but if none are found
then it returns immediately with a return value of 0 to indicate
that no work was done.
\fBTcl_DoOneEvent\fR will also return 0 without doing anything if
the only alternative is to block forever (this can happen, for example,
if \fIflags\fR is \fBTCL_IDLE_EVENTS\fR and there are no
\fBTcl_DoWhenIdle\fR callbacks pending, or if no event handlers or
timer handlers exist).
.PP
\fBTcl_DoOneEvent\fR may be invoked recursively. For example,
it is possible to invoke \fBTcl_DoOneEvent\fR recursively
from a handler called by \fBTcl_DoOneEvent\fR. This sort
of operation is useful in some modal situations, such
as when a
notification dialog has been popped up and an application wishes to
wait for the user to click a button in the dialog before
doing anything else.
.SH KEYWORDS
callback, event, handler, idle, timer
tcl8.4.20/doc/memory.n 0000644 0036047 0045461 00000010277 11737050674 013162 0 ustar dgp 771div '\"
'\" Copyright (c) 1992-1999 by Karl Lehenbauer and Mark Diekhans
'\" Copyright (c) 2000 by Scriptics Corporation.
'\" All rights reserved.
'\"
.so man.macros
.TH memory n 8.1 Tcl "Tcl Built-In Commands"
.BS
.SH NAME
memory \- Control Tcl memory debugging capabilities.
.SH SYNOPSIS
\fBmemory \fIoption \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBmemory\fR command gives the Tcl developer control of Tcl's memory
debugging capabilities. The memory command has several suboptions, which are
described below. It is only available when Tcl has been compiled with
memory debugging enabled (when \fBTCL_MEM_DEBUG\fR is defined at
compile time), and after \fBTcl_InitMemory\fR has been called.
.TP
\fBmemory active\fR \fIfile\fR
Write a list of all currently allocated memory to the specified \fIfile\fR.
.TP
\fBmemory break_on_malloc\fR \fIcount\fR
After the \fIcount\fR allocations have been performed, \fBckalloc\fR
outputs a message to this effect and that it is now attempting to enter
the C debugger. Tcl will then issue a \fISIGINT\fR signal against itself.
If you are running Tcl under a C debugger, it should then enter the debugger
command mode.
.TP
\fBmemory info\fR
Returns a report containing the total allocations and frees since
Tcl began, the current packets allocated (the current
number of calls to \fBckalloc\fR not met by a corresponding call
to \fBckfree\fR), the current bytes allocated, and the maximum number
of packets and bytes allocated.
.TP
\fB memory init [on|off]\fR
Turn on or off the pre-initialization of all allocated memory
with bogus bytes. Useful for detecting the use of uninitialized values.
.TP
\fBmemory onexit\fR \fIfile\fR
Causes a list of all allocated memory to be written to the specified \fIfile\fR
during the finalization of Tcl's memory subsystem. Useful for checking
that memory is properly cleaned up during process exit.
.TP
\fBmemory tag\fR \fIstring\fR
Each packet of memory allocated by \fBckalloc\fR can have associated
with it a string-valued tag. In the lists of allocated memory generated
by \fBmemory active\fR and \fBmemory onexit\fR, the tag for each packet
is printed along with other information about the packet. The
\fBmemory tag\fR command sets the tag value for subsequent calls
to \fBckalloc\fR to be \fIstring\fR.
.TP
\fBmemory trace [on|off]\fR
.br
Turns memory tracing on or off. When memory tracing is on, every call
to \fBckalloc\fR causes a line of trace information to be written to
\fIstderr\fR, consisting of the word \fIckalloc\fR, followed by the
address returned, the amount of memory allocated, and the C filename
and line number of the code performing the allocation. For example:
.RS
.CS
ckalloc 40e478 98 tclProc.c 1406
.CE
Calls to \fBckfree\fR are traced in the same manner.
.RE
.TP
\fBmemory trace_on_at_malloc\fR \fIcount\fR
Enable memory tracing after \fIcount\fR \fBckalloc\fR's have been performed.
For example, if you enter \fBmemory trace_on_at_malloc 100\fR,
after the 100th call to \fBckalloc\fR, memory trace information will begin
being displayed for all allocations and frees. Since there can be a lot
of memory activity before a problem occurs, judicious use of this option
can reduce the slowdown caused by tracing (and the amount of trace information
produced), if you can identify a number of allocations that occur before
the problem sets in. The current number of memory allocations that have
occurred since Tcl started is printed on a guard zone failure.
.TP
\fBmemory validate [on|off]\fR
Turns memory validation on or off. When memory validation is enabled,
on every call to \fBckalloc\fR or \fBckfree\fR, the guard zones are
checked for every piece of memory currently in existence that was
allocated by \fBckalloc\fR. This has a large performance impact and
should only be used when overwrite problems are strongly suspected.
The advantage of enabling memory validation is that a guard zone
overwrite can be detected on the first call to \fBckalloc\fR or
\fBckfree\fR after the overwrite occurred, rather than when the
specific memory with the overwritten guard zone(s) is freed, which may
occur long after the overwrite occurred.
.SH "SEE ALSO"
ckalloc, ckfree, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory, TCL_MEM_DEBUG
.SH KEYWORDS
memory, debug
tcl8.4.20/doc/DetachPids.3 0000644 0036047 0045461 00000005766 11737050674 013576 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_DetachPids 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_DetachPids, Tcl_ReapDetachedProcs, Tcl_WaitPid \- manage child processes in background
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_DetachPids\fR(\fInumPids, pidPtr\fR)
.sp
\fBTcl_ReapDetachedProcs\fR()
.sp
Tcl_Pid
\fBTcl_WaitPid\fR(\fIpid, statPtr, options\fR)
.SH ARGUMENTS
.AS int *statusPtr
.AP int numPids in
Number of process ids contained in the array pointed to by \fIpidPtr\fR.
.AP int *pidPtr in
Address of array containing \fInumPids\fR process ids.
.AP Tcl_Pid pid in
The id of the process (pipe) to wait for.
.AP int* statPtr out
The result of waiting on a process (pipe). Either 0 or ECHILD.
.AP int options
The options controlling the wait. WNOHANG specifies not to wait when
checking the process.
.BE
.SH DESCRIPTION
.PP
\fBTcl_DetachPids\fR and \fBTcl_ReapDetachedProcs\fR provide a
mechanism for managing subprocesses that are running in background.
These procedures are needed because the parent of a process must
eventually invoke the \fBwaitpid\fR kernel call (or one of a few other
similar kernel calls) to wait for the child to exit. Until the
parent waits for the child, the child's state cannot be completely
reclaimed by the system. If a parent continually creates children
and doesn't wait on them, the system's process table will eventually
overflow, even if all the children have exited.
.PP
\fBTcl_DetachPids\fR may be called to ask Tcl to take responsibility
for one or more processes whose process ids are contained in the
\fIpidPtr\fR array passed as argument. The caller presumably
has started these processes running in background and doesn't
want to have to deal with them again.
.PP
\fBTcl_ReapDetachedProcs\fR invokes the \fBwaitpid\fR kernel call
on each of the background processes so that its state can be cleaned
up if it has exited. If the process hasn't exited yet,
\fBTcl_ReapDetachedProcs\fR doesn't wait for it to exit; it will check again
the next time it is invoked.
Tcl automatically calls \fBTcl_ReapDetachedProcs\fR each time the
\fBexec\fR command is executed, so in most cases it isn't necessary
for any code outside of Tcl to invoke \fBTcl_ReapDetachedProcs\fR.
However, if you call \fBTcl_DetachPids\fR in situations where the
\fBexec\fR command may never get executed, you may wish to call
\fBTcl_ReapDetachedProcs\fR from time to time so that background
processes can be cleaned up.
.PP
\fBTcl_WaitPid\fR is a thin wrapper around the facilities provided by
the operating system to wait on the end of a spawned process and to
check a whether spawned process is still running. It is used by
\fBTcl_ReapDetachedProcs\fR and the channel system to portably access
the operating system.
.SH KEYWORDS
background, child, detach, process, wait
tcl8.4.20/doc/Signal.3 0000644 0036047 0045461 00000001733 11737050674 012771 0 ustar dgp 771div '\"
'\" Copyright (c) 2001 ActiveState Tool Corp.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_SignalId 3 8.3 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SignalId, Tcl_SignalMsg \- Convert signal codes
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
CONST char *
\fBTcl_SignalId\fR(\fIsig\fR)
.sp
CONST char *
\fBTcl_SignalMsg\fR(\fIsig\fR)
.sp
.SH ARGUMENTS
.AP int sig in
A POSIX signal number such as \fBSIGPIPE\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_SignalId\fR and \fBTcl_SignalMsg\fR return a string
representation of the provided signal number (\fIsig\fR).
\fBTcl_SignalId\fR returns a machine-readable textual identifier such
as "SIGPIPE". \fBTcl_SignalMsg\fR returns a human-readable string such
as "bus error". The strings returned by these functions are
statically allocated and the caller must not free or modify them.
.SH KEYWORDS
signals, signal numbers
tcl8.4.20/doc/namespace.n 0000644 0036047 0045461 00000055343 11737050674 013611 0 ustar dgp 771div '\"
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH namespace n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
namespace \- create and manipulate contexts for commands and variables
.SH SYNOPSIS
\fBnamespace \fR?\fIoption\fR? ?\fIarg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBnamespace\fR command lets you create, access, and destroy
separate contexts for commands and variables.
See the section \fBWHAT IS A NAMESPACE?\fR below
for a brief overview of namespaces.
The legal values of \fIoption\fR are listed below.
Note that you can abbreviate the \fIoption\fRs.
.TP
\fBnamespace children \fR?\fInamespace\fR? ?\fIpattern\fR?
Returns a list of all child namespaces that belong to the
namespace \fInamespace\fR.
If \fInamespace\fR is not specified,
then the children are returned for the current namespace.
This command returns fully-qualified names,
which start with a double colon (\fB::\fR).
If the optional \fIpattern\fR is given,
then this command returns only the names that match the glob-style pattern.
The actual pattern used is determined as follows:
a pattern that starts with double colon (\fB::\fR) is used directly,
otherwise the namespace \fInamespace\fR
(or the fully-qualified name of the current namespace)
is prepended onto the pattern.
.TP
\fBnamespace code \fIscript\fR
Captures the current namespace context for later execution
of the script \fIscript\fR.
It returns a new script in which \fIscript\fR has been wrapped
in a \fBnamespace inscope\fR command.
The new script has two important properties.
First, it can be evaluated in any namespace and will cause
\fIscript\fR to be evaluated in the current namespace
(the one where the \fBnamespace code\fR command was invoked).
Second, additional arguments can be appended to the resulting script
and they will be passed to \fIscript\fR as additional arguments.
For example, suppose the command
\fBset script [namespace code {foo bar}]\fR
is invoked in namespace \fB::a::b\fR.
Then \fBeval "$script x y"\fR
can be executed in any namespace (assuming the value of
\fBscript\fR has been passed in properly)
and will have the same effect as the command
\fB::namespace eval ::a::b {foo bar x y}\fR.
This command is needed because
extensions like Tk normally execute callback scripts
in the global namespace.
A scoped command captures a command together with its namespace context
in a way that allows it to be executed properly later.
See the section \fBSCOPED SCRIPTS\fR for some examples
of how this is used to create callback scripts.
.TP
\fBnamespace current\fR
Returns the fully-qualified name for the current namespace.
The actual name of the global namespace is ``''
(i.e., an empty string),
but this command returns \fB::\fR for the global namespace
as a convenience to programmers.
.TP
\fBnamespace delete \fR?\fInamespace namespace ...\fR?
Each namespace \fInamespace\fR is deleted
and all variables, procedures, and child namespaces
contained in the namespace are deleted.
If a procedure is currently executing inside the namespace,
the namespace will be kept alive until the procedure returns;
however, the namespace is marked to prevent other code from
looking it up by name.
If a namespace doesn't exist, this command returns an error.
If no namespace names are given, this command does nothing.
.TP
\fBnamespace eval\fR \fInamespace arg\fR ?\fIarg ...\fR?
Activates a namespace called \fInamespace\fR and evaluates some code
in that context.
If the namespace does not already exist, it is created.
If more than one \fIarg\fR argument is specified,
the arguments are concatenated together with a space between each one
in the same fashion as the \fBeval\fR command,
and the result is evaluated.
.br
.sp
If \fInamespace\fR has leading namespace qualifiers
and any leading namespaces do not exist,
they are automatically created.
.TP
\fBnamespace exists\fR \fInamespace\fR
Returns \fB1\fR if \fInamespace\fR is a valid namespace in the current
context, returns \fB0\fR otherwise.
.TP
\fBnamespace export \fR?\-\fBclear\fR? ?\fIpattern pattern ...\fR?
Specifies which commands are exported from a namespace.
The exported commands are those that can be later imported
into another namespace using a \fBnamespace import\fR command.
Both commands defined in a namespace and
commands the namespace has previously imported
can be exported by a namespace.
The commands do not have to be defined
at the time the \fBnamespace export\fR command is executed.
Each \fIpattern\fR may contain glob-style special characters,
but it may not include any namespace qualifiers.
That is, the pattern can only specify commands
in the current (exporting) namespace.
Each \fIpattern\fR is appended onto the namespace's list of export patterns.
If the \-\fBclear\fR flag is given,
the namespace's export pattern list is reset to empty before any
\fIpattern\fR arguments are appended.
If no \fIpattern\fRs are given and the \-\fBclear\fR flag isn't given,
this command returns the namespace's current export list.
.TP
\fBnamespace forget \fR?\fIpattern pattern ...\fR?
Removes previously imported commands from a namespace.
Each \fIpattern\fR is a simple or qualified name such as
\fBx\fR, \fBfoo::x\fR or \fBa::b::p*\fR.
Qualified names contain double colons (\fB::\fR) and qualify a name
with the name of one or more namespaces.
Each \fIqualified pattern\fR is qualified with the name of an
exporting namespace
and may have glob-style special characters in the command name
at the end of the qualified name.
Glob characters may not appear in a namespace name.
For each \fIsimple pattern\fR this command deletes the matching
commands of the
current namespace that were imported from a different namespace.
For \fIqualified patterns\fR, this command first finds the matching
exported commands.
It then checks whether any of those commands
were previously imported by the current namespace.
If so, this command deletes the corresponding imported commands.
In effect, this un-does the action of a \fBnamespace import\fR command.
.TP
\fBnamespace import \fR?\fB\-force\fR? ?\fIpattern\fR \fIpattern ...\fR?
Imports commands into a namespace.
Each \fIpattern\fR is a qualified name like
\fBfoo::x\fR or \fBa::p*\fR.
That is, it includes the name of an exporting namespace
and may have glob-style special characters in the command name
at the end of the qualified name.
Glob characters may not appear in a namespace name.
All the commands that match a \fIpattern\fR string
and which are currently exported from their namespace
are added to the current namespace.
This is done by creating a new command in the current namespace
that points to the exported command in its original namespace;
when the new imported command is called, it invokes the exported command.
This command normally returns an error
if an imported command conflicts with an existing command.
However, if the \-\fBforce\fR option is given,
imported commands will silently replace existing commands.
The \fBnamespace import\fR command has snapshot semantics:
that is, only requested commands that are currently defined
in the exporting namespace are imported.
In other words, you can import only the commands that are in a namespace
at the time when the \fBnamespace import\fR command is executed.
If another command is defined and exported in this namespace later on,
it will not be imported.
.TP
\fBnamespace inscope\fR \fInamespace\fR \fIscript\fR ?\fIarg ...\fR?
Executes a script in the context of the specified \fInamespace\fR.
This command is not expected to be used directly by programmers;
calls to it are generated implicitly when applications
use \fBnamespace code\fR commands to create callback scripts
that the applications then register with, e.g., Tk widgets.
The \fBnamespace inscope\fR command is much like the \fBnamespace eval\fR
command except that the \fInamespace\fR must already exist,
and \fBnamespace inscope\fR appends additional \fIarg\fRs
as proper list elements.
.br
\fBnamespace inscope ::foo $script $x $y $z\fR
is equivalent to
\fBnamespace eval ::foo [concat $script [list $x $y $z]]\fR
thus additional arguments will not undergo a second round of substitution,
as is the case with \fBnamespace eval\fR.
.TP
\fBnamespace origin \fIcommand\fR
Returns the fully-qualified name of the original command
to which the imported command \fIcommand\fR refers.
When a command is imported into a namespace,
a new command is created in that namespace
that points to the actual command in the exporting namespace.
If a command is imported into a sequence of namespaces
\fIa, b,...,n\fR where each successive namespace
just imports the command from the previous namespace,
this command returns the fully-qualified name of the original command
in the first namespace, \fIa\fR.
If \fIcommand\fR does not refer to an imported command,
the command's own fully-qualified name is returned.
.TP
\fBnamespace parent\fR ?\fInamespace\fR?
Returns the fully-qualified name of the parent namespace
for namespace \fInamespace\fR.
If \fInamespace\fR is not specified,
the fully-qualified name of the current namespace's parent is returned.
.TP
\fBnamespace qualifiers\fR \fIstring\fR
Returns any leading namespace qualifiers for \fIstring\fR.
Qualifiers are namespace names separated by double colons (\fB::\fR).
For the \fIstring\fR \fB::foo::bar::x\fR,
this command returns \fB::foo::bar\fR,
and for \fB::\fR it returns an empty string.
This command is the complement of the \fBnamespace tail\fR command.
Note that it does not check whether the
namespace names are, in fact,
the names of currently defined namespaces.
.TP
\fBnamespace tail\fR \fIstring\fR
Returns the simple name at the end of a qualified string.
Qualifiers are namespace names separated by double colons (\fB::\fR).
For the \fIstring\fR \fB::foo::bar::x\fR,
this command returns \fBx\fR,
and for \fB::\fR it returns an empty string.
This command is the complement of the \fBnamespace qualifiers\fR command.
It does not check whether the namespace names are, in fact,
the names of currently defined namespaces.
.TP
\fBnamespace which\fR ?\-\fBcommand\fR? ?\-\fBvariable\fR? \fIname\fR
Looks up \fIname\fR as either a command or variable
and returns its fully-qualified name.
For example, if \fIname\fR does not exist in the current namespace
but does exist in the global namespace,
this command returns a fully-qualified name in the global namespace.
If the command or variable does not exist,
this command returns an empty string. If the variable has been
created but not defined, such as with the \fBvariable\fR command
or through a \fBtrace\fR on the variable, this command will return the
fully-qualified name of the variable.
If no flag is given, \fIname\fR is treated as a command name.
See the section \fBNAME RESOLUTION\fR below for an explanation of
the rules regarding name resolution.
.SH "WHAT IS A NAMESPACE?"
.PP
A namespace is a collection of commands and variables.
It encapsulates the commands and variables to ensure that they
won't interfere with the commands and variables of other namespaces.
Tcl has always had one such collection,
which we refer to as the \fIglobal namespace\fR.
The global namespace holds all global variables and commands.
The \fBnamespace eval\fR command lets you create new namespaces.
For example,
.CS
\fBnamespace eval\fR Counter {
\fBnamespace export\fR bump
variable num 0
proc bump {} {
variable num
incr num
}
}
.CE
creates a new namespace containing the variable \fBnum\fR and
the procedure \fBbump\fR.
The commands and variables in this namespace are separate from
other commands and variables in the same program.
If there is a command named \fBbump\fR in the global namespace,
for example, it will be different from the command \fBbump\fR
in the \fBCounter\fR namespace.
.PP
Namespace variables resemble global variables in Tcl.
They exist outside of the procedures in a namespace
but can be accessed in a procedure via the \fBvariable\fR command,
as shown in the example above.
.PP
Namespaces are dynamic.
You can add and delete commands and variables at any time,
so you can build up the contents of a
namespace over time using a series of \fBnamespace eval\fR commands.
For example, the following series of commands has the same effect
as the namespace definition shown above:
.CS
\fBnamespace eval\fR Counter {
variable num 0
proc bump {} {
variable num
return [incr num]
}
}
\fBnamespace eval\fR Counter {
proc test {args} {
return $args
}
}
\fBnamespace eval\fR Counter {
rename test ""
}
.CE
Note that the \fBtest\fR procedure is added to the \fBCounter\fR namespace,
and later removed via the \fBrename\fR command.
.PP
Namespaces can have other namespaces within them,
so they nest hierarchically.
A nested namespace is encapsulated inside its parent namespace
and can not interfere with other namespaces.
.SH "QUALIFIED NAMES"
.PP
Each namespace has a textual name such as
\fBhistory\fR or \fB::safe::interp\fR.
Since namespaces may nest,
qualified names are used to refer to
commands, variables, and child namespaces contained inside namespaces.
Qualified names are similar to the hierarchical path names for
Unix files or Tk widgets,
except that \fB::\fR is used as the separator
instead of \fB/\fR or \fB.\fR.
The topmost or global namespace has the name ``'' (i.e., an empty string),
although \fB::\fR is a synonym.
As an example, the name \fB::safe::interp::create\fR
refers to the command \fBcreate\fR in the namespace \fBinterp\fR
that is a child of namespace \fB::safe\fR,
which in turn is a child of the global namespace, \fB::\fR.
.PP
If you want to access commands and variables from another namespace,
you must use some extra syntax.
Names must be qualified by the namespace that contains them.
From the global namespace,
we might access the \fBCounter\fR procedures like this:
.CS
Counter::bump 5
Counter::Reset
.CE
We could access the current count like this:
.CS
puts "count = $Counter::num"
.CE
When one namespace contains another, you may need more than one
qualifier to reach its elements.
If we had a namespace \fBFoo\fR that contained the namespace \fBCounter\fR,
you could invoke its \fBbump\fR procedure
from the global namespace like this:
.CS
Foo::Counter::bump 3
.CE
.PP
You can also use qualified names when you create and rename commands.
For example, you could add a procedure to the \fBFoo\fR
namespace like this:
.CS
proc Foo::Test {args} {return $args}
.CE
And you could move the same procedure to another namespace like this:
.CS
rename Foo::Test Bar::Test
.CE
.PP
There are a few remaining points about qualified names
that we should cover.
Namespaces have nonempty names except for the global namespace.
\fB::\fR is disallowed in simple command, variable, and namespace names
except as a namespace separator.
Extra colons in any separator part of a qualified name are ignored;
i.e. two or more colons are treated as a namespace separator.
A trailing \fB::\fR in a qualified variable or command name
refers to the variable or command named {}.
However, a trailing \fB::\fR in a qualified namespace name is ignored.
.SH "NAME RESOLUTION"
.PP
In general, all Tcl commands that take variable and command names
support qualified names.
This means you can give qualified names to such commands as
\fBset\fR, \fBproc\fR, \fBrename\fR, and \fBinterp alias\fR.
If you provide a fully-qualified name that starts with a \fB::\fR,
there is no question about what command, variable, or namespace
you mean.
However, if the name does not start with a \fB::\fR
(i.e., is \fIrelative\fR),
Tcl follows a fixed rule for looking it up:
Command and variable names are always resolved
by looking first in the current namespace,
and then in the global namespace.
Namespace names, on the other hand, are always resolved
by looking in only the current namespace.
.PP
In the following example,
.CS
set traceLevel 0
\fBnamespace eval\fR Debug {
printTrace $traceLevel
}
.CE
Tcl looks for \fBtraceLevel\fR in the namespace \fBDebug\fR
and then in the global namespace.
It looks up the command \fBprintTrace\fR in the same way.
If a variable or command name is not found in either context,
the name is undefined.
To make this point absolutely clear, consider the following example:
.CS
set traceLevel 0
\fBnamespace eval\fR Foo {
variable traceLevel 3
\fBnamespace eval\fR Debug {
printTrace $traceLevel
}
}
.CE
Here Tcl looks for \fBtraceLevel\fR first in the namespace \fBFoo::Debug\fR.
Since it is not found there, Tcl then looks for it
in the global namespace.
The variable \fBFoo::traceLevel\fR is completely ignored
during the name resolution process.
.PP
You can use the \fBnamespace which\fR command to clear up any question
about name resolution.
For example, the command:
.CS
\fBnamespace eval\fR Foo::Debug {\fBnamespace which\fR \-variable traceLevel}
.CE
returns \fB::traceLevel\fR.
On the other hand, the command,
.CS
\fBnamespace eval\fR Foo {\fBnamespace which\fR \-variable traceLevel}
.CE
returns \fB::Foo::traceLevel\fR.
.PP
As mentioned above,
namespace names are looked up differently
than the names of variables and commands.
Namespace names are always resolved in the current namespace.
This means, for example,
that a \fBnamespace eval\fR command that creates a new namespace
always creates a child of the current namespace
unless the new namespace name begins with \fB::\fR.
.PP
Tcl has no access control to limit what variables, commands,
or namespaces you can reference.
If you provide a qualified name that resolves to an element
by the name resolution rule above,
you can access the element.
.PP
You can access a namespace variable
from a procedure in the same namespace
by using the \fBvariable\fR command.
Much like the \fBglobal\fR command,
this creates a local link to the namespace variable.
If necessary, it also creates the variable in the current namespace
and initializes it.
Note that the \fBglobal\fR command only creates links
to variables in the global namespace.
It is not necessary to use a \fBvariable\fR command
if you always refer to the namespace variable using an
appropriate qualified name.
.SH "IMPORTING COMMANDS"
.PP
Namespaces are often used to represent libraries.
Some library commands are used so frequently
that it is a nuisance to type their qualified names.
For example, suppose that all of the commands in a package
like BLT are contained in a namespace called \fBBlt\fR.
Then you might access these commands like this:
.CS
Blt::graph .g \-background red
Blt::table . .g 0,0
.CE
If you use the \fBgraph\fR and \fBtable\fR commands frequently,
you may want to access them without the \fBBlt::\fR prefix.
You can do this by importing the commands into the current namespace,
like this:
.CS
\fBnamespace import\fR Blt::*
.CE
This adds all exported commands from the \fBBlt\fR namespace
into the current namespace context, so you can write code like this:
.CS
graph .g \-background red
table . .g 0,0
.CE
The \fBnamespace import\fR command only imports commands
from a namespace that that namespace exported
with a \fBnamespace export\fR command.
.PP
Importing \fIevery\fR command from a namespace is generally
a bad idea since you don't know what you will get.
It is better to import just the specific commands you need.
For example, the command
.CS
\fBnamespace import\fR Blt::graph Blt::table
.CE
imports only the \fBgraph\fR and \fBtable\fR commands into the
current context.
.PP
If you try to import a command that already exists, you will get an
error. This prevents you from importing the same command from two
different packages. But from time to time (perhaps when debugging),
you may want to get around this restriction. You may want to
reissue the \fBnamespace import\fR command to pick up new commands
that have appeared in a namespace. In that case, you can use the
\fB\-force\fR option, and existing commands will be silently overwritten:
.CS
\fBnamespace import\fR \-force Blt::graph Blt::table
.CE
If for some reason, you want to stop using the imported commands,
you can remove them with a \fBnamespace forget\fR command, like this:
.CS
\fBnamespace forget\fR Blt::*
.CE
This searches the current namespace for any commands imported from \fBBlt\fR.
If it finds any, it removes them. Otherwise, it does nothing.
After this, the \fBBlt\fR commands must be accessed with the \fBBlt::\fR
prefix.
.PP
When you delete a command from the exporting namespace like this:
.CS
rename Blt::graph ""
.CE
the command is automatically removed from all namespaces that import it.
.SH "EXPORTING COMMANDS"
You can export commands from a namespace like this:
.CS
\fBnamespace eval\fR Counter {
\fBnamespace export\fR bump reset
variable Num 0
variable Max 100
proc bump {{by 1}} {
variable Num
incr Num $by
Check
return $Num
}
proc reset {} {
variable Num
set Num 0
}
proc Check {} {
variable Num
variable Max
if {$Num > $Max} {
error "too high!"
}
}
}
.CE
The procedures \fBbump\fR and \fBreset\fR are exported,
so they are included when you import from the \fBCounter\fR namespace,
like this:
.CS
\fBnamespace import\fR Counter::*
.CE
However, the \fBCheck\fR procedure is not exported,
so it is ignored by the import operation.
.PP
The \fBnamespace import\fR command only imports commands
that were declared as exported by their namespace.
The \fBnamespace export\fR command specifies what commands
may be imported by other namespaces.
If a \fBnamespace import\fR command specifies a command
that is not exported, the command is not imported.
.SH "SCOPED SCRIPTS"
The \fBnamespace code\fR command is the means by which a script may be
packaged for evaluation in a namespace other than the one in which it
was created. It is used most often to create event handlers, Tk bindings,
and traces for evaluation in the global context. For instance, the following
code indicates how to direct a variable trace callback into the current
namespace:
.CS
\fBnamespace eval\fR a {
variable b
proc theTraceCallback { n1 n2 op } {
upvar 1 $n1 var
puts "the value of $n1 has changed to $var"
return
}
trace variable b w [\fBnamespace code\fR theTraceCallback]
}
set a::b c
.CE
When executed, it prints the message:
.CS
the value of a::b has changed to c
.CE
.SH EXAMPLES
Create a namespace containing a variable and an exported command:
.CS
\fBnamespace eval\fR foo {
variable bar 0
proc grill {} {
variable bar
puts "called [incr bar] times"
}
\fBnamespace export\fR grill
}
.CE
.PP
Call the command defined in the previous example in various ways.
.CS
# Direct call
foo::grill
# Import into current namespace, then call local alias
namespace import foo::grill
grill
.CE
.PP
Look up where the command imported in the previous example came from:
.CS
puts "grill came from [\fBnamespace origin\fR grill]"
.CE
.SH "SEE ALSO"
variable(n)
.SH KEYWORDS
exported, internal, variable
tcl8.4.20/doc/tclvars.n 0000644 0036047 0045461 00000037047 12052456743 013332 0 ustar dgp 771div '\"
'\" Copyright (c) 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.
'\"
.so man.macros
.TH tclvars n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
tclvars \- Variables used by Tcl
.BE
.SH DESCRIPTION
.PP
The following global variables are created and managed automatically
by the Tcl library. Except where noted below, these variables should
normally be treated as read-only by application-specific code and by users.
.TP
\fBenv\fR
This variable is maintained by Tcl as an array
whose elements are the environment variables for the process.
Reading an element will return the value of the corresponding
environment variable.
Setting an element of the array will modify the corresponding
environment variable or create a new one if it doesn't already
exist.
Unsetting an element of \fBenv\fR will remove the corresponding
environment variable.
Changes to the \fBenv\fR array will affect the environment
passed to children by commands like \fBexec\fR.
If the entire \fBenv\fR array is unset then Tcl will stop
monitoring \fBenv\fR accesses and will not update environment
variables.
.RS
.VS 8.0
Under Windows, the environment variables PATH and COMSPEC in any
capitalization are converted automatically to upper case. For instance, the
PATH variable could be exported by the operating system as ``path'',
``Path'', ``PaTh'', etc., causing otherwise simple Tcl code to have to
support many special cases. All other environment variables inherited by
Tcl are left unmodified. Setting an env array variable to blank is the
same as unsetting it as this is the behavior of the underlying Windows OS.
It should be noted that relying on an existing and empty environment variable
won't work on windows and is discouraged for cross-platform usage.
.RE
.TP
\fBerrorCode\fR
After an error has occurred, this variable will be set to hold
a list value representing additional information about the error
in a form that is easy to process with programs.
The first element of the list identifies a general class of
errors, and determines the format of the rest of the list.
The following formats for \fBerrorCode\fR are used by the
Tcl core; individual applications may define additional formats.
.RS
.TP
\fBARITH\fI code msg\fR
This format is used when an arithmetic error occurs (e.g. an attempt
to divide by zero in the \fBexpr\fR command).
\fICode\fR identifies the precise error and \fImsg\fR provides a
human-readable description of the error. \fICode\fR will be either
DIVZERO (for an attempt to divide by zero),
DOMAIN (if an argument is outside the domain of a function, such as acos(\-3)),
IOVERFLOW (for integer overflow),
OVERFLOW (for a floating-point overflow),
or UNKNOWN (if the cause of the error cannot be determined).
.TP
\fBCHILDKILLED\fI pid sigName msg\fR
This format is used when a child process has been killed because of
a signal. The second element of \fBerrorCode\fR will be the
process's identifier (in decimal).
The third element will be the symbolic name of the signal that caused
the process to terminate; it will be one of the names from the
include file signal.h, such as \fBSIGPIPE\fR.
The fourth element will be a short human-readable message
describing the signal, such as ``write on pipe with no readers''
for \fBSIGPIPE\fR.
.TP
\fBCHILDSTATUS\fI pid code\fR
This format is used when a child process has exited with a non-zero
exit status. The second element of \fBerrorCode\fR will be the
process's identifier (in decimal) and the third element will be the exit
code returned by the process (also in decimal).
.TP
\fBCHILDSUSP\fI pid sigName msg\fR
This format is used when a child process has been suspended because
of a signal.
The second element of \fBerrorCode\fR will be the process's identifier,
in decimal.
The third element will be the symbolic name of the signal that caused
the process to suspend; this will be one of the names from the
include file signal.h, such as \fBSIGTTIN\fR.
The fourth element will be a short human-readable message
describing the signal, such as ``background tty read''
for \fBSIGTTIN\fR.
.TP
\fBNONE\fR
This format is used for errors where no additional information is
available for an error besides the message returned with the
error. In these cases \fBerrorCode\fR will consist of a list
containing a single element whose contents are \fBNONE\fR.
.TP
\fBPOSIX \fIerrName msg\fR
If the first element of \fBerrorCode\fR is \fBPOSIX\fR, then
the error occurred during a POSIX kernel call.
The second element of the list will contain the symbolic name
of the error that occurred, such as \fBENOENT\fR; this will
be one of the values defined in the include file errno.h.
The third element of the list will be a human-readable
message corresponding to \fIerrName\fR, such as
``no such file or directory'' for the \fBENOENT\fR case.
.PP
To set \fBerrorCode\fR, applications should use library
procedures such as \fBTcl_SetErrorCode\fR and \fBTcl_PosixError\fR,
or they may invoke the \fBerror\fR command.
If one of these methods hasn't been used, then the Tcl
interpreter will reset the variable to \fBNONE\fR after
the next error.
.RE
.TP
\fBerrorInfo\fR
After an error has occurred, this string will contain one or more lines
identifying the Tcl commands and procedures that were being executed
when the most recent error occurred.
Its contents take the form of a stack trace showing the various
nested Tcl commands that had been invoked at the time of the error.
.TP
\fBtcl_library\fR
This variable holds the name of a directory containing the
system library of Tcl scripts, such as those used for auto-loading.
The value of this variable is returned by the \fBinfo library\fR command.
See the \fBlibrary\fR manual entry for details of the facilities
provided by the Tcl script library.
Normally each application or package will have its own application-specific
script library in addition to the Tcl script library;
each application should set a global variable with a name like
\fB$\fIapp\fB_library\fR (where \fIapp\fR is the application's name)
to hold the network file name for that application's library directory.
The initial value of \fBtcl_library\fR is set when an interpreter
is created by searching several different directories until one is
found that contains an appropriate Tcl startup script.
If the \fBTCL_LIBRARY\fR environment variable exists, then
the directory it names is checked first.
If \fBTCL_LIBRARY\fR isn't set or doesn't refer to an appropriate
directory, then Tcl checks several other directories based on a
compiled-in default location, the location of the binary containing
the application, and the current working directory.
.TP
\fBtcl_patchLevel\fR
When an interpreter is created Tcl initializes this variable to
hold a string giving the current patch level for Tcl, such as
\fB7.3p2\fR for Tcl 7.3 with the first two official patches, or
\fB7.4b4\fR for the fourth beta release of Tcl 7.4.
The value of this variable is returned by the \fBinfo patchlevel\fR
command.
.VS 8.0 br
.TP
\fBtcl_pkgPath\fR
This variable holds a list of directories indicating where packages are
normally installed. It is not used on Windows. It typically contains
either one or two entries; if it contains two entries, the first is
normally a directory for platform-dependent packages (e.g., shared library
binaries) and the second is normally a directory for platform-independent
packages (e.g., script files). Typically a package is installed as a
subdirectory of one of the entries in \fB$tcl_pkgPath\fR. The directories
in \fB$tcl_pkgPath\fR are included by default in the \fBauto_path\fR
variable, so they and their immediate subdirectories are automatically
searched for packages during \fBpackage require\fR commands. Note:
\fBtcl_pkgPath\fR it not intended to be modified by the application. Its
value is added to \fBauto_path\fR at startup; changes to \fBtcl_pkgPath\fR
are not reflected in \fBauto_path\fR. If you want Tcl to search additional
directories for packages you should add the names of those directories to
\fBauto_path\fR, not \fBtcl_pkgPath\fR.
.VE
.TP
\fBtcl_platform\fR
This is an associative array whose elements contain information about
the platform on which the application is running, such as the name of
the operating system, its current release number, and the machine's
instruction set. The elements listed below will always
be defined, but they may have empty strings as values if Tcl couldn't
retrieve any relevant information. In addition, extensions
and applications may add additional values to the array. The
predefined elements are:
.RS
.VS
.TP
\fBbyteOrder\fR
The native byte order of this machine: either \fBlittleEndian\fR or
\fBbigEndian\fR.
.VE
.TP
\fBdebug\fR
If this variable exists, then the interpreter was compiled with and linked
to a debug-enabled C run-time. This variable will only exist on Windows,
so extension writers can specify which package to load depending on the
C run-time library that is in use. This is not an indication that this core
contains symbols.
.TP
\fBmachine\fR
The instruction set executed by this machine, such as
\fBintel\fR, \fBPPC\fR, \fB68k\fR, or \fBsun4m\fR. On UNIX machines, this
is the value returned by \fBuname -m\fR.
.TP
\fBos\fR
The name of the operating system running on this machine,
such as \fBWindows 95\fR, \fBWindows NT\fR, \fBMacOS\fR, or \fBSunOS\fR.
On UNIX machines, this is the value returned by \fBuname -s\fR.
On Windows 95 and Windows 98, the value returned will be \fBWindows
95\fR to provide better backwards compatibility to Windows 95; to
distinguish between the two, check the \fBosVersion\fR.
.TP
\fBosVersion\fR
The version number for the operating system running on this machine.
On UNIX machines, this is the value returned by \fBuname -r\fR. On
Windows 95, the version will be 4.0; on Windows 98, the version will
be 4.10.
.TP
\fBplatform\fR
Either \fBwindows\fR or \fBunix\fR. This identifies the
general operating environment of the machine.
.TP
\fBthreaded\fR
If this variable exists, then the interpreter
was compiled with threads enabled.
.TP
\fBuser\fR
This identifies the
current user based on the login information available on the platform.
This comes from the USER or LOGNAME environment variable on Unix,
and the value from GetUserName on Windows.
.TP
\fBwordSize\fR
.VS 8.4
This gives the size of the native-machine word in bytes (strictly, it
is same as the result of evaluating \fIsizeof(long)\fR in C.)
.VE 8.4
.RE
.TP
\fBtcl_precision\fR
.VS
This variable controls the number of digits to generate
when converting floating-point values to strings. It defaults
to 12.
17 digits is ``perfect'' for IEEE floating-point in that it allows
double-precision values to be converted to strings and back to
binary with no loss of information. However, using 17 digits prevents
any rounding, which produces longer, less intuitive results. For example,
\fBexpr 1.4\fR returns 1.3999999999999999 with \fBtcl_precision\fR
set to 17, vs. 1.4 if \fBtcl_precision\fR is 12.
.RS
All interpreters in a process share a single \fBtcl_precision\fR value:
changing it in one interpreter will affect all other interpreters as
well. However, safe interpreters are not allowed to modify the
variable.
.RE
.VE
.TP
\fBtcl_rcFileName\fR
This variable is used during initialization to indicate the name of a
user-specific startup file. If it is set by application-specific
initialization, then the Tcl startup code will check for the existence
of this file and \fBsource\fR it if it exists. For example, for \fBwish\fR
the variable is set to \fB~/.wishrc\fR for Unix and \fB~/wishrc.tcl\fR
for Windows.
.TP
\fBtcl_traceCompile\fR
The value of this variable can be set to control
how much tracing information
is displayed during bytecode compilation.
By default, tcl_traceCompile is zero and no information is displayed.
Setting tcl_traceCompile to 1 generates a one-line summary in stdout
whenever a procedure or top-level command is compiled.
Setting it to 2 generates a detailed listing in stdout of the
bytecode instructions emitted during every compilation.
This variable is useful in
tracking down suspected problems with the Tcl compiler.
It is also occasionally useful when converting
existing code to use Tcl8.0.
.PP
This variable and functionality only exist if
\fBTCL_COMPILE_DEBUG\fR was defined during Tcl's compilation.
.TP
\fBtcl_traceExec\fR
The value of this variable can be set to control
how much tracing information
is displayed during bytecode execution.
By default, tcl_traceExec is zero and no information is displayed.
Setting tcl_traceExec to 1 generates a one-line trace in stdout
on each call to a Tcl procedure.
Setting it to 2 generates a line of output
whenever any Tcl command is invoked
that contains the name of the command and its arguments.
Setting it to 3 produces a detailed trace showing the result of
executing each bytecode instruction.
Note that when tcl_traceExec is 2 or 3,
commands such as \fBset\fR and \fBincr\fR
that have been entirely replaced by a sequence
of bytecode instructions are not shown.
Setting this variable is useful in
tracking down suspected problems with the bytecode compiler
and interpreter.
It is also occasionally useful when converting
code to use Tcl8.0.
.PP
This variable and functionality only exist if
\fBTCL_COMPILE_DEBUG\fR was defined during Tcl's compilation.
.TP
\fBtcl_wordchars\fR
The value of this variable is a regular expression that can be set to
control what are considered ``word'' characters, for instances like
selecting a word by double-clicking in text in Tk. It is platform
dependent. On Windows, it defaults to \fB\\S\fR, meaning anything
but a Unicode space character. Otherwise it defaults to \fB\\w\fR,
which is any Unicode word character (number, letter, or underscore).
.TP
\fBtcl_nonwordchars\fR
The value of this variable is a regular expression that can be set to
control what are considered ``non-word'' characters, for instances like
selecting a word by double-clicking in text in Tk. It is platform
dependent. On Windows, it defaults to \fB\\s\fR, meaning any Unicode space
character. Otherwise it defaults to \fB\\W\fR, which is anything but a
Unicode word character (number, letter, or underscore).
.TP
\fBtcl_version\fR
When an interpreter is created Tcl initializes this variable to
hold the version number for this version of Tcl in the form \fIx.y\fR.
Changes to \fIx\fR represent major changes with probable
incompatibilities and changes to \fIy\fR represent small enhancements and
bug fixes that retain backward compatibility.
The value of this variable is returned by the \fBinfo tclversion\fR
command.
.SH "OTHER GLOBAL VARIABLES"
The following variables are only guaranteed to exist in \fBtclsh\fR
and \fBwish\fR executables; the Tcl library does not define them
itself but many Tcl environments do.
.TP 6
\fBargc\fR
The number of arguments to \fBtclsh\fR or \fBwish\fR.
.TP 6
\fBargv\fR
Tcl list of arguments to \fBtclsh\fR or \fBwish\fR.
.TP 6
\fBargv0\fR
The script that \fBtclsh\fR or \fBwish\fR started executing (if it was
specified) or otherwise the name by which \fBtclsh\fR or \fBwish\fR
was invoked.
.TP 6
\fBtcl_interactive\fR
Contains 1 if \fBtclsh\fR or \fBwish\fR is running interactively (no
script was specified and standard input is a terminal-like device), 0
otherwise.
.PP
The \fBwish\fR executably additionally specifies the following global
variable:
.TP 6
\fBgeometry\fR
If set, contains the user-supplied geometry specification to use for
the main Tk window.
.SH "SEE ALSO"
eval(n), tclsh(1), wish(1)
.SH KEYWORDS
arithmetic, bytecode, compiler, error, environment, POSIX, precision, subprocess, variables
tcl8.4.20/doc/lsearch.n 0000644 0036047 0045461 00000011662 11737050674 013272 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH lsearch n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
lsearch \- See if a list contains a particular element
.SH SYNOPSIS
\fBlsearch \fR?\fIoptions\fR? \fIlist pattern\fR
.BE
.SH DESCRIPTION
.PP
This command searches the elements of \fIlist\fR to see if one
of them matches \fIpattern\fR. If so, the command returns the index
of the first matching element
.VS 8.4
(unless the options \fB\-all\fR or \fB\-inline\fR are specified.)
.VE 8.4
If not, the command returns \fB\-1\fR. The \fIoption\fR arguments
indicates how the elements of the list are to be matched against
\fIpattern\fR and it must have one of the following values:
.TP
\fB\-all\fR
.VS 8.4
Changes the result to be the list of all matching indices (or all
matching values if \fB\-inline\fR is specified as well.)
.VE 8.4
.TP
\fB\-ascii\fR
The list elements are to be examined as Unicode strings (the name is
for backward-compatability reasons.) This option is only meaningful
when used with \fB\-exact\fR or \fB\-sorted\fR.
.TP
\fB\-decreasing\fR
The list elements are sorted in decreasing order. This option is only
meaningful when used with \fB\-sorted\fR.
.TP
\fB\-dictionary\fR
The list elements are to be compared using dictionary-style
comparisons (see \fBlsort\fR for a fuller description). This option
is only meaningful when used with \fB\-exact\fR or \fB\-sorted\fR, and
it is only distinguishable from the \fB\-ascii\fR option when
the \fB\-sorted\fR option is given, because values are only
dictionary-equal when exactly equal.
.TP
\fB\-exact\fR
The list element must contain exactly the same string as \fIpattern\fR.
.TP
\fB\-glob\fR
\fIPattern\fR is a glob-style pattern which is matched against each list
element using the same rules as the \fBstring match\fR command.
.TP
\fB\-increasing\fR
The list elements are sorted in increasing order. This option is only
meaningful when used with \fB\-sorted\fR.
.TP
\fB\-inline\fR
.VS 8.4
The matching value is returned instead of its index (or an empty
string if no value matches.) If \fB\-all\fR is also specified, then
the result of the command is the list of all values that matched.
.VE 8.4
.TP
\fB\-integer\fR
The list elements are to be compared as integers. This option is only
meaningful when used with \fB\-exact\fR or \fB\-sorted\fR.
.TP
\fB\-not\fR
.VS 8.4
This negates the sense of the match, returning the index of the first
non-matching value in the list.
.VE 8.4
.TP
\fB\-real\fR
The list elements are to be compared as floating-point values. This
option is only meaningful when used with \fB\-exact\fR or \fB\-sorted\fR.
.TP
\fB\-regexp\fR
\fIPattern\fR is treated as a regular expression and matched against
each list element using the rules described in the \fBre_syntax\fR
reference page.
.TP
\fB\-sorted\fR
The list elements are in sorted order. If this option is specified,
\fBlsearch\fR will use a more efficient searching algorithm to search
\fIlist\fR. If no other options are specified, \fIlist\fR is assumed
to be sorted in increasing order, and to contain ASCII strings. This
option is mutually exclusive with \fB\-glob\fR and \fB\-regexp\fR, and
is treated exactly like \fB-exact\fR when either \fB\-all\fR, or
\fB\-not\fR is specified.
.TP
\fB\-start\fR \fIindex\fR
.VS 8.4
The list is searched starting at position \fIindex\fR. If \fIindex\fR
has the value \fBend\fR, it refers to the last element in the list,
and \fBend\-\fIinteger\fR refers to the last element in the list minus
the specified integer offset.
.VE 8.4
.PP
If \fIoption\fR is omitted then it defaults to \fB\-glob\fR. If more
than one of \fB\-exact\fR, \fB\-glob\fR, \fB\-regexp\fR, and
\fB\-sorted\fR is specified, whichever option is specified last takes
precedence. If more than one of \fB\-ascii\fR, \fB\-dictionary\fR,
\fB\-integer\fR and \fB\-real\fR is specified, the option specified
last takes precedence. If more than one of \fB\-increasing\fR and
\fB\-decreasing\fR is specified, the option specified last takes
precedence.
.VS 8.4
.SH EXAMPLES
.CS
\fBlsearch\fR {a b c d e} c \fI=> 2\fR
\fBlsearch\fR -all {a b c a b c} c \fI=> 2 5\fR
\fBlsearch\fR -inline {a20 b35 c47} b* \fI=> b35\fR
\fBlsearch\fR -inline -not {a20 b35 c47} b* \fI=> a20\fR
\fBlsearch\fR -all -inline -not {a20 b35 c47} b* \fI=> a20 c47\fR
\fBlsearch\fR -all -not {a20 b35 c47} b* \fI=> 0 2\fR
\fBlsearch\fR -start 3 {a b c a b c} c \fI=> 5\fR
.CE
.VE 8.4
.SH "SEE ALSO"
.VS 8.4
foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n),
lset(n), lsort(n), lrange(n), lreplace(n)
.VE
.SH KEYWORDS
list, match, pattern, regular expression, search, string
'\" Local Variables:
'\" mode: nroff
'\" End:
tcl8.4.20/doc/StaticPkg.3 0000644 0036047 0045461 00000005412 11737050674 013443 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH Tcl_StaticPackage 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_StaticPackage \- make a statically linked package available via the \fBload\fR command
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_StaticPackage\fR(\fIinterp, pkgName, initProc, safeInitProc\fR)
.SH ARGUMENTS
.AS Tcl_PackageInitProc *safeInitProc
.AP Tcl_Interp *interp in
If not NULL, points to an interpreter into which the package has
already been loaded (i.e., the caller has already invoked the
appropriate initialization procedure). NULL means the package
hasn't yet been incorporated into any interpreter.
.AP "CONST char" *pkgName in
Name of the package; should be properly capitalized (first letter
upper-case, all others lower-case).
.AP Tcl_PackageInitProc *initProc in
Procedure to invoke to incorporate this package into a trusted
interpreter.
.AP Tcl_PackageInitProc *safeInitProc in
Procedure to call to incorporate this package into a safe interpreter
(one that will execute untrusted scripts). NULL means the package
can't be used in safe interpreters.
.BE
.SH DESCRIPTION
.PP
This procedure may be invoked to announce that a package has been
linked statically with a Tcl application and, optionally, that it
has already been loaded into an interpreter.
Once \fBTcl_StaticPackage\fR has been invoked for a package, it
may be loaded into interpreters using the \fBload\fR command.
\fBTcl_StaticPackage\fR is normally invoked only by the \fBTcl_AppInit\fR
procedure for the application, not by packages for themselves
(\fBTcl_StaticPackage\fR should only be invoked for statically
loaded packages, and code in the package itself should not need
to know whether the package is dynamically or statically loaded).
.PP
When the \fBload\fR command is used later to load the package into
an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will
be invoked, depending on whether the target interpreter is safe
or not.
\fIinitProc\fR and \fIsafeInitProc\fR must both match the
following prototype:
.CS
typedef int Tcl_PackageInitProc(Tcl_Interp *\fIinterp\fR);
.CE
The \fIinterp\fR argument identifies the interpreter in which the package
is to be loaded. The initialization procedure must return \fBTCL_OK\fR or
\fBTCL_ERROR\fR to indicate whether or not it completed successfully; in
the event of an error it should set the interpreter's result to point to an
error message. The result or error from the initialization procedure will
be returned as the result of the \fBload\fR command that caused the
initialization procedure to be invoked.
.SH KEYWORDS
initialization procedure, package, static linking
tcl8.4.20/doc/ByteArrObj.3 0000644 0036047 0045461 00000007671 11737050674 013566 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl objects as a arrays of bytes
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Obj *
\fBTcl_NewByteArrayObj\fR(\fIbytes, length\fR)
.sp
void
\fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, length\fR)
.sp
unsigned char *
\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR)
.sp
unsigned char *
\fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR)
.SH ARGUMENTS
.AS "unsigned char" *lengthPtr in/out
.AP "CONST unsigned char" *bytes in
The array of bytes used to initialize or set a byte-array object.
.AP int length in
The length of the array of bytes. It must be >= 0.
.AP Tcl_Obj *objPtr in/out
For \fBTcl_SetByteArrayObj\fR, this points to the object to be converted to
byte-array type. For \fBTcl_GetByteArrayFromObj\fR and
\fBTcl_SetByteArrayLength\fR, this points to the object from which to get
the byte-array value; if \fIobjPtr\fR does not already point to a byte-array
object, it will be converted to one.
.AP int *lengthPtr out
If non-NULL, filled with the length of the array of bytes in the object.
.BE
.SH DESCRIPTION
.PP
These procedures are used to create, modify, and read Tcl byte-array objects
from C code. Byte-array objects are typically used to hold the
results of binary IO operations or data structures created with the
\fBbinary\fR command. In Tcl, an array of bytes is not equivalent to a
string. Conceptually, a string is an array of Unicode characters, while a
byte-array is an array of 8-bit quantities with no implicit meaning.
Accesser functions are provided to get the string representation of a
byte-array or to convert an arbitrary object to a byte-array. Obtaining the
string representation of a byte-array object (by calling
\fBTcl_GetStringFromObj\fR) produces a properly formed UTF-8 sequence with a
one-to-one mapping between the bytes in the internal representation and the
UTF-8 characters in the string representation.
.PP
\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR will
create a new object of byte-array type or modify an existing object to have a
byte-array type. Both of these procedures set the object's type to be
byte-array and set the object's internal representation to a copy of the
array of bytes given by \fIbytes\fR. \fBTcl_NewByteArrayObj\fR returns a
pointer to a newly allocated object with a reference count of zero.
\fBTcl_SetByteArrayObj\fR invalidates any old string representation and, if
the object is not already a byte-array object, frees any old internal
representation.
.PP
\fBTcl_GetByteArrayFromObj\fR converts a Tcl object to byte-array type and
returns a pointer to the object's new internal representation as an array of
bytes. The length of this array is stored in \fIlengthPtr\fR if
\fIlengthPtr\fR is non-NULL. The storage for the array of bytes is owned by
the object and should not be freed. The contents of the array may be
modified by the caller only if the object is not shared and the caller
invalidates the string representation.
.PP
\fBTcl_SetByteArrayLength\fR converts the Tcl object to byte-array type
and changes the length of the object's internal representation as an
array of bytes. If \fIlength\fR is greater than the space currently
allocated for the array, the array is reallocated to the new length; the
newly allocated bytes at the end of the array have arbitrary values. If
\fIlength\fR is less than the space currently allocated for the array,
the length of array is reduced to the new length. The return value is a
pointer to the object's new array of bytes.
.SH "SEE ALSO"
Tcl_GetStringFromObj, Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount
.SH KEYWORDS
object, byte array, utf, unicode, internationalization
tcl8.4.20/doc/upvar.n 0000644 0036047 0045461 00000011074 11737050674 013003 0 ustar dgp 771div '\"
'\" Copyright (c) 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.
'\"
.so man.macros
.TH upvar n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
upvar \- Create link to variable in a different stack frame
.SH SYNOPSIS
\fBupvar \fR?\fIlevel\fR? \fIotherVar myVar \fR?\fIotherVar myVar \fR...?
.BE
.SH DESCRIPTION
.PP
This command arranges for one or more local variables in the current
procedure to refer to variables in an enclosing procedure call or
to global variables.
\fILevel\fR may have any of the forms permitted for the \fBuplevel\fR
command, and may be omitted if the first letter of the first \fIotherVar\fR
isn't \fB#\fR or a digit (it defaults to \fB1\fR).
For each \fIotherVar\fR argument, \fBupvar\fR makes the variable
by that name in the procedure frame given by \fIlevel\fR (or at
global level, if \fIlevel\fR is \fB#0\fR) accessible
in the current procedure by the name given in the corresponding
\fImyVar\fR argument.
The variable named by \fIotherVar\fR need not exist at the time of the
call; it will be created the first time \fImyVar\fR is referenced, just like
an ordinary variable. There must not exist a variable by the
name \fImyVar\fR at the time \fBupvar\fR is invoked.
\fIMyVar\fR is always treated as the name of a variable, not an
array element. Even if the name looks like an array element,
such as \fBa(b)\fR, a regular variable is created.
\fIOtherVar\fR may refer to a scalar variable, an array,
or an array element.
\fBUpvar\fR returns an empty string.
.PP
The \fBupvar\fR command simplifies the implementation of call-by-name
procedure calling and also makes it easier to build new control constructs
as Tcl procedures.
For example, consider the following procedure:
.CS
proc add2 name {
\fBupvar\fR $name x
set x [expr $x+2]
}
.CE
\fBadd2\fR is invoked with an argument giving the name of a variable,
and it adds two to the value of that variable.
Although \fBadd2\fR could have been implemented using \fBuplevel\fR
instead of \fBupvar\fR, \fBupvar\fR makes it simpler for \fBadd2\fR
to access the variable in the caller's procedure frame.
.PP
\fBnamespace eval\fR is another way (besides procedure calls)
that the Tcl naming context can change.
It adds a call frame to the stack to represent the namespace context.
This means each \fBnamespace eval\fR command
counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
For example, \fBinfo level 1\fR will return a list
describing a command that is either
the outermost procedure call or the outermost \fBnamespace eval\fR command.
Also, \fBuplevel #0\fR evaluates a script
at top-level in the outermost namespace (the global namespace).
.PP
.VS
If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the
\fBunset\fR operation affects the variable it is linked to, not the
upvar variable. There is no way to unset an upvar variable except
by exiting the procedure in which it is defined. However, it is
possible to retarget an upvar variable by executing another \fBupvar\fR
command.
.SH "TRACES AND UPVAR"
.PP
Upvar interacts with traces in a straightforward but possibly
unexpected manner. If a variable trace is defined on \fIotherVar\fR, that
trace will be triggered by actions involving \fImyVar\fR. However,
the trace procedure will be passed the name of \fImyVar\fR, rather
than the name of \fIotherVar\fR. Thus, the output of the following code
will be \fBlocalVar\fR rather than \fBoriginalVar\fR:
.CS
proc \fBtraceproc\fR { name index op } {
puts $name
}
proc \fBsetByUpvar\fR { name value } {
\fBupvar\fR $name localVar
set localVar $value
}
set originalVar 1
trace variable originalVar w \fBtraceproc\fR
\fBsetByUpvar\fR originalVar 2
}
.CE
.PP
If \fIotherVar\fR refers to an element of an array, then variable
traces set for the entire array will not be invoked when \fImyVar\fR
is accessed (but traces on the particular element will still be
invoked). In particular, if the array is \fBenv\fR, then changes
made to \fImyVar\fR will not be passed to subprocesses correctly.
.VE
.SH EXAMPLE
A \fBdecr\fR command that works like \fBincr\fR except it subtracts
the value from the variable instead of adding it:
.CS
proc decr {varName {decrement 1}} {
\fBupvar\fR 1 $varName var
incr var [expr {-$decrement}]
}
.CE
.SH "SEE ALSO"
global(n), namespace(n), uplevel(n), variable(n)
.SH KEYWORDS
context, frame, global, level, namespace, procedure, variable
tcl8.4.20/doc/switch.n 0000644 0036047 0045461 00000010030 11737050674 013136 0 ustar dgp 771div '\"
'\" Copyright (c) 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.
'\"
.so man.macros
.TH switch n 7.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
switch \- Evaluate one of several scripts, depending on a given value
.SH SYNOPSIS
\fBswitch \fR?\fIoptions\fR?\fI string pattern body \fR?\fIpattern body \fR...?
.sp
\fBswitch \fR?\fIoptions\fR?\fI string \fR{\fIpattern body \fR?\fIpattern body \fR...?}
.BE
.SH DESCRIPTION
.PP
The \fBswitch\fR command matches its \fIstring\fR argument against each of
the \fIpattern\fR arguments in order.
As soon as it finds a \fIpattern\fR that matches \fIstring\fR it
evaluates the following \fIbody\fR argument by passing it recursively
to the Tcl interpreter and returns the result of that evaluation.
If the last \fIpattern\fR argument is \fBdefault\fR then it matches
anything.
If no \fIpattern\fR argument
matches \fIstring\fR and no default is given, then the \fBswitch\fR
command returns an empty string.
.PP
If the initial arguments to \fBswitch\fR start with \fB\-\fR then
they are treated as options. The following options are
currently supported:
.TP 10
\fB\-exact\fR
Use exact matching when comparing \fIstring\fR to a pattern. This
is the default.
.TP 10
\fB\-glob\fR
When matching \fIstring\fR to the patterns, use glob-style matching
(i.e. the same as implemented by the \fBstring match\fR command).
.TP 10
\fB\-regexp\fR
When matching \fIstring\fR to the patterns, use regular
expression matching
(as described in the \fBre_syntax\fR reference page).
.TP 10
\fB\-\|\-\fR
Marks the end of options. The argument following this one will
be treated as \fIstring\fR even if it starts with a \fB\-\fR.
.PP
Two syntaxes are provided for the \fIpattern\fR and \fIbody\fR arguments.
The first uses a separate argument for each of the patterns and commands;
this form is convenient if substitutions are desired on some of the
patterns or commands.
The second form places all of the patterns and commands together into
a single argument; the argument must have proper list structure, with
the elements of the list being the patterns and commands.
The second form makes it easy to construct multi-line switch commands,
since the braces around the whole list make it unnecessary to include a
backslash at the end of each line.
Since the \fIpattern\fR arguments are in braces in the second form,
no command or variable substitutions are performed on them; this makes
the behavior of the second form different than the first form in some
cases.
.PP
If a \fIbody\fR is specified as ``\fB\-\fR'' it means that the \fIbody\fR
for the next pattern should also be used as the body for this
pattern (if the next pattern also has a body of ``\fB\-\fR''
then the body after that is used, and so on).
This feature makes it possible to share a single \fIbody\fR among
several patterns.
.PP
Beware of how you place comments in \fBswitch\fR commands. Comments
should only be placed \fBinside\fR the execution body of one of the
patterns, and not intermingled with the patterns.
.SH "EXAMPLES"
The \fBswitch\fR command can match against variables and not just
literals, as shown here (the result is \fI2\fR):
.CS
set foo "abc"
\fBswitch\fR abc a \- b {expr 1} $foo {expr 2} default {expr 3}
.CE
.PP
Using glob matching and the fall-through body is an alternative to
writing regular expressions with alternations, as can be seen here
(this returns \fI1\fR):
.CS
\fBswitch\fR \-glob aaab {
a*b \-
b {expr 1}
a* {expr 2}
default {expr 3}
}
.CE
.PP
Whenever nothing matches, the \fBdefault\fR clause (which must be
last) is taken. This example has a result of \fI3\fR:
.CS
\fBswitch\fR xyz {
a \-
b {
# Correct Comment Placement
expr 1
}
c {
expr 2
}
default {
expr 3
}
}
.CE
.SH "SEE ALSO"
for(n), if(n), regexp(n)
.SH KEYWORDS
switch, match, regular expression
tcl8.4.20/doc/IntObj.3 0000644 0036047 0045461 00000012272 11737050674 012741 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_IntObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj \- manipulate Tcl objects as integers and wide integers
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Obj *
\fBTcl_NewIntObj\fR(\fIintValue\fR)
.sp
Tcl_Obj *
\fBTcl_NewLongObj\fR(\fIlongValue\fR)
.sp
.VS 8.4
Tcl_Obj *
\fBTcl_NewWideIntObj\fR(\fIwideValue\fR)
.VE 8.4
.sp
\fBTcl_SetIntObj\fR(\fIobjPtr, intValue\fR)
.sp
\fBTcl_SetLongObj\fR(\fIobjPtr, longValue\fR)
.sp
.VS 8.4
\fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR)
.VE 8.4
.sp
int
\fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR)
.sp
int
\fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR)
.sp
.VS 8.4
int
\fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR)
.VE 8.4
.SH ARGUMENTS
.AS Tcl_WideInt *interp
.AP int intValue in
Integer value used to initialize or set an integer object.
.AP long longValue in
Long integer value used to initialize or set an integer object.
.AP Tcl_WideInt wideValue in
.VS 8.4
Wide integer value (minimum 64-bits wide where supported by the
compiler) used to initialize or set a wide integer object.
.VE 8.4
.AP Tcl_Obj *objPtr in/out
For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, and
.VS 8.4
\fBTcl_SetWideIntObj\fR, this points to the object to be converted to
integer type. For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR,
and \fBTcl_GetWideIntFromObj\fR, this refers to the object from which
to get an integer or long integer value; if \fIobjPtr\fR does not
already point to an integer object (or a wide integer object in the
case of \fBTcl_SetWideIntObj\fR and \fBTcl_GetWideIntFromObj\fR,) an
.VE 8.4
attempt will be made to convert it to one.
.AP Tcl_Interp *interp in/out
If an error occurs during conversion,
an error message is left in the interpreter's result object
unless \fIinterp\fR is NULL.
.AP int *intPtr out
Points to place to store the integer value
obtained by \fBTcl_GetIntFromObj\fR from \fIobjPtr\fR.
.AP long *longPtr out
Points to place to store the long integer value
obtained by \fBTcl_GetLongFromObj\fR from \fIobjPtr\fR.
.AP Tcl_WideInt *widePtr out
.VS 8.4
Points to place to store the wide integer value
obtained by \fBTcl_GetWideIntFromObj\fR from \fIobjPtr\fR.
.VE 8.4
.BE
.SH DESCRIPTION
.PP
These procedures are used to create, modify, and read
integer and wide integer Tcl objects from C code.
\fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR,
\fBTcl_SetIntObj\fR, and \fBTcl_SetLongObj\fR
create a new object of integer type
or modify an existing object to have integer type,
.VS 8.4
and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR create a new
object of wide integer type or modify an existing object to have wide
integer type.
.VE 8.4
\fBTcl_NewIntObj\fR and \fBTcl_SetIntObj\fR set the object to have the
integer value given by \fIintValue\fR,
\fBTcl_NewLongObj\fR and \fBTcl_SetLongObj\fR
set the object to have the
long integer value given by \fIlongValue\fR,
.VS 8.4
and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR set the object
to have the wide integer value given by \fIwideValue\fR.
\fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR and \fBTcl_NewWideIntObj\fR
return a pointer to a newly created object with reference count zero.
These procedures set the object's type to be integer
and assign the integer value to the object's internal representation
\fIlongValue\fR or \fIwideValue\fR member (as appropriate).
\fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR
and \fBTcl_SetWideIntObj\fR
.VE 8.4
invalidate any old string representation and,
if the object is not already an integer object,
free any old internal representation.
.PP
\fBTcl_GetIntFromObj\fR and \fBTcl_GetLongFromObj\fR
attempt to return an integer value from the Tcl object \fIobjPtr\fR,
.VS 8.4
and \fBTcl_GetWideIntFromObj\fR attempts to return a wide integer
value from the Tcl object \fIobjPtr\fR.
If the object is not already an integer object,
or a wide integer object in the case of \fBTcl_GetWideIntFromObj\fR
.VE 8.4
they will attempt to convert it to one.
If an error occurs during conversion, they return \fBTCL_ERROR\fR
and leave an error message in the interpreter's result object
unless \fIinterp\fR is NULL.
Also, if the long integer held in the object's internal representation
\fIlongValue\fR member can not be represented in a (non-long) integer,
\fBTcl_GetIntFromObj\fR returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
unless \fIinterp\fR is NULL.
Otherwise, all three procedures return \fBTCL_OK\fR and
store the integer, long integer value
.VS 8.4
or wide integer in the address given by \fIintPtr\fR, \fIlongPtr\fR
and \fIwidePtr\fR
.VE 8.4
respectively. If the object is not already an integer or wide integer
object, the conversion will free any old internal representation.
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult
.SH KEYWORDS
integer, integer object, integer type, internal representation, object, object type, string representation
tcl8.4.20/doc/time.n 0000644 0036047 0045461 00000002100 11737050674 012572 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH time n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
time \- Time the execution of a script
.SH SYNOPSIS
\fBtime \fIscript\fR ?\fIcount\fR?
.BE
.SH DESCRIPTION
.PP
This command will call the Tcl interpreter \fIcount\fR
times to evaluate \fIscript\fR (or once if \fIcount\fR isn't
specified). It will then return a string of the form
.CS
\fB503 microseconds per iteration\fR
.CE
which indicates the average amount of time required per iteration,
in microseconds.
Time is measured in elapsed time, not CPU time.
.SH EXAMPLE
Estimate how long it takes for a simple Tcl \fBfor\fR loop to count to
a thousand:
.CS
time {
for {set i 0} {$i<1000} {incr i} {
# empty body
}
}
.CE
.SH "SEE ALSO"
clock(n)
.SH KEYWORDS
script, time
tcl8.4.20/doc/AppInit.3 0000644 0036047 0045461 00000005263 11737050674 013122 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_AppInit 3 7.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_AppInit \- perform application-specific initialization
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_AppInit\fR(\fIinterp\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp
.AP Tcl_Interp *interp in
Interpreter for the application.
.BE
.SH DESCRIPTION
.PP
\fBTcl_AppInit\fR is a ``hook'' procedure that is invoked by
the main programs for Tcl applications such as \fBtclsh\fR and \fBwish\fR.
Its purpose is to allow new Tcl applications to be created without
modifying the main programs provided as part of Tcl and Tk.
To create a new application you write a new version of
\fBTcl_AppInit\fR to replace the default version provided by Tcl,
then link your new \fBTcl_AppInit\fR with the Tcl library.
.PP
\fBTcl_AppInit\fR is invoked by \fBTcl_Main\fR and \fBTk_Main\fR
after their own initialization and before entering the main loop
to process commands.
Here are some examples of things that \fBTcl_AppInit\fR might do:
.IP [1]
Call initialization procedures for various packages used by
the application.
Each initialization procedure adds new commands to \fIinterp\fR
for its package and performs other package-specific initialization.
.IP [2]
Process command-line arguments, which can be accessed from the
Tcl variables \fBargv\fR and \fBargv0\fR in \fIinterp\fR.
.IP [3]
Invoke a startup script to initialize the application.
.LP
\fBTcl_AppInit\fR returns TCL_OK or TCL_ERROR.
If it returns TCL_ERROR then it must leave an error message in
for the interpreter's result; otherwise the result is ignored.
.PP
In addition to \fBTcl_AppInit\fR, your application should also contain
a procedure \fBmain\fR that calls \fBTcl_Main\fR as follows:
.CS
Tcl_Main(argc, argv, Tcl_AppInit);
.CE
The third argument to \fBTcl_Main\fR gives the address of the
application-specific initialization procedure to invoke.
This means that you don't have to use the name \fBTcl_AppInit\fR
for the procedure, but in practice the name is nearly always
\fBTcl_AppInit\fR (in versions before Tcl 7.4 the name \fBTcl_AppInit\fR
was implicit; there was no way to specify the procedure explicitly).
The best way to get started is to make a copy of the file
\fBtclAppInit.c\fR from the Tcl library or source directory.
It already contains a \fBmain\fR procedure and a template for
\fBTcl_AppInit\fR that you can modify for your application.
.SH KEYWORDS
application, argument, command, initialization, interpreter
tcl8.4.20/doc/GetCwd.3 0000755 0036047 0045461 00000003256 11737050674 012736 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_GetCwd 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetCwd, Tcl_Chdir \- manipulate the current working directory
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
char *
\fBTcl_GetCwd\fR(\fIinterp\fR, \fIbufferPtr\fR)
.sp
int
\fBTcl_Chdir\fR(\fIpath\fR)
.SH ARGUMENTS
.AS Tcl_DString *bufferPtr
.AP Tcl_Interp *interp in
Interpreter in which to report an error, if any.
.AP Tcl_DString *bufferPtr in/out
This dynamic string is used to store the current working directory.
At the time of the call it should be uninitialized or free. The
caller must eventually call \fBTcl_DStringFree\fR to free up
anything stored here.
.AP char *path in
File path in UTF\-8 format.
.BE
.SH DESCRIPTION
.PP
These procedures may be used to manipulate the current working
directory for the application. They provide C\-level access to
the same functionality as the Tcl \fBpwd\fR command.
.PP
\fBTcl_GetCwd\fR returns a pointer to a string specifying the current
directory, or NULL if the current directory could not be determined.
If NULL is returned, an error message is left in the interp's result.
Storage for the result string is allocated in bufferPtr; the caller
must call \fBTcl_DStringFree()\fR when the result is no longer needed.
The format of the path is UTF\-8.
.PP
\fBTcl_Chdir\fR changes the applications current working directory to
the value specified in \fIpath\fR. The format of the passed in string
must be UTF\-8. The function returns -1 on error or 0 on success.
.SH KEYWORDS
pwd
tcl8.4.20/doc/split.n 0000644 0036047 0045461 00000005044 11737050674 013001 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH split n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
split \- Split a string into a proper Tcl list
.SH SYNOPSIS
\fBsplit \fIstring \fR?\fIsplitChars\fR?
.BE
.SH DESCRIPTION
.PP
Returns a list created by splitting \fIstring\fR at each character
that is in the \fIsplitChars\fR argument.
Each element of the result list will consist of the
characters from \fIstring\fR that lie between instances of the
characters in \fIsplitChars\fR.
Empty list elements will be generated if \fIstring\fR contains
adjacent characters in \fIsplitChars\fR, or if the first or last
character of \fIstring\fR is in \fIsplitChars\fR.
If \fIsplitChars\fR is an empty string then each character of
\fIstring\fR becomes a separate element of the result list.
\fISplitChars\fR defaults to the standard white-space characters.
.SH EXAMPLES
Divide up a USENET group name into its hierarchical components:
.CS
\fBsplit\fR "comp.lang.tcl.announce" .
\fI=> comp lang tcl announce\fR
.CE
.PP
See how the \fBsplit\fR command splits on \fIevery\fR character in
\fIsplitChars\fR, which can result in information loss if you are not
careful:
.CS
\fBsplit\fR "alpha beta gamma" "temp"
\fI=> al {ha b} {} {a ga} {} a\fR
.CE
.PP
Extract the list words from a string that is not a well-formed list:
.CS
\fBsplit\fR "Example with {unbalanced brace character"
\fI=> Example with \\{unbalanced brace character\fR
.CE
.PP
Split a string into its constituent characters
.CS
\fBsplit\fR "Hello world" {}
\fI=> H e l l o { } w o r l d\fR
.CE
.SH "PARSING RECORD-ORIENTED FILES"
Parse a Unix /etc/passwd file, which consists of one entry per line,
with each line consisting of a colon-separated list of fields:
.CS
## Read the file
set fid [open /etc/passwd]
set content [read $fid]
close $fid
## Split into records on newlines
set records [\fBsplit\fR $content "\\n"]
## Iterate over the records
foreach rec $records {
## Split into fields on colons
set fields [\fBsplit\fR $rec ":"]
## Assign fields to variables and print some out...
lassign $fields \\
userName password uid grp longName homeDir shell
puts "$longName uses [file tail $shell] for a login shell"
}
.CE
.SH "SEE ALSO"
join(n), list(n), string(n)
.SH KEYWORDS
list, split, string
tcl8.4.20/doc/CrtChannel.3 0000644 0036047 0045461 00000111433 11737050674 013574 0 ustar dgp 771div '\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1997-2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.so man.macros
.TH Tcl_CreateChannel 3 8.4 Tcl "Tcl Library Procedures"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Channel
\fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR)
.sp
ClientData
\fBTcl_GetChannelInstanceData\fR(\fIchannel\fR)
.sp
Tcl_ChannelType *
\fBTcl_GetChannelType\fR(\fIchannel\fR)
.sp
CONST char *
\fBTcl_GetChannelName\fR(\fIchannel\fR)
.sp
int
\fBTcl_GetChannelHandle\fR(\fIchannel, direction, handlePtr\fR)
.sp
.VS 8.4
Tcl_ThreadId
\fBTcl_GetChannelThread\fR(\fIchannel\fR)
.VE 8.4
.sp
int
\fBTcl_GetChannelMode\fR(\fIchannel\fR)
.sp
int
\fBTcl_GetChannelBufferSize\fR(\fIchannel\fR)
.sp
\fBTcl_SetChannelBufferSize\fR(\fIchannel, size\fR)
.sp
\fBTcl_NotifyChannel\fR(\fIchannel, mask\fR)
.sp
int
\fBTcl_BadChannelOption\fR(\fIinterp, optionName, optionList\fR)
.VS 8.4
.sp
int
\fBTcl_IsChannelShared\fR(\fIchannel\fR)
.sp
int
\fBTcl_IsChannelRegistered\fR(\fIinterp, channel\fR)
.sp
int
\fBTcl_IsChannelExisting\fR(\fIchannelName\fR)
.sp
void
\fBTcl_CutChannel\fR(\fIchannel\fR)
.sp
void
\fBTcl_SpliceChannel\fR(\fIchannel\fR)
.sp
void
\fBTcl_ClearChannelHandlers\fR(\fIchannel\fR)
.VE 8.4
.sp
int
\fBTcl_ChannelBuffered\fR(\fIchannel\fR)
.sp
CONST char *
\fBTcl_ChannelName\fR(\fItypePtr\fR)
.sp
Tcl_ChannelTypeVersion
\fBTcl_ChannelVersion\fR(\fItypePtr\fR)
.sp
Tcl_DriverBlockModeProc *
\fBTcl_ChannelBlockModeProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverCloseProc *
\fBTcl_ChannelCloseProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverClose2Proc *
\fBTcl_ChannelClose2Proc\fR(\fItypePtr\fR)
.sp
Tcl_DriverInputProc *
\fBTcl_ChannelInputProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverOutputProc *
\fBTcl_ChannelOutputProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverSeekProc *
\fBTcl_ChannelSeekProc\fR(\fItypePtr\fR)
.sp
.VS 8.4
Tcl_DriverWideSeekProc *
\fBTcl_ChannelWideSeekProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverThreadActionProc *
\fBTcl_ChannelThreadActionProc\fR(\fItypePtr\fR)
.VE 8.4
.sp
Tcl_DriverSetOptionProc *
\fBTcl_ChannelSetOptionProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverGetOptionProc *
\fBTcl_ChannelGetOptionProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverWatchProc *
\fBTcl_ChannelWatchProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverGetHandleProc *
\fBTcl_ChannelGetHandleProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverFlushProc *
\fBTcl_ChannelFlushProc\fR(\fItypePtr\fR)
.sp
Tcl_DriverHandlerProc *
\fBTcl_ChannelHandlerProc\fR(\fItypePtr\fR)
.sp
.SH ARGUMENTS
.AS Tcl_ChannelType *channelName in
.AP Tcl_ChannelType *typePtr in
Points to a structure containing the addresses of procedures that
can be called to perform I/O and other functions on the channel.
.AP "CONST char" *channelName in
The name of this channel, such as \fBfile3\fR; must not be in use
by any other channel. Can be NULL, in which case the channel is
created without a name.
.AP ClientData instanceData in
Arbitrary one-word value to be associated with this channel. This
value is passed to procedures in \fItypePtr\fR when they are invoked.
.AP int mask in
OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate
whether a channel is readable and writable.
.AP Tcl_Channel channel in
The channel to operate on.
.AP int direction in
\fBTCL_READABLE\fR means the input handle is wanted; \fBTCL_WRITABLE\fR
means the output handle is wanted.
.AP ClientData *handlePtr out
Points to the location where the desired OS-specific handle should be
stored.
.AP int size in
The size, in bytes, of buffers to allocate in this channel.
.AP int mask in
An OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR
and \fBTCL_EXCEPTION\fR that indicates events that have occurred on
this channel.
.AP Tcl_Interp *interp in
Current interpreter. (can be NULL)
.AP "CONST char" *optionName in
Name of the invalid option.
.AP "CONST char" *optionList in
Specific options list (space separated words, without "-")
to append to the standard generic options list.
Can be NULL for generic options error message only.
.BE
.SH DESCRIPTION
.PP
Tcl uses a two-layered channel architecture. It provides a generic upper
layer to enable C and Tcl programs to perform input and output using the
same APIs for a variety of files, devices, sockets etc. The generic C APIs
are described in the manual entry for \fBTcl_OpenFileChannel\fR.
.PP
The lower layer provides type-specific channel drivers for each type
of device supported on each platform. This manual entry describes the
C APIs used to communicate between the generic layer and the
type-specific channel drivers. It also explains how new types of
channels can be added by providing new channel drivers.
.PP
Channel drivers consist of a number of components: First, each channel
driver provides a \fBTcl_ChannelType\fR structure containing pointers to
functions implementing the various operations used by the generic layer to
communicate with the channel driver. The \fBTcl_ChannelType\fR structure
and the functions referenced by it are described in the section
TCL_CHANNELTYPE, below.
.PP
Second, channel drivers usually provide a Tcl command to create
instances of that type of channel. For example, the Tcl \fBopen\fR
command creates channels that use the file and command channel
drivers, and the Tcl \fBsocket\fR command creates channels that use
TCP sockets for network communication.
.PP
Third, a channel driver optionally provides a C function to open
channel instances of that type. For example, \fBTcl_OpenFileChannel\fR
opens a channel that uses the file channel driver, and
\fBTcl_OpenTcpClient\fR opens a channel that uses the TCP network
protocol. These creation functions typically use
\fBTcl_CreateChannel\fR internally to open the channel.
.PP
To add a new type of channel you must implement a C API or a Tcl command
that opens a channel by invoking \fBTcl_CreateChannel\fR.
When your driver calls \fBTcl_CreateChannel\fR it passes in
a \fBTcl_ChannelType\fR structure describing the driver's I/O
procedures.
The generic layer will then invoke the functions referenced in that
structure to perform operations on the channel.
.PP
\fBTcl_CreateChannel\fR opens a new channel and associates the supplied
\fItypePtr\fR and \fIinstanceData\fR with it. The channel is opened in the
mode indicated by \fImask\fR.
For a discussion of channel drivers, their operations and the
\fBTcl_ChannelType\fR structure, see the section TCL_CHANNELTYPE, below.
.PP
\fBTcl_CreateChannel\fR interacts with the code managing the standard
channels. Once a standard channel was initialized either through a
call to \fBTcl_GetStdChannel\fR or a call to \fBTcl_SetStdChannel\fR
closing this standard channel will cause the next call to
\fBTcl_CreateChannel\fR to make the new channel the new standard
channel too. See \fBTcl_StandardChannels\fR for a general treatise
about standard channels and the behaviour of the Tcl library with
regard to them.
.PP
\fBTcl_GetChannelInstanceData\fR returns the instance data associated with
the channel in \fIchannel\fR. This is the same as the \fIinstanceData\fR
argument in the call to \fBTcl_CreateChannel\fR that created this channel.
.PP
\fBTcl_GetChannelType\fR returns a pointer to the \fBTcl_ChannelType\fR
structure used by the channel in the \fIchannel\fR argument. This is
the same as the \fItypePtr\fR argument in the call to
\fBTcl_CreateChannel\fR that created this channel.
.PP
\fBTcl_GetChannelName\fR returns a string containing the name associated
with the channel, or NULL if the \fIchannelName\fR argument to
\fBTcl_CreateChannel\fR was NULL.
.PP
\fBTcl_GetChannelHandle\fR places the OS-specific device handle
associated with \fIchannel\fR for the given \fIdirection\fR in the
location specified by \fIhandlePtr\fR and returns \fBTCL_OK\fR. If
the channel does not have a device handle for the specified direction,
then \fBTCL_ERROR\fR is returned instead. Different channel drivers
will return different types of handle. Refer to the manual entries
for each driver to determine what type of handle is returned.
.PP
.VS 8.4
\fBTcl_GetChannelThread\fR returns the id of the thread currently managing
the specified \fIchannel\fR. This allows channel drivers to send their file
events to the correct event queue even for a multi-threaded core.
.VE 8.4
.PP
\fBTcl_GetChannelMode\fR returns an OR-ed combination of \fBTCL_READABLE\fR
and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input
and output.
.PP
\fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers
allocated to store input or output in \fIchannel\fR. If the value was not set
by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then
the default value of 4096 is returned.
.PP
\fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that
will be allocated in subsequent operations on the channel to store input or
output. The \fIsize\fR argument should be between ten and one million,
allowing buffers of ten bytes to one million bytes. If \fIsize\fR is
outside this range, \fBTcl_SetChannelBufferSize\fR sets the buffer size to
4096.
.PP
\fBTcl_NotifyChannel\fR is called by a channel driver to indicate to
the generic layer that the events specified by \fImask\fR have
occurred on the channel. Channel drivers are responsible for invoking
this function whenever the channel handlers need to be called for the
channel. See \fBWATCHPROC\fR below for more details.
.PP
\fBTcl_BadChannelOption\fR is called from driver specific set or get option
procs to generate a complete error message.
.PP
\fBTcl_ChannelBuffered\fR returns the number of bytes of input
currently buffered in the internal buffer (push back area) of the
channel itself. It does not report about the data in the overall
buffers for the stack of channels the supplied channel is part of.
.PP
.VS 8.4
\fBTcl_IsChannelShared\fR checks the refcount of the specified
\fIchannel\fR and returns whether the \fIchannel\fR was shared among
multiple interpreters (result == 1) or not (result == 0).
.PP
\fBTcl_IsChannelRegistered\fR checks whether the specified \fIchannel\fR is
registered in the given \fIinterp\fRreter (result == 1) or not
(result == 0).
.PP
\fBTcl_IsChannelExisting\fR checks whether a channel with the specified
name is registered in the (thread)-global list of all channels (result
== 1) or not (result == 0).
.PP
\fBTcl_CutChannel\fR removes the specified \fIchannel\fR from the
(thread)global list of all channels (of the current thread).
Application to a channel still registered in some interpreter
is not allowed.
.VS 8.4
Also notifies the driver if the \fBTcl_ChannelType\fR version is
\fBTCL_CHANNEL_VERSION_4\fR (or higher), and
\fBTcl_DriverThreadActionProc\fR is defined for it.
.VE 8.4
.PP
\fBTcl_SpliceChannel\fR adds the specified \fIchannel\fR to the
(thread)global list of all channels (of the current thread).
Application to a channel registered in some interpreter is not allowed.
.VS 8.4
Also notifies the driver if the \fBTcl_ChannelType\fR version is
\fBTCL_CHANNEL_VERSION_4\fR (or higher), and
\fBTcl_DriverThreadActionProc\fR is defined for it.
.VE 8.4
.PP
\fBTcl_ClearChannelHandlers\fR removes all channelhandlers and event
scripts associated with the specified \fIchannel\fR, thus shutting
down all event processing for this channel.
.VE 8.4
.SH TCL_CHANNELTYPE
.PP
A channel driver provides a \fBTcl_ChannelType\fR structure that contains
pointers to functions that implement the various operations on a channel;
these operations are invoked as needed by the generic layer. The structure
was versioned starting in Tcl 8.3.2/8.4 to correct a problem with stacked
channel drivers. See the \fBOLD CHANNEL TYPES\fR section below for
details about the old structure.
.PP
The \fBTcl_ChannelType\fR structure contains the following fields:
.CS
typedef struct Tcl_ChannelType {
char *\fItypeName\fR;
Tcl_ChannelTypeVersion \fIversion\fR;
Tcl_DriverCloseProc *\fIcloseProc\fR;
Tcl_DriverInputProc *\fIinputProc\fR;
Tcl_DriverOutputProc *\fIoutputProc\fR;
Tcl_DriverSeekProc *\fIseekProc\fR;
Tcl_DriverSetOptionProc *\fIsetOptionProc\fR;
Tcl_DriverGetOptionProc *\fIgetOptionProc\fR;
Tcl_DriverWatchProc *\fIwatchProc\fR;
Tcl_DriverGetHandleProc *\fIgetHandleProc\fR;
Tcl_DriverClose2Proc *\fIclose2Proc\fR;
Tcl_DriverBlockModeProc *\fIblockModeProc\fR;
Tcl_DriverFlushProc *\fIflushProc\fR;
Tcl_DriverHandlerProc *\fIhandlerProc\fR;
Tcl_DriverWideSeekProc *\fIwideSeekProc\fR;
Tcl_DriverThreadActionProc *\fIthreadActionProc\fR;
} Tcl_ChannelType;
.CE
.PP
It is not necessary to provide implementations for all channel
operations. Those which are not necessary may be set to NULL in the
struct: \fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR,
\fIgetOptionProc\fR, and \fIclose2Proc\fR, in addition to
\fIflushProc\fR, \fIhandlerProc\fR, and \fIthreadActionProc\fR. Other
functions that cannot be implemented in a meaningful way should return
\fBEINVAL\fR when called, to indicate that the operations they
represent are not available. Also note that \fIwideSeekProc\fR can be
NULL if \fIseekProc\fR is.
.PP
The user should only use the above structure for \fBTcl_ChannelType\fR
instantiation. When referencing fields in a \fBTcl_ChannelType\fR
structure, the following functions should be used to obtain the values:
\fBTcl_ChannelName\fR, \fBTcl_ChannelVersion\fR,
\fBTcl_ChannelBlockModeProc\fR, \fBTcl_ChannelCloseProc\fR,
\fBTcl_ChannelClose2Proc\fR, \fBTcl_ChannelInputProc\fR,
\fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelSeekProc\fR,
.VS 8.4
\fBTcl_ChannelWideSeekProc\fR,
\fBTcl_ChannelThreadActionProc\fR,
.VE 8.4
\fBTcl_ChannelSetOptionProc\fR, \fBTcl_ChannelGetOptionProc\fR,
\fBTcl_ChannelWatchProc\fR, \fBTcl_ChannelGetHandleProc\fR,
\fBTcl_ChannelFlushProc\fR, or \fBTcl_ChannelHandlerProc\fR.
.PP
The change to the structures was made in such a way that standard channel
types are binary compatible. However, channel types that use stacked
channels (ie: TLS, Trf) have new versions to correspond to the above change
since the previous code for stacked channels had problems.
.SH TYPENAME
.PP
The \fItypeName\fR field contains a null-terminated string that
identifies the type of the device implemented by this driver, e.g.
\fBfile\fR or \fBsocket\fR.
.PP
This value can be retrieved with \fBTcl_ChannelName\fR, which returns
a pointer to the string.
.SH VERSION
.PP
The \fIversion\fR field should be set to the version of the structure
that you require. \fBTCL_CHANNEL_VERSION_2\fR is the minimum recommended.
.VS 8.4
\fBTCL_CHANNEL_VERSION_3\fR must be set to specifiy the \fIwideSeekProc\fR member.
.VE 8.4
.VS 8.4
\fBTCL_CHANNEL_VERSION_4\fR must be set to specifiy the
\fIthreadActionProc\fR member (includes \fIwideSeekProc\fR).
.VE 8.4
If it is not set to any of these, then this
\fBTcl_ChannelType\fR is assumed to have the original structure. See
\fBOLD CHANNEL TYPES\fR for more details. While Tcl will recognize
and function with either structures, stacked channels must be of at
least \fBTCL_CHANNEL_VERSION_2\fR to function correctly.
.PP
This value can be retrieved with \fBTcl_ChannelVersion\fR, which returns
.VS 8.4
one of \fBTCL_CHANNEL_VERSION_4\fR, \fBTCL_CHANNEL_VERSION_3\fR,
.VE 8.4
\fBTCL_CHANNEL_VERSION_2\fR, or \fBTCL_CHANNEL_VERSION_1\fR.
.SH BLOCKMODEPROC
.PP
The \fIblockModeProc\fR field contains the address of a function called by
the generic layer to set blocking and nonblocking mode on the device.
\fIBlockModeProc\fR should match the following prototype:
.PP
.CS
typedef int Tcl_DriverBlockModeProc(
ClientData \fIinstanceData\fR,
int \fImode\fR);
.CE
.PP
The \fIinstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created. The \fImode\fR
argument is either \fBTCL_MODE_BLOCKING\fR or \fBTCL_MODE_NONBLOCKING\fR to
set the device into blocking or nonblocking mode. The function should
return zero if the operation was successful, or a nonzero POSIX error code
if the operation failed.
.PP
If the operation is successful, the function can modify the supplied
\fIinstanceData\fR to record that the channel entered blocking or
nonblocking mode and to implement the blocking or nonblocking behavior.
For some device types, the blocking and nonblocking behavior can be
implemented by the underlying operating system; for other device types, the
behavior must be emulated in the channel driver.
.PP
This value can be retrieved with \fBTcl_ChannelBlockModeProc\fR, which returns
a pointer to the function.
.PP
A channel driver \fBnot\fR supplying a \fIblockModeProc\fR has to be
very, very careful. It has to tell the generic layer exactly which
blocking mode is acceptable to it, and should this also document for
the user so that the blocking mode of the channel is not changed to an
inacceptable value. Any confusion here may lead the interpreter into a
(spurious and difficult to find) deadlock.
.SH "CLOSEPROC AND CLOSE2PROC"
.PP
The \fIcloseProc\fR field contains the address of a function called by the
generic layer to clean up driver-related information when the channel is
closed. \fICloseProc\fR must match the following prototype:
.PP
.CS
typedef int Tcl_DriverCloseProc(
ClientData \fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
.PP
The \fIinstanceData\fR argument is the same as the value provided to
\fBTcl_CreateChannel\fR when the channel was created. The function should
release any storage maintained by the channel driver for this channel, and
close the input and output devices encapsulated by this channel. All queued
output will have been flushed to the device before this function is called,
and no further driver operations will be invoked on this instance after
calling the \fIcloseProc\fR. If the close operation is successful, the
procedure should return zero; otherwise it should return a nonzero POSIX
error code. In addition, if an error occurs and \fIinterp\fR is not NULL,
the procedure should store an error message in the interpreter's result.
.PP
Alternatively, channels that support closing the read and write sides
independently may set \fIcloseProc\fR to \fBTCL_CLOSE2PROC\fR and set
\fIclose2Proc\fR to the address of a function that matches the
following prototype:
.PP
.CS
typedef int Tcl_DriverClose2Proc(
ClientData \fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIflags\fR);
.CE
.PP
The \fIclose2Proc\fR will be called with \fIflags\fR set to an OR'ed
combination of \fBTCL_CLOSE_READ\fR or \fBTCL_CLOSE_WRITE\fR to
indicate that the driver should close the read and/or write side of
the channel. The channel driver may be invoked to perform
additional operations on the channel after \fIclose2Proc\fR is
called to close one or both sides of the channel. If \fIflags\fR is
\fB0\fR (zero), the driver should close the channel in the manner
described above for \fIcloseProc\fR. No further operations will be
invoked on this instance after \fIclose2Proc\fR is called with all
flags cleared. In all cases, the \fIclose2Proc\fR function should
return zero if the close operation was successful; otherwise it should
return a nonzero POSIX error code. In addition, if an error occurs and
\fIinterp\fR is not NULL, the procedure should store an error message
in the interpreter's result.
.PP
These value can be retrieved with \fBTcl_ChannelCloseProc\fR or
\fBTcl_ChannelClose2Proc\fR, which returns a pointer to the respective
function.
.SH INPUTPROC
.PP
The \fIinputProc\fR field contains the address of a function called by the
generic layer to read data from the file or device and store it in an
internal buffer. \fIInputProc\fR must match the following prototype:
.PP
.CS
typedef int Tcl_DriverInputProc(
ClientData \fIinstanceData\fR,
char *\fIbuf\fR,
int \fIbufSize\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when the channel was created. The \fIbuf\fR
argument points to an array of bytes in which to store input from the
device, and the \fIbufSize\fR argument indicates how many bytes are
available at \fIbuf\fR.
.PP
The \fIerrorCodePtr\fR argument points to an integer variable provided by
the generic layer. If an error occurs, the function should set the variable
to a POSIX error code that identifies the error that occurred.
.PP
The function should read data from the input device encapsulated by the
channel and store it at \fIbuf\fR. On success, the function should return
a nonnegative integer indicating how many bytes were read from the input
device and stored at \fIbuf\fR. On error, the function should return -1. If
an error occurs after some data has been read from the device, that data is
lost.
.PP
If \fIinputProc\fR can determine that the input device has some data
available but less than requested by the \fIbufSize\fR argument, the
function should only attempt to read as much data as is available and
return without blocking. If the input device has no data available
whatsoever and the channel is in nonblocking mode, the function should
return an \fBEAGAIN\fR error. If the input device has no data available
whatsoever and the channel is in blocking mode, the function should block
for the shortest possible time until at least one byte of data can be read
from the device; then, it should return as much data as it can read without
blocking.
.PP
This value can be retrieved with \fBTcl_ChannelInputProc\fR, which returns
a pointer to the function.
.SH OUTPUTPROC
.PP
The \fIoutputProc\fR field contains the address of a function called by the
generic layer to transfer data from an internal buffer to the output device.
\fIOutputProc\fR must match the following prototype:
.PP
.CS
typedef int Tcl_DriverOutputProc(
ClientData \fIinstanceData\fR,
CONST char *\fIbuf\fR,
int \fItoWrite\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when the channel was created. The \fIbuf\fR
argument contains an array of bytes to be written to the device, and the
\fItoWrite\fR argument indicates how many bytes are to be written from the
\fIbuf\fR argument.
.PP
The \fIerrorCodePtr\fR argument points to an integer variable provided by
the generic layer. If an error occurs, the function should set this
variable to a POSIX error code that identifies the error.
.PP
The function should write the data at \fIbuf\fR to the output device
encapsulated by the channel. On success, the function should return a
nonnegative integer indicating how many bytes were written to the output
device. The return value is normally the same as \fItoWrite\fR, but may be
less in some cases such as if the output operation is interrupted by a
signal. If an error occurs the function should return -1. In case of
error, some data may have been written to the device.
.PP
If the channel is nonblocking and the output device is unable to absorb any
data whatsoever, the function should return -1 with an \fBEAGAIN\fR error
without writing any data.
.PP
This value can be retrieved with \fBTcl_ChannelOutputProc\fR, which returns
a pointer to the function.
.SH "SEEKPROC AND WIDESEEKPROC"
.PP
The \fIseekProc\fR field contains the address of a function called by the
generic layer to move the access point at which subsequent input or output
operations will be applied. \fISeekProc\fR must match the following
prototype:
.PP
.CS
typedef int Tcl_DriverSeekProc(
ClientData \fIinstanceData\fR,
long \fIoffset\fR,
int \fIseekMode\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
The \fIinstanceData\fR argument is the same as the value given to
\fBTcl_CreateChannel\fR when this channel was created. \fIOffset\fR and
\fIseekMode\fR have the same meaning as for the \fBTcl_Seek\fR
procedure (described in the manual entry for \fBTcl_OpenFileChannel\fR).
.PP
The \fIerrorCodePtr\fR argument points to an integer variable provided by
the generic layer for returning \fBerrno\fR values from the function. The
function should set this variable to a POSIX error code if an error occurs.
The function should store an \fBEINVAL\fR error code if the channel type
does not implement seeking.
.PP
The return value is the new access point or -1 in case of error. If an
error occurred, the function should not move the access point.
.PP
.VS 8.4
If there is a non-NULL \fIseekProc\fR field, the \fIwideSeekProc\fR
field may contain the address of an alternative function to use which
handles wide (i.e. larger than 32-bit) offsets, so allowing seeks
within files larger than 2GB. The \fIwideSeekProc\fR will be called
in preference to the \fIseekProc\fR, but both must be defined if the
\fIwideSeekProc\fR is defined. \fIWideSeekProc\fR must match the
following prototype:
.PP
.CS
typedef Tcl_WideInt Tcl_DriverWideSeekProc(
ClientData \fIinstanceData\fR,
Tcl_WideInt \fIoffset\fR,
int \fIseekMode\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
The arguments and return values mean the same thing as with
\fIseekProc\fR above, except that the type of offsets and the return
type are different.
.PP
The \fIseekProc\fR value can be retrieved with
\fBTcl_ChannelSeekProc\fR, which returns a pointer to the function,
and similarly the \fIwideSeekProc\fR can be retrieved with
\fBTcl_ChannelWideSeekProc\fR.
.VE 8.4
.SH SETOPTIONPROC
.PP
The \fIsetOptionProc\fR field contains the address of a function called by
the generic layer to set a channel type specific option on a channel.
\fIsetOptionProc\fR must match the following prototype:
.PP
.CS
typedef int Tcl_DriverSetOptionProc(
ClientData \fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR,
CONST char *\fIoptionName\fR,
CONST char *\fInewValue\fR);
.CE
.PP
\fIoptionName\fR is the name of an option to set, and \fInewValue\fR is
the new value for that option, as a string. The \fIinstanceData\fR is the
same as the value given to \fBTcl_CreateChannel\fR when this channel was
created. The function should do whatever channel type specific action is
required to implement the new value of the option.
.PP
Some options are handled by the generic code and this function is never
called to set them, e.g. \fB-blockmode\fR. Other options are specific to
each channel type and the \fIsetOptionProc\fR procedure of the channel
driver will get called to implement them. The \fIsetOptionProc\fR field can
be NULL, which indicates that this channel type supports no type specific
options.
.PP
If the option value is successfully modified to the new value, the function
returns \fBTCL_OK\fR.
It should call \fBTcl_BadChannelOption\fR which itself returns
\fBTCL_ERROR\fR if the \fIoptionName\fR is
unrecognized.
If \fInewValue\fR specifies a value for the option that
is not supported or if a system call error occurs,
the function should leave an error message in the
\fIresult\fR field of \fIinterp\fR if \fIinterp\fR is not NULL. The
function should also call \fBTcl_SetErrno\fR to store an appropriate POSIX
error code.
.PP
This value can be retrieved with \fBTcl_ChannelSetOptionProc\fR, which returns
a pointer to the function.
.SH GETOPTIONPROC
.PP
The \fIgetOptionProc\fR field contains the address of a function called by
the generic layer to get the value of a channel type specific option on a
channel. \fIgetOptionProc\fR must match the following prototype:
.PP
.CS
typedef int Tcl_DriverGetOptionProc(
ClientData \fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR,
CONST char *\fIoptionName\fR,
Tcl_DString *\fIoptionValue\fR);
.CE
.PP
\fIOptionName\fR is the name of an option supported by this type of
channel. If the option name is not NULL, the function stores its current
value, as a string, in the Tcl dynamic string \fIoptionValue\fR.
If \fIoptionName\fR is NULL, the function stores in \fIoptionValue\fR an
alternating list of all supported options and their current values.
On success, the function returns \fBTCL_OK\fR.
It should call \fBTcl_BadChannelOption\fR which itself returns
\fBTCL_ERROR\fR if the \fIoptionName\fR is
unrecognized. If a system call error occurs,
the function should leave an error message in the
result of \fIinterp\fR if \fIinterp\fR is not NULL. The
function should also call \fBTcl_SetErrno\fR to store an appropriate POSIX
error code.
.PP
Some options are handled by the generic code and this function is never
called to retrieve their value, e.g. \fB-blockmode\fR. Other options are
specific to each channel type and the \fIgetOptionProc\fR procedure of the
channel driver will get called to implement them. The \fIgetOptionProc\fR
field can be NULL, which indicates that this channel type supports no type
specific options.
.PP
This value can be retrieved with \fBTcl_ChannelGetOptionProc\fR, which returns
a pointer to the function.
.SH WATCHPROC
.PP
The \fIwatchProc\fR field contains the address of a function called
by the generic layer to initialize the event notification mechanism to
notice events of interest on this channel.
\fIWatchProc\fR should match the following prototype:
.PP
.CS
typedef void Tcl_DriverWatchProc(
ClientData \fIinstanceData\fR,
int \fImask\fR);
.CE
.PP
The \fIinstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created. The \fImask\fR
argument is an OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR
and \fBTCL_EXCEPTION\fR; it indicates events the caller is interested in
noticing on this channel.
.PP
The function should initialize device type specific mechanisms to
notice when an event of interest is present on the channel. When one
or more of the designated events occurs on the channel, the channel
driver is responsible for calling \fBTcl_NotifyChannel\fR to inform
the generic channel module. The driver should take care not to starve
other channel drivers or sources of callbacks by invoking
Tcl_NotifyChannel too frequently. Fairness can be insured by using
the Tcl event queue to allow the channel event to be scheduled in sequence
with other events. See the description of \fBTcl_QueueEvent\fR for
details on how to queue an event.
.PP
This value can be retrieved with \fBTcl_ChannelWatchProc\fR, which returns
a pointer to the function.
.SH GETHANDLEPROC
.PP
The \fIgetHandleProc\fR field contains the address of a function called by
the generic layer to retrieve a device-specific handle from the channel.
\fIGetHandleProc\fR should match the following prototype:
.PP
.CS
typedef int Tcl_DriverGetHandleProc(
ClientData \fIinstanceData\fR,
int \fIdirection\fR,
ClientData *\fIhandlePtr\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created. The \fIdirection\fR
argument is either \fBTCL_READABLE\fR to retrieve the handle used
for input, or \fBTCL_WRITABLE\fR to retrieve the handle used for
output.
.PP
If the channel implementation has device-specific handles, the
function should retrieve the appropriate handle associated with the
channel, according the \fIdirection\fR argument. The handle should be
stored in the location referred to by \fIhandlePtr\fR, and
\fBTCL_OK\fR should be returned. If the channel is not open for the
specified direction, or if the channel implementation does not use
device handles, the function should return \fBTCL_ERROR\fR.
.PP
This value can be retrieved with \fBTcl_ChannelGetHandleProc\fR, which returns
a pointer to the function.
.SH FLUSHPROC
.PP
The \fIflushProc\fR field is currently reserved for future use.
It should be set to NULL.
\fIFlushProc\fR should match the following prototype:
.PP
.CS
typedef int Tcl_DriverFlushProc(
ClientData \fIinstanceData\fR);
.CE
.PP
This value can be retrieved with \fBTcl_ChannelFlushProc\fR, which returns
a pointer to the function.
.SH HANDLERPROC
.PP
The \fIhandlerProc\fR field contains the address of a function called by
the generic layer to notify the channel that an event occurred. It should
be defined for stacked channel drivers that wish to be notified of events
that occur on the underlying (stacked) channel.
\fIHandlerProc\fR should match the following prototype:
.PP
.CS
typedef int Tcl_DriverHandlerProc(
ClientData \fIinstanceData\fR,
int \fIinterestMask\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR
when this channel was created. The \fIinterestMask\fR is an OR-ed
combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what
type of event occurred on this channel.
.PP
This value can be retrieved with \fBTcl_ChannelHandlerProc\fR, which returns
a pointer to the function.
.VS 8.4
.SH "THREADACTIONPROC"
.PP
The \fIthreadActionProc\fR field contains the address of the function
called by the generic layer when a channel is created, closed, or
going to move to a different thread, i.e. whenever thread-specific
driver state might have to initialized or updated. It can be NULL.
The action \fITCL_CHANNEL_THREAD_REMOVE\fR is used to notify the
driver that it should update or remove any thread-specific data it
might be maintaining for the channel.
.PP
The action \fITCL_CHANNEL_THREAD_INSERT\fR is used to notify the
driver that it should update or initialize any thread-specific data it
might be maintaining using the calling thread as the associate. See
\fBTcl_CutChannel\fR and \fBTcl_SpliceChannel\fR for more detail.
.PP
.CS
typedef void Tcl_DriverThreadActionProc(
ClientData \fIinstanceData\fR,
int \fIaction\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created.
.PP
These values can be retrieved with \fBTcl_ChannelThreadActionProc\fR,
which returns a pointer to the function.
.VE 8.4
.SH TCL_BADCHANNELOPTION
.PP
This procedure generates a "bad option" error message in an
(optional) interpreter. It is used by channel drivers when
a invalid Set/Get option is requested. Its purpose is to concatenate
the generic options list to the specific ones and factorize
the generic options error message string.
.PP
It always return \fBTCL_ERROR\fR
.PP
An error message is generated in \fIinterp\fR's result object to
indicate that a command was invoked with the a bad option
The message has the form
.CS
bad option "blah": should be one of
<...generic options...>+<...specific options...>
so you get for instance:
bad option "-blah": should be one of -blocking,
-buffering, -buffersize, -eofchar, -translation,
-peername, or -sockname
when called with \fIoptionList\fR="peername sockname"
.CE
``blah'' is the \fIoptionName\fR argument and ``''
is a space separated list of specific option words.
The function takes good care of inserting minus signs before
each option, commas after, and an ``or'' before the last option.
.SH "OLD CHANNEL TYPES"
The original (8.3.1 and below) \fBTcl_ChannelType\fR structure contains
the following fields:
.PP
.CS
typedef struct Tcl_ChannelType {
char *\fItypeName\fR;
Tcl_DriverBlockModeProc *\fIblockModeProc\fR;
Tcl_DriverCloseProc *\fIcloseProc\fR;
Tcl_DriverInputProc *\fIinputProc\fR;
Tcl_DriverOutputProc *\fIoutputProc\fR;
Tcl_DriverSeekProc *\fIseekProc\fR;
Tcl_DriverSetOptionProc *\fIsetOptionProc\fR;
Tcl_DriverGetOptionProc *\fIgetOptionProc\fR;
Tcl_DriverWatchProc *\fIwatchProc\fR;
Tcl_DriverGetHandleProc *\fIgetHandleProc\fR;
Tcl_DriverClose2Proc *\fIclose2Proc\fR;
} Tcl_ChannelType;
.CE
.PP
It is still possible to create channel with the above structure. The
internal channel code will determine the version. It is imperative to use
the new \fBTcl_ChannelType\fR structure if you are creating a stacked
channel driver, due to problems with the earlier stacked channel
implementation (in 8.2.0 to 8.3.1).
.PP
.VS 8.4
Prior to 8.4.0 (i.e. during the later releases of 8.3 and early part
of the 8.4 development cycle) the \fBTcl_ChannelType\fR structure
contained the following fields:
.PP
.CS
typedef struct Tcl_ChannelType {
char *\fItypeName\fR;
Tcl_ChannelTypeVersion \fIversion\fR;
Tcl_DriverCloseProc *\fIcloseProc\fR;
Tcl_DriverInputProc *\fIinputProc\fR;
Tcl_DriverOutputProc *\fIoutputProc\fR;
Tcl_DriverSeekProc *\fIseekProc\fR;
Tcl_DriverSetOptionProc *\fIsetOptionProc\fR;
Tcl_DriverGetOptionProc *\fIgetOptionProc\fR;
Tcl_DriverWatchProc *\fIwatchProc\fR;
Tcl_DriverGetHandleProc *\fIgetHandleProc\fR;
Tcl_DriverClose2Proc *\fIclose2Proc\fR;
Tcl_DriverBlockModeProc *\fIblockModeProc\fR;
Tcl_DriverFlushProc *\fIflushProc\fR;
Tcl_DriverHandlerProc *\fIhandlerProc\fR;
} Tcl_ChannelType;
.CE
.PP
When the above structure is registered as a channel type, the
\fIversion\fR field should always be \fBTCL_CHANNEL_VERSION_2\fR.
.VE 8.4
.SH "SEE ALSO"
Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3), Tcl_QueueEvent(3), Tcl_StackChannel(3), Tcl_GetStdChannel(3)
.SH KEYWORDS
blocking, channel driver, channel registration, channel type, nonblocking
tcl8.4.20/doc/pid.n 0000644 0036047 0045461 00000002765 11737050674 012431 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH pid n 7.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
pid \- Retrieve process identifiers
.SH SYNOPSIS
\fBpid \fR?\fIfileId\fR?
.BE
.SH DESCRIPTION
.PP
If the \fIfileId\fR argument is given then it should normally
refer to a process pipeline created with the \fBopen\fR command.
In this case the \fBpid\fR command will return a list whose elements
are the process identifiers of all the processes in the pipeline,
in order.
The list will be empty if \fIfileId\fR refers to an open file
that isn't a process pipeline.
If no \fIfileId\fR argument is given then \fBpid\fR returns the process
identifier of the current process.
All process identifiers are returned as decimal strings.
.SH EXAMPLE
Print process information about the processes in a pipeline using the
SysV \fBps\fR program before reading the output of that pipeline:
.PP
.CS
set pipeline [open "| zcat somefile.gz | grep foobar | sort -u"]
# Print process information
exec ps -fp [\fBpid\fR $pipeline] >@stdout
# Print a separator and then the output of the pipeline
puts [string repeat - 70]
puts [read $pipeline]
close $pipeline
.CE
.SH "SEE ALSO"
exec(n), open(n)
.SH KEYWORDS
file, pipeline, process identifier
tcl8.4.20/doc/library.n 0000644 0036047 0045461 00000033372 11737050674 013317 0 ustar dgp 771div '\"
'\" Copyright (c) 1991-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH library n "8.0" Tcl "Tcl Built-In Commands"
.BS
.SH NAME
auto_execok, auto_import, auto_load, auto_mkindex, auto_mkindex_old, auto_qualify, auto_reset, tcl_findLibrary, parray, tcl_endOfWord, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore \- standard library of Tcl procedures
.SH SYNOPSIS
.nf
\fBauto_execok \fIcmd\fR
\fBauto_import \fIpattern\fR
\fBauto_load \fIcmd\fR
\fBauto_mkindex \fIdir pattern pattern ...\fR
\fBauto_mkindex_old \fIdir pattern pattern ...\fR
\fBauto_qualify \fIcommand namespace\fR
\fBauto_reset\fR
\fBtcl_findLibrary \fIbasename version patch initScript enVarName varName\fR
\fBparray \fIarrayName\fR
.VS
\fBtcl_endOfWord \fIstr start\fR
\fBtcl_startOfNextWord \fIstr start\fR
\fBtcl_startOfPreviousWord \fIstr start\fR
\fBtcl_wordBreakAfter \fIstr start\fR
\fBtcl_wordBreakBefore \fIstr start\fR
.VE
.BE
.SH INTRODUCTION
.PP
Tcl includes a library of Tcl procedures for commonly-needed functions.
The procedures defined in the Tcl library are generic ones suitable
for use by many different applications.
The location of the Tcl library is returned by the \fBinfo library\fR
command.
In addition to the Tcl library, each application will normally have
its own library of support procedures as well; the location of this
library is normally given by the value of the \fB$\fIapp\fB_library\fR
global variable, where \fIapp\fR is the name of the application.
For example, the location of the Tk library is kept in the variable
\fB$tk_library\fR.
.PP
To access the procedures in the Tcl library, an application should
source the file \fBinit.tcl\fR in the library, for example with
the Tcl command
.CS
\fBsource [file join [info library] init.tcl]\fR
.CE
If the library procedure \fBTcl_Init\fR is invoked from an application's
\fBTcl_AppInit\fR procedure, this happens automatically.
The code in \fBinit.tcl\fR will define the \fBunknown\fR procedure
and arrange for the other procedures to be loaded on-demand using
the auto-load mechanism defined below.
.SH "COMMAND PROCEDURES"
.PP
The following procedures are provided in the Tcl library:
.TP
\fBauto_execok \fIcmd\fR
Determines whether there is an executable file or shell builtin
by the name \fIcmd\fR. If so, it returns a list of arguments to be
passed to \fBexec\fR to execute the executable file or shell builtin
named by \fIcmd\fR. If not, it returns an empty string. This command
examines the directories in the current search path (given by the PATH
environment variable) in its search for an executable file named
\fIcmd\fR. On Windows platforms, the search is expanded with the same
directories and file extensions as used by \fBexec\fR. \fBAuto_exec\fR
remembers information about previous searches in an array named
\fBauto_execs\fR; this avoids the path search in future calls for the
same \fIcmd\fR. The command \fBauto_reset\fR may be used to force
\fBauto_execok\fR to forget its cached information.
.TP
\fBauto_import \fIpattern\fR
\fBAuto_import\fR is invoked during \fBnamespace import\fR to see if
the imported commands specified by \fIpattern\fR reside in an
autoloaded library. If so, the commands are loaded so that they will
be available to the interpreter for creating the import links. If the
commands do not reside in an autoloaded library, \fBauto_import\fR
does nothing. The pattern matching is performed according to the
matching rules of \fBnamespace import\fR.
.TP
\fBauto_load \fIcmd\fR
This command attempts to load the definition for a Tcl command named
\fIcmd\fR. To do this, it searches an \fIauto-load path\fR, which is
a list of one or more directories. The auto-load path is given by the
global variable \fB$auto_path\fR if it exists. If there is no
\fB$auto_path\fR variable, then the TCLLIBPATH environment variable is
used, if it exists. Otherwise the auto-load path consists of just the
Tcl library directory. Within each directory in the auto-load path
there must be a file \fBtclIndex\fR that describes one or more
commands defined in that directory and a script to evaluate to load
each of the commands. The \fBtclIndex\fR file should be generated
with the \fBauto_mkindex\fR command. If \fIcmd\fR is found in an
index file, then the appropriate script is evaluated to create the
command. The \fBauto_load\fR command returns 1 if \fIcmd\fR was
successfully created. The command returns 0 if there was no index
entry for \fIcmd\fR or if the script didn't actually define \fIcmd\fR
(e.g. because index information is out of date). If an error occurs
while processing the script, then that error is returned.
\fBAuto_load\fR only reads the index information once and saves it in
the array \fBauto_index\fR; future calls to \fBauto_load\fR check for
\fIcmd\fR in the array rather than re-reading the index files. The
cached index information may be deleted with the command
\fBauto_reset\fR. This will force the next \fBauto_load\fR command to
reload the index database from disk.
.TP
\fBauto_mkindex \fIdir pattern pattern ...\fR
Generates an index suitable for use by \fBauto_load\fR. The command
searches \fIdir\fR for all files whose names match any of the
\fIpattern\fR arguments (matching is done with the \fBglob\fR
command), generates an index of all the Tcl command procedures defined
in all the matching files, and stores the index information in a file
named \fBtclIndex\fR in \fIdir\fR. If no pattern is given a pattern of
\fB*.tcl\fR will be assumed. For example, the command
.RS
.CS
\fBauto_mkindex foo *.tcl\fR
.CE
.LP
will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR and
generate a new index file \fBfoo/tclIndex\fR.
.PP
\fBAuto_mkindex\fR parses the Tcl scripts by sourcing them into a
slave interpreter and monitoring the proc and namespace commands that
are executed. Extensions can use the (undocumented)
auto_mkindex_parser package to register other commands that can
contribute to the auto_load index. You will have to read through
auto.tcl to see how this works.
.PP
\fBAuto_mkindex_old\fR parses the Tcl scripts in a relatively
unsophisticated way: if any line contains the word \fBproc\fR
as its first characters then it is assumed to be a procedure
definition and the next word of the line is taken as the
procedure's name.
Procedure definitions that don't appear in this way (e.g. they
have spaces before the \fBproc\fR) will not be indexed. If your
script contains "dangerous" code, such as global initialization
code or procedure names with special characters like \fB$\fR,
\fB*\fR, \fB[\fR or \fB]\fR, you are safer using auto_mkindex_old.
.RE
.TP
\fBauto_reset\fR
Destroys all the information cached by \fBauto_execok\fR and
\fBauto_load\fR. This information will be re-read from disk the next
time it is needed. \fBAuto_reset\fR also deletes any procedures
listed in the auto-load index, so that fresh copies of them will be
loaded the next time that they're used.
.TP
\fBauto_qualify \fIcommand namespace\fR
Computes a list of fully qualified names for \fIcommand\fR. This list
mirrors the path a standard Tcl interpreter follows for command
lookups: first it looks for the command in the current namespace, and
then in the global namespace. Accordingly, if \fIcommand\fR is
relative and \fInamespace\fR is not \fB::\fR, the list returned has
two elements: \fIcommand\fR scoped by \fInamespace\fR, as if it were
a command in the \fInamespace\fR namespace; and \fIcommand\fR as if it
were a command in the global namespace. Otherwise, if either
\fIcommand\fR is absolute (it begins with \fB::\fR), or
\fInamespace\fR is \fB::\fR, the list contains only \fIcommand\fR as
if it were a command in the global namespace.
.RS
.PP
\fBAuto_qualify\fR is used by the auto-loading facilities in Tcl, both
for producing auto-loading indexes such as \fIpkgIndex.tcl\fR, and for
performing the actual auto-loading of functions at runtime.
.RE
.TP
\fBtcl_findLibrary \fIbasename version patch initScript enVarName varName\fR
This is a standard search procedure for use by extensions during
their initialization. They call this procedure to look for their
script library in several standard directories.
The last component of the name of the library directory is
normally \fIbasenameversion\fP
(e.g., tk8.0), but it might be "library" when in the build hierarchies.
The \fIinitScript\fR file will be sourced into the interpreter
once it is found. The directory in which this file is found is
stored into the global variable \fIvarName\fP.
If this variable is already defined (e.g., by C code during
application initialization) then no searching is done.
Otherwise the search looks in these directories:
the directory named by the environment variable \fIenVarName\fP;
relative to the Tcl library directory;
relative to the executable file in the standard installation
bin or bin/\fIarch\fP directory;
relative to the executable file in the current build tree;
relative to the executable file in a parallel build tree.
.TP
\fBparray \fIarrayName\fR
Prints on standard output the names and values of all the elements
in the array \fIarrayName\fR.
\fBArrayName\fR must be an array accessible to the caller of \fBparray\fR.
It may be either local or global.
.TP
\fBtcl_endOfWord \fIstr start\fR
.VS
Returns the index of the first end-of-word location that occurs after
a starting index \fIstart\fR in the string \fIstr\fR. An end-of-word
location is defined to be the first non-word character following the
first word character after the starting point. Returns -1 if there
are no more end-of-word locations after the starting point. See the
description of \fBtcl_wordchars\fR and \fBtcl_nonwordchars\fR below
for more details on how Tcl determines which characters are word
characters.
.TP
\fBtcl_startOfNextWord \fIstr start\fR
Returns the index of the first start-of-word location that occurs
after a starting index \fIstart\fR in the string \fIstr\fR. A
start-of-word location is defined to be the first word character
following a non-word character. Returns \-1 if there are no more
start-of-word locations after the starting point.
.TP
\fBtcl_startOfPreviousWord \fIstr start\fR
Returns the index of the first start-of-word location that occurs
before a starting index \fIstart\fR in the string \fIstr\fR. Returns
\-1 if there are no more start-of-word locations before the starting
point.
.TP
\fBtcl_wordBreakAfter \fIstr start\fR
Returns the index of the first word boundary after the starting index
\fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more
boundaries after the starting point in the given string. The index
returned refers to the second character of the pair that comprises a
boundary.
.TP
\fBtcl_wordBreakBefore \fIstr start\fR
Returns the index of the first word boundary before the starting index
\fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more
boundaries before the starting point in the given string. The index
returned refers to the second character of the pair that comprises a
boundary.
.VE
.SH "VARIABLES"
.PP
The following global variables are defined or used by the procedures in
the Tcl library:
.TP
\fBauto_execs\fR
Used by \fBauto_execok\fR to record information about whether
particular commands exist as executable files.
.TP
\fBauto_index\fR
Used by \fBauto_load\fR to save the index information read from
disk.
.TP
\fBauto_noexec\fR
If set to any value, then \fBunknown\fR will not attempt to auto-exec
any commands.
.TP
\fBauto_noload\fR
If set to any value, then \fBunknown\fR will not attempt to auto-load
any commands.
.TP
\fBauto_path\fR
If set, then it must contain a valid Tcl list giving directories to
search during auto-load operations.
This variable is initialized during startup to contain, in order:
the directories listed in the TCLLIBPATH environment variable,
the directory named by the $tcl_library variable,
the parent directory of $tcl_library,
the directories listed in the $tcl_pkgPath variable.
.TP
\fBenv(TCL_LIBRARY)\fR
If set, then it specifies the location of the directory containing
library scripts (the value of this variable will be
assigned to the \fBtcl_library\fR variable and therefore returned by
the command \fBinfo library\fR). If this variable isn't set then
a default value is used.
.TP
\fBenv(TCLLIBPATH)\fR
If set, then it must contain a valid Tcl list giving directories to
search during auto-load operations. Directories must be specified in
Tcl format, using "/" as the path separator, regardless of platform.
This variable is only used when initializing the \fBauto_path\fR variable.
.TP
\fBtcl_nonwordchars\fR
.VS
This variable contains a regular expression that is used by routines
like \fBtcl_endOfWord\fR to identify whether a character is part of a
word or not. If the pattern matches a character, the character is
considered to be a non-word character. On Windows platforms, spaces,
tabs, and newlines are considered non-word characters. Under Unix,
everything but numbers, letters and underscores are considered
non-word characters.
.TP
\fBtcl_wordchars\fR
This variable contains a regular expression that is used by routines
like \fBtcl_endOfWord\fR to identify whether a character is part of a
word or not. If the pattern matches a character, the character is
considered to be a word character. On Windows platforms, words are
comprised of any character that is not a space, tab, or newline. Under
Unix, words are comprised of numbers, letters or underscores.
.VE
.TP
\fBunknown_pending\fR
Used by \fBunknown\fR to record the command(s) for which it is
searching.
It is used to detect errors where \fBunknown\fR recurses on itself
infinitely.
The variable is unset before \fBunknown\fR returns.
.SH "SEE ALSO"
info(n), re_syntax(n)
.SH KEYWORDS
auto-exec, auto-load, library, unknown, word, whitespace
tcl8.4.20/doc/lsort.n 0000644 0036047 0045461 00000012727 11737050674 013017 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 1999 Scriptics Corporation
'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH lsort n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
lsort \- Sort the elements of a list
.SH SYNOPSIS
\fBlsort \fR?\fIoptions\fR? \fIlist\fR
.BE
.SH DESCRIPTION
.PP
This command sorts the elements of \fIlist\fR, returning a new
list in sorted order. The implementation of the \fBlsort\fR command
uses the merge\-sort algorithm which is a stable sort that has O(n log
n) performance characteristics.
.PP
By default ASCII sorting is used with the result returned in
increasing order. However, any of the following options may be
specified before \fIlist\fR to control the sorting process (unique
abbreviations are accepted):
.TP 20
\fB\-ascii\fR
Use string comparison with Unicode code-point collation order (the
name is for backward-compatibility reasons.) This is the default.
.TP 20
\fB\-dictionary\fR
Use dictionary-style comparison. This is the same as \fB\-ascii\fR
except (a) case is ignored except as a tie-breaker and (b) if two
strings contain embedded numbers, the numbers compare as integers,
not characters. For example, in \fB\-dictionary\fR mode, \fBbigBoy\fR
sorts between \fBbigbang\fR and \fBbigboy\fR, and \fBx10y\fR
sorts between \fBx9y\fR and \fBx11y\fR.
.TP 20
\fB\-integer\fR
Convert list elements to integers and use integer comparison.
.TP 20
\fB\-real\fR
Convert list elements to floating-point values and use floating comparison.
.TP 20
\fB\-command\0\fIcommand\fR
Use \fIcommand\fR as a comparison command.
To compare two elements, evaluate a Tcl script consisting of
\fIcommand\fR with the two elements appended as additional
arguments. The script should return an integer less than,
equal to, or greater than zero if the first element is to
be considered less than, equal to, or greater than the second,
respectively.
.TP 20
\fB\-increasing\fR
Sort the list in increasing order (``smallest'' items first).
This is the default.
.TP 20
\fB\-decreasing\fR
Sort the list in decreasing order (``largest'' items first).
.TP 20
\fB\-index\0\fIindex\fR
If this option is specified, each of the elements of \fIlist\fR must
itself be a proper Tcl sublist. Instead of sorting based on whole
sublists, \fBlsort\fR will extract the \fIindex\fR'th element from
each sublist and sort based on the given element. The keyword
\fBend\fP is allowed for the \fIindex\fP to sort on the last sublist
element,
.VS 8.4
and \fBend-\fIindex\fR sorts on a sublist element offset from
the end.
.VE
For example,
.RS
.CS
lsort -integer -index 1 {{First 24} {Second 18} {Third 30}}
.CE
returns \fB{Second 18} {First 24} {Third 30}\fR, and
.VS 8.4
'\"
'\" This example is from the test suite!
'\"
.CS
lsort -index end-1 {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}}
.CE
returns \fB{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}\fR.
.VE
This option is much more efficient than using \fB\-command\fR
to achieve the same effect.
.RE
.TP 20
\fB\-unique\fR
If this option is specified, then only the last set of duplicate
elements found in the list will be retained. Note that duplicates are
determined relative to the comparison used in the sort. Thus if
\fI-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be
considered duplicates and only the second element, \fB{1 b}\fR, would
be retained.
.SH "NOTES"
.PP
The options to \fBlsort\fR only control what sort of comparison is
used, and do not necessarily constrain what the values themselves
actually are. This distinction is only noticeable when the list to be
sorted has fewer than two elements.
.PP
The \fBlsort\fR command is reentrant, meaning it is safe to use as
part of the implementation of a command used in the \fB\-command\fR
option.
.SH "EXAMPLES"
.PP
Sorting a list using ASCII sorting:
.CS
% \fBlsort\fR {a10 B2 b1 a1 a2}
B2 a1 a10 a2 b1
.CE
.PP
Sorting a list using Dictionary sorting:
.CS
% \fBlsort\fR -dictionary {a10 B2 b1 a1 a2}
a1 a2 a10 b1 B2
.CE
.PP
Sorting lists of integers:
.CS
% \fBlsort\fR -integer {5 3 1 2 11 4}
1 2 3 4 5 11
% \fBlsort\fR -integer {1 2 0x5 7 0 4 -1}
-1 0 1 2 4 0x5 7
.CE
.PP
Sorting lists of floating-point numbers:
.CS
% \fBlsort\fR -real {5 3 1 2 11 4}
1 2 3 4 5 11
% \fBlsort\fR -real {.5 0.07e1 0.4 6e-1}
0.4 .5 6e-1 0.07e1
.CE
.PP
Sorting using indices:
.CS
% # Note the space character before the c
% \fBlsort\fR {{a 5} { c 3} {b 4} {e 1} {d 2}}
{ c 3} {a 5} {b 4} {d 2} {e 1}
% \fBlsort\fR -index 0 {{a 5} { c 3} {b 4} {e 1} {d 2}}
{a 5} {b 4} { c 3} {d 2} {e 1}
% \fBlsort\fR -index 1 {{a 5} { c 3} {b 4} {e 1} {d 2}}
{e 1} {d 2} { c 3} {b 4} {a 5}
.CE
.PP
Stripping duplicate values using sorting:
.CS
% \fBlsort\fR -unique {a b c a b c a b c}
a b c
.CE
.PP
More complex sorting using a comparison function:
.CS
% proc compare {a b} {
set a0 [lindex $a 0]
set b0 [lindex $b 0]
if {$a0 < $b0} {
return -1
} elseif {$a0 > $b0} {
return 1
}
return [string compare [lindex $a 1] [lindex $b 1]]
}
% \fBlsort\fR -command compare \\
{{3 apple} {0x2 carrot} {1 dingo} {2 banana}}
{1 dingo} {2 banana} {0x2 carrot} {3 apple}
.CE
.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lset(n), lrange(n), lreplace(n)
.VE
.SH KEYWORDS
element, list, order, sort
tcl8.4.20/doc/FileSystem.3 0000644 0036047 0045461 00000163157 12052456743 013647 0 ustar dgp 771div '\"
'\" Copyright (c) 2001 Vincent Darley
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Filesystem 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_AllocStatBuf \- procedures to interact with any filesystem
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_FSRegister\fR(\fIclientData, fsPtr\fR)
.sp
int
\fBTcl_FSUnregister\fR(\fIfsPtr\fR)
.sp
ClientData
\fBTcl_FSData\fR(\fIfsPtr\fR)
.sp
void
\fBTcl_FSMountsChanged\fR(\fIfsPtr\fR)
.sp
Tcl_Filesystem*
\fBTcl_FSGetFileSystemForPath\fR(\fIpathObjPtr\fR)
.sp
Tcl_PathType
\fBTcl_FSGetPathType\fR(\fIpathObjPtr\fR)
.sp
int
\fBTcl_FSCopyFile\fR(\fIsrcPathPtr, destPathPtr\fR)
.sp
int
\fBTcl_FSCopyDirectory\fR(\fIsrcPathPtr, destPathPtr, errorPtr\fR)
.sp
int
\fBTcl_FSCreateDirectory\fR(\fIpathPtr\fR)
.sp
int
\fBTcl_FSDeleteFile\fR(\fIpathPtr\fR)
.sp
int
\fBTcl_FSRemoveDirectory\fR(\fIpathPtr, int recursive, errorPtr\fR)
.sp
int
\fBTcl_FSRenameFile\fR(\fIsrcPathPtr, destPathPtr\fR)
.sp
Tcl_Obj*
\fBTcl_FSListVolumes\fR(\fIvoid\fR)
.sp
int
\fBTcl_FSEvalFile\fR(\fIinterp, pathPtr\fR)
.sp
int
\fBTcl_FSLoadFile\fR(\fIinterp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
handlePtr, unloadProcPtr\fR)
.sp
int
\fBTcl_FSMatchInDirectory\fR(\fIinterp, result, pathPtr, pattern, types\fR)
.sp
Tcl_Obj*
\fBTcl_FSLink\fR(\fIlinkNamePtr, toPtr, linkAction\fR)
.sp
int
\fBTcl_FSLstat\fR(\fIpathPtr, statPtr\fR)
.sp
int
\fBTcl_FSUtime\fR(\fIpathPtr, tval\fR)
.sp
int
\fBTcl_FSFileAttrsGet\fR(\fIinterp, int index, pathPtr, objPtrRef\fR)
.sp
int
\fBTcl_FSFileAttrsSet\fR(\fIinterp, int index, pathPtr, Tcl_Obj *objPtr\fR)
.sp
CONST char**
\fBTcl_FSFileAttrStrings\fR(\fIpathPtr, objPtrRef\fR)
.sp
int
\fBTcl_FSStat\fR(\fIpathPtr, statPtr\fR)
.sp
int
\fBTcl_FSAccess\fR(\fIpathPtr, mode\fR)
.sp
Tcl_Channel
\fBTcl_FSOpenFileChannel\fR(\fIinterp, pathPtr, modeString, permissions\fR)
.sp
Tcl_Obj*
\fBTcl_FSGetCwd\fR(\fIinterp\fR)
.sp
int
\fBTcl_FSChdir\fR(\fIpathPtr\fR)
.sp
Tcl_Obj*
\fBTcl_FSPathSeparator\fR(\fIpathPtr\fR)
.sp
Tcl_Obj*
\fBTcl_FSJoinPath\fR(\fIlistObj, elements\fR)
.sp
Tcl_Obj*
\fBTcl_FSSplitPath\fR(\fIpathPtr, lenPtr\fR)
.sp
int
\fBTcl_FSEqualPaths\fR(\fIfirstPtr, secondPtr\fR)
.sp
Tcl_Obj*
\fBTcl_FSGetNormalizedPath\fR(\fIinterp, pathPtr\fR)
.sp
Tcl_Obj*
\fBTcl_FSJoinToPath\fR(\fIbasePtr, objc, objv\fR)
.sp
int
\fBTcl_FSConvertToPathType\fR(\fIinterp, pathPtr\fR)
.sp
ClientData
\fBTcl_FSGetInternalRep\fR(\fIpathPtr, fsPtr\fR)
.sp
Tcl_Obj*
\fBTcl_FSGetTranslatedPath\fR(\fIinterp, pathPtr\fR)
.sp
CONST char*
\fBTcl_FSGetTranslatedStringPath\fR(\fIinterp, pathPtr\fR)
.sp
Tcl_Obj*
\fBTcl_FSNewNativePath\fR(\fIfsPtr, clientData\fR)
.sp
CONST char*
\fBTcl_FSGetNativePath\fR(\fIpathPtr\fR)
.sp
Tcl_Obj*
\fBTcl_FSFileSystemInfo\fR(\fIpathPtr\fR)
.sp
Tcl_StatBuf*
\fBTcl_AllocStatBuf\fR()
.SH ARGUMENTS
.AS Tcl_Filesystem *fsPtr in
.AP Tcl_Filesystem *fsPtr in
Points to a structure containing the addresses of procedures that
can be called to perform the various filesystem operations.
.AP Tcl_Obj *pathPtr in
The path represented by this object is used for the operation in
question. If the object does not already have an internal \fBpath\fR
representation, it will be converted to have one.
.AP Tcl_Obj *srcPathPtr in
As for \fBpathPtr\fR, but used for the source file for a copy or
rename operation.
.AP Tcl_Obj *destPathPtr in
As for \fBpathPtr\fR, but used for the destination filename for a copy or
rename operation.
.AP "CONST char" *pattern in
Only files or directories matching this pattern will be returned by
\fBTcl_FSMatchInDirectory\fR.
.AP GlobTypeData *types in
Only files or directories matching the type descriptions contained in
this structure will be returned by \fBTcl_FSMatchInDirectory\fR. It
is very important that the 'directory' flag is properly handled.
This parameter may be NULL.
.AP Tcl_Interp *interp in
Interpreter to use either for results, evaluation, or reporting error
messages.
.AP ClientData clientData in
The native description of the path object to create.
.AP Tcl_Obj *firstPtr in
The first of two path objects to compare. The object may be converted
to \fBpath\fR type.
.AP Tcl_Obj *secondPtr in
The second of two path objects to compare. The object may be converted
to \fBpath\fR type.
.AP Tcl_Obj *listObj in
The list of path elements to operate on with a \fBjoin\fR operation.
.AP int elements in
If non-negative, the number of elements in the listObj which should
be joined together. If negative, then all elements are joined.
.AP Tcl_Obj **errorPtr out
In the case of an error, filled with an object containing the name of
the file which caused an error in the various copy/rename operations.
.AP Tcl_Obj **objPtrRef out
Filled with an object containing the result of the operation.
.AP Tcl_Obj *result out
Pre-allocated object in which to store (by lappending) the list of
files or directories which are successfully matched in
\fBTcl_FSMatchInDirectory\fR.
.AP int mode in
Mask consisting of one or more of R_OK, W_OK, X_OK and F_OK. R_OK,
W_OK and X_OK request checking whether the file exists and has read,
write and execute permissions, respectively. F_OK just requests
checking for the existence of the file.
.AP Tcl_StatBuf *statPtr out
The structure that contains the result of a stat or lstat operation.
.AP "CONST char" *sym1 in
Name of a procedure to look up in the file's symbol table
.AP "CONST char" *sym2 in
Name of a procedure to look up in the file's symbol table
.AP Tcl_PackageInitProc **proc1Ptr out
Filled with the init function for this code.
.AP Tcl_PackageInitProc **proc2Ptr out
Filled with the safe-init function for this code.
.AP Tcl_LoadHandle *handlePtr out
Filled with an abstract token representing the loaded file.
.AP ClientData *clientDataPtr out
Filled with the clientData value to pass to this code's unload
function when it is called.
.AP TclfsUnloadFileProc_ **unloadProcPtr out
Filled with the function to use to unload this piece of code.
.AP utimbuf *tval in
The access and modification times in this structure are read and
used to set those values for a given file.
.AP "CONST char" *modeString in
Specifies how the file is to be accessed. May have any of the values
allowed for the \fImode\fR argument to the Tcl \fBopen\fR command.
.AP int permissions in
POSIX-style permission flags such as 0644. If a new file is created, these
permissions will be set on the created file.
.AP int *lenPtr out
If non-NULL, filled with the number of elements in the split path.
.AP Tcl_Obj *basePtr in
The base path on to which to join the given elements. May be NULL.
.AP int objc in
The number of elements in \fIobjv\fR.
.AP "Tcl_Obj *CONST" objv[] in
The elements to join to the given base path.
.BE
.SH DESCRIPTION
.PP
There are several reasons for calling the \fBTcl_FS...\fR functions
rather than calling system level functions like \fBaccess\fR and
\fBstat\fR directly. First, they will work cross-platform, so an
extension which calls them should work unmodified on Unix, MacOS and
Windows. Second, the Windows implementation of some of these functions
fixes some bugs in the system level calls. Third, these function calls
deal with any 'Utf to platform-native' path conversions which may be
required (and may cache the results of such conversions for greater
efficiency on subsequent calls). Fourth, and perhaps most importantly,
all of these functions are 'virtual filesystem aware'. Any virtual
filesystem which has been registered (through
\fBTcl_FSRegister\fR) may reroute file access to alternative
media or access methods. This means that all of these functions (and
therefore the corresponding \fBfile\fR, \fBglob\fR, \fBpwd\fR, \fBcd\fR,
\fBopen\fR, etc. Tcl commands) may be operate on 'files' which are not
native files in the native filesystem. This also means that any Tcl
extension which accesses the filesystem through this API is
automatically 'virtual filesystem aware'. Of course, if an extension
accesses the native filesystem directly (through platform-specific
APIs, for example), then Tcl cannot intercept such calls.
.PP
If appropriate vfs's have been registered, the 'files' may, to give two
examples, be remote (e.g. situated on a remote ftp server) or archived
(e.g. lying inside a .zip archive). Such registered filesystems provide
a lookup table of functions to implement all or some of the functionality
listed here. Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls
abstract away from what the 'struct stat' buffer buffer is actually
declared to be, allowing the same code to be used both on systems with
and systems without support for files larger than 2GB in size.
.PP
The \fBTcl_FS...\fR are objectified and may cache internal
representations and other path-related strings (e.g. the current working
directory). One side-effect of this is that one must not pass in objects
with a refCount of zero to any of these functions. If such calls were
handled, they might result
in memory leaks (under some circumstances, the filesystem code may wish
to retain a reference to the passed in object, and so one must not assume
that after any of these calls return, the object still has a refCount of
zero - it may have been incremented), or in a direct segfault
due to the object being freed part way through the complex object
manipulation required to ensure that the path is fully normalized and
absolute for filesystem determination. The practical lesson to learn
from this is that \fBTcl_Obj *path = Tcl_NewStringObj(...) ;
Tcl_FS...(path) ; Tcl_DecrRefCount(path)\fR is wrong, and may segfault.
The 'path' must have its refCount incremented before passing it in, or
decrementing it. For this reason, objects with a refCount of zero are
considered not to be valid filesystem paths and calling any Tcl_FS API
with such an object will result in no action being taken.
.PP
\fBTcl_FSCopyFile\fR attempts to copy the file given by srcPathPtr to the
path name given by destPathPtr. If the two paths given lie in the same
filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that
filesystem's 'copy file' function is called (if it is non-NULL).
Otherwise the function returns -1 and sets Tcl's errno to the 'EXDEV'
posix error code (which signifies a 'cross-domain link').
.PP
\fBTcl_FSCopyDirectory\fR attempts to copy the directory given by srcPathPtr to the
path name given by destPathPtr. If the two paths given lie in the same
filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that
filesystem's 'copy file' function is called (if it is non-NULL).
Otherwise the function returns -1 and sets Tcl's errno to the 'EXDEV'
posix error code (which signifies a 'cross-domain link').
.PP
\fBTcl_FSCreateDirectory\fR attempts to create the directory given by
pathPtr by calling the owning filesystem's 'create directory'
function.
.PP
\fBTcl_FSDeleteFile\fR attempts to delete the file given by
pathPtr by calling the owning filesystem's 'delete file'
function.
.PP
\fBTcl_FSRemoveDirectory\fR attempts to remove the directory given by
pathPtr by calling the owning filesystem's 'remove directory'
function.
.PP
\fBTcl_FSRenameFile\fR attempts to rename the file or directory given by
srcPathPtr to the path name given by destPathPtr. If the two paths
given lie in the same filesystem (according to
\fBTcl_FSGetFileSystemForPath\fR) then that filesystem's 'rename file'
function is called (if it is non-NULL). Otherwise the function returns -1
and sets Tcl's errno to the 'EXDEV' posix error code (which signifies
a ``cross-domain link'').
.PP
\fBTcl_FSListVolumes\fR calls each filesystem which has a non-NULL 'list
volumes' function and asks them to return their list of root volumes. It
accumulates the return values in a list which is returned to the
caller (with a refCount of 0).
.PP
\fBTcl_FSEvalFile\fR reads the file given by \fIpathPtr\fR and evaluates
its contents as a Tcl script. It returns the same information as
\fBTcl_EvalObjEx\fR.
If the file couldn't be read then a Tcl error is returned to describe
why the file couldn't be read.
The eofchar for files is '\\32' (^Z) for all platforms.
If you require a ``^Z'' in code for string comparison, you can use
``\\032'' or ``\\u001a'', which will be safely substituted by the Tcl
interpreter into ``^Z''.
.PP
\fBTcl_FSLoadFile\fR dynamically loads a binary code file into memory and
returns the addresses of two procedures within that file, if they are
defined. The appropriate function for the filesystem to which pathPtr
belongs will be called. If that filesystem does not implement this
function (most virtual filesystems will not, because of OS limitations
in dynamically loading binary code), Tcl will attempt to copy the file
to a temporary directory and load that temporary file.
.PP
Returns a standard Tcl completion code. If an error occurs, an error
message is left in the interp's result.
.PP
\fBTcl_FSMatchInDirectory\fR is used by the globbing code to search a
directory for all files which match a given pattern. The appropriate
function for the filesystem to which pathPtr belongs will be called.
.PP
The return value is a standard Tcl result indicating whether an error
occurred in globbing. Error messages are placed in interp, but good
results are placed in the resultPtr given.
Note that the 'glob' code implements recursive patterns internally, so
this function will only ever be passed simple patterns, which can be
matched using the logic of 'string match'. To handle recursion, Tcl
will call this function frequently asking only for directories to be
returned.
.PP
\fBTcl_FSLink\fR replaces the library version of readlink(), and
extends it to support the creation of links. The appropriate function
for the filesystem to which linkNamePtr belongs will be called.
.PP
If the \fItoPtr\fR is NULL, a readlink action is performed. The result
is a Tcl_Obj specifying the contents of the symbolic link given by
\fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned
by the caller, which should call Tcl_DecrRefCount when the result is no
longer needed. If the \fItoPtr\fR is not NULL, Tcl should create a link
of one of the types passed in in the \fIlinkAction\fR flag. This flag is
an or'd combination of TCL_CREATE_SYMBOLIC_LINK and TCL_CREATE_HARD_LINK.
Where a choice exists (i.e. more than one flag is passed in), the Tcl
convention is to prefer symbolic links. When a link is successfully
created, the return value should be \fItoPtr\fR (which is therefore
already owned by the caller). If unsuccessful, NULL should be
returned.
.PP
\fBTcl_FSLstat\fR fills the stat structure \fIstatPtr\fR with information
about the specified file. You do not need any access rights to the
file to get this information but you need search rights to all
directories named in the path leading to the file. The stat structure
includes info regarding device, inode (always 0 on Windows),
privilege mode, nlink (always 1 on Windows), user id (always 0 on
Windows), group id (always 0 on Windows), rdev (same as device on
Windows), size, last access time, last modification time, and
last metadata change time.
.PP
If \fIpath\fR exists, \fBTcl_FSLstat\fR returns 0 and the stat structure
is filled with data. Otherwise, -1 is returned, and no stat info is
given.
.PP
\fBTcl_FSUtime\fR replaces the library version of utime.
.PP
For results see 'utime' documentation. If successful, the function
will update the 'atime' and 'mtime' values of the file given.
.PP
\fBTcl_FSFileAttrsGet\fR implements read access for the hookable 'file
attributes' subcommand. The appropriate function for the filesystem to
which pathPtr belongs will be called.
.PP
If the result is TCL_OK, then an object was placed in objPtrRef, which
will only be temporarily valid (unless Tcl_IncrRefCount is called).
.PP
\fBTcl_FSFileAttrsSet\fR implements write access for the hookable 'file
attributes' subcommand. The appropriate function for the filesystem to
which pathPtr belongs will be called.
.PP
\fBTcl_FSFileAttrStrings\fR implements part of the hookable 'file attributes'
subcommand. The appropriate function for the filesystem to which
pathPtr belongs will be called.
.PP
The called procedure may either return an array of strings, or may
instead return NULL and place a Tcl list into the given objPtrRef. Tcl
will take that list and first increment its refCount before using it.
On completion of that use, Tcl will decrement its refCount. Hence if
the list should be disposed of by Tcl when done, it should have a
refCount of zero, and if the list should not be disposed of, the
filesystem should ensure it retains a refCount on the object.
.PP
\fBTcl_FSAccess\fR checks whether the process would be allowed to read,
write or test for existence of the file (or other file system object)
whose name is pathname. If pathname is a symbolic link on Unix,
then permissions of the file referred by this symbolic link are
tested.
.PP
On success (all requested permissions granted), zero is returned. On
error (at least one bit in mode asked for a permission that is denied,
or some other error occurred), -1 is returned.
.PP
\fBTcl_FSStat\fR fills the stat structure \fIstatPtr\fR with information
about the specified file. You do not need any access rights to the
file to get this information but you need search rights to all
directories named in the path leading to the file. The stat structure
includes info regarding device, inode (always 0 on Windows),
privilege mode, nlink (always 1 on Windows), user id (always 0 on
Windows), group id (always 0 on Windows), rdev (same as device on
Windows), size, last access time, last modification time, and
last metadata change time.
.PP
If \fIpath\fR exists, \fBTcl_FSStat\fR returns 0 and the stat structure
is filled with data. Otherwise, -1 is returned, and no stat info is
given.
.PP
\fBTcl_FSOpenFileChannel\fR opens a file specified by \fIpathPtr\fR and
returns a channel handle that can be used to perform input and output on
the file. This API is modeled after the \fBfopen\fR procedure of
the Unix standard I/O library.
The syntax and meaning of all arguments is similar to those
given in the Tcl \fBopen\fR command when opening a file.
If an error occurs while opening the channel, \fBTcl_FSOpenFileChannel\fR
returns NULL and records a POSIX error code that can be
retrieved with \fBTcl_GetErrno\fR.
In addition, if \fIinterp\fR is non-NULL, \fBTcl_FSOpenFileChannel\fR
leaves an error message in \fIinterp\fR's result after any error.
.PP
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR.
If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.
.PP
\fBTcl_FSGetCwd\fR replaces the library version of getcwd().
.PP
It returns the Tcl library's current working directory. This may be
different to the native platform's working directory, in the case for
which the cwd is not in the native filesystem.
.PP
The result is a pointer to a Tcl_Obj specifying the current directory,
or NULL if the current directory could not be determined. If NULL is
returned, an error message is left in the interp's result.
The result already has its refCount incremented for the caller. When
it is no longer needed, that refCount should be decremented. This is
needed for thread-safety purposes, to allow multiple threads to access
this and related functions, while ensuring the results are always
valid.
.PP
\fBTcl_FSChdir\fR replaces the library version of chdir(). The path is
normalized and then passed to the filesystem which claims it. If that
filesystem does not implement this function, Tcl will fallback to a
combination of stat and access to check whether the directory exists
and has appropriate permissions.
.PP
For results, see chdir() documentation. If successful, we keep a
record of the successful path in cwdPathPtr for subsequent calls to
getcwd.
.PP
\fBTcl_FSPathSeparator\fR returns the separator character to be used for
most specific element of the path specified by pathPtr (i.e. the last
part of the path).
.PP
The separator is returned as a Tcl_Obj containing a string of length
1. If the path is invalid, NULL is returned.
.PP
\fBTcl_FSJoinPath\fR takes the given Tcl_Obj, which should be a valid list,
and returns the path object given by considering the first 'elements'
elements as valid path segments. If elements < 0, we use the entire
list.
.PP
Returns object with refCount of zero, containing the joined path.
.PP
\fBTcl_FSSplitPath\fR takes the given Tcl_Obj, which should be a valid path,
and returns a Tcl List object containing each segment of that path as
an element.
.PP
Returns list object with refCount of zero. If the passed in lenPtr is
non-NULL, we use it to return the number of elements in the returned
list.
.PP
\fBTcl_FSEqualPaths\fR tests whether the two paths given represent the same
filesystem object
.PP
It returns 1 if the paths are equal, and 0 if they are different. If
either path is NULL, 0 is always returned.
.PP
\fBTcl_FSGetNormalizedPath\fR this important function attempts to extract
from the given Tcl_Obj a unique normalized path representation, whose
string value can be used as a unique identifier for the file.
.PP
It returns the normalized path object, with refCount of zero, or NULL
if the path was invalid or could otherwise not be successfully
converted. Extraction of absolute, normalized paths is very
efficient (because the filesystem operates on these representations
internally), although the result when the filesystem contains
numerous symbolic links may not be the most user-friendly
version of a path.
.PP
\fBTcl_FSJoinToPath\fR takes the given object, which should usually be a
valid path or NULL, and joins onto it the array of paths segments
given.
.PP
Returns object with refCount of zero, containing the joined path.
.PP
\fBTcl_FSConvertToPathType\fR tries to convert the given Tcl_Obj to a valid
Tcl path type, taking account of the fact that the cwd may have changed
even if this object is already supposedly of the correct type.
The filename may begin with "~" (to indicate current user's home
directory) or "~" (to indicate any user's home directory).
.PP
If the conversion succeeds (i.e. the object is a valid path in one of
the current filesystems), then TCL_OK is returned. Otherwise
TCL_ERROR is returned, and an error message may
be left in the interpreter.
.PP
\fBTcl_FSGetInternalRep\fR extracts the internal representation of a given
path object, in the given filesystem. If the path object belongs to a
different filesystem, we return NULL. If the internal representation is
currently NULL, we attempt to generate it, by calling the filesystem's
\fBTcl_FSCreateInternalRepProc\fR.
.PP
Returns NULL or a valid internal path representation. This internal
representation is cached, so that repeated calls to this function will
not require additional conversions.
.PP
\fBTcl_FSGetTranslatedPath\fR attempts to extract the translated path
from the given Tcl_Obj.
.PP
If the translation succeeds (i.e. the object is a valid path), then it is
returned. Otherwise NULL will be returned, and an error message may be
left in the interpreter. A "translated" path is one which contains no
"~" or "~user" sequences (these have been expanded to their current
representation in the filesystem). The object returned is owned by the
caller, which must store it or call Tcl_DecrRefCount to ensure memory is
freed. This function is of little practical use, and
\fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\fR are usually
better functions to use for most purposes.
.PP
\fBTcl_FSGetTranslatedStringPath\fR does the same as
\fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL.
The string returned is dynamically allocated and owned by the caller,
which must store it or call ckfree to ensure it is freed. Again,
\fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\fR are usually
better functions to use for most purposes.
.PP
\fBTcl_FSNewNativePath\fR performs something like that reverse of the
usual obj->path->nativerep conversions. If some code retrieves a path
in native form (from, e.g. readlink or a native dialog), and that path
is to be used at the Tcl level, then calling this function is an
efficient way of creating the appropriate path object type.
.PP
The resulting object is a pure 'path' object, which will only receive
a Utf-8 string representation if that is required by some Tcl code.
.PP
\fBTcl_FSGetNativePath\fR is for use by the Win/Unix/MacOS native
filesystems, so that they can easily retrieve the native (char* or
TCHAR*) representation of a path. This function is a convenience
wrapper around \fBTcl_FSGetInternalRep\fR, and assumes the native
representation is string-based. It may be desirable in the future
to have non-string-based native representations (for example, on
MacOS, a representation using a fileSpec of FSRef structure would
probably be more efficient). On Windows a full Unicode
representation would allow for paths of unlimited length. Currently
the representation is simply a character string containing the
complete, absolute path in the native encoding.
.PP
The native representation is cached so that repeated calls to this
function will not require additional conversions.
.PP
\fBTcl_FSFileSystemInfo\fR returns a list of two elements. The first
element is the name of the filesystem (e.g. "native" or "vfs" or "zip"
or "prowrap", perhaps), and the second is the particular type of the
given path within that filesystem (which is filesystem dependent). The
second element may be empty if the filesystem does not provide a
further categorization of files.
.PP
A valid list object is returned, unless the path object is not
recognized, when NULL will be returned.
.PP
\fBTcl_FSGetFileSystemForPath\fR returns the a pointer to the
\fBTcl_Filesystem\fR which accepts this path as valid.
.PP
If no filesystem will accept the path, NULL is returned.
.PP
\fBTcl_FSGetPathType\fR determines whether the given path is relative
to the current directory, relative to the current volume, or
absolute.
.PP
It returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
TCL_PATH_VOLUME_RELATIVE
.PP
\fBTcl_AllocStatBuf\fR allocates a \fITcl_StatBuf\fR on the system
heap (which may be deallocated by being passed to \fBckfree\fR.) This
allows extensions to invoke \fBTcl_FSStat\fR and \fBTcl_FSLStat\fR
without being dependent on the size of the buffer. That in turn
depends on the flags used to build Tcl.
.PP
.SH TCL_FILESYSTEM
.PP
A filesystem provides a \fBTcl_Filesystem\fR structure that contains
pointers to functions that implement the various operations on a
filesystem; these operations are invoked as needed by the generic
layer, which generally occurs through the functions listed above.
.PP
The \fBTcl_Filesystem\fR structures are manipulated using the following
methods.
.PP
\fBTcl_FSRegister\fR takes a pointer to a filesystem structure and an
optional piece of data to associated with that filesystem. On calling
this function, Tcl will attach the filesystem to the list of known
filesystems, and it will become fully functional immediately. Tcl does
not check if the same filesystem is registered multiple times (and in
general that is not a good thing to do). TCL_OK will be returned.
.PP
\fBTcl_FSUnregister\fR removes the given filesystem structure from
the list of known filesystems, if it is known, and returns TCL_OK. If
the filesystem is not currently registered, TCL_ERROR is returned.
.PP
\fBTcl_FSData\fR will return the ClientData associated with the given
filesystem, if that filesystem is registered. Otherwise it will
return NULL.
.PP
\fBTcl_FSMountsChanged\fR is used to inform the Tcl's core that
the set of mount points for the given (already registered) filesystem
have changed, and that cached file representations may therefore no
longer be correct.
.PP
The \fBTcl_Filesystem\fR structure contains the following fields:
.CS
typedef struct Tcl_Filesystem {
CONST char *\fItypeName\fR;
int \fIstructureLength\fR;
Tcl_FSVersion \fIversion\fR;
Tcl_FSPathInFilesystemProc *\fIpathInFilesystemProc\fR;
Tcl_FSDupInternalRepProc *\fIdupInternalRepProc\fR;
Tcl_FSFreeInternalRepProc *\fIfreeInternalRepProc\fR;
Tcl_FSInternalToNormalizedProc *\fIinternalToNormalizedProc\fR;
Tcl_FSCreateInternalRepProc *\fIcreateInternalRepProc\fR;
Tcl_FSNormalizePathProc *\fInormalizePathProc\fR;
Tcl_FSFilesystemPathTypeProc *\fIfilesystemPathTypeProc\fR;
Tcl_FSFilesystemSeparatorProc *\fIfilesystemSeparatorProc\fR;
Tcl_FSStatProc *\fIstatProc\fR;
Tcl_FSAccessProc *\fIaccessProc\fR;
Tcl_FSOpenFileChannelProc *\fIopenFileChannelProc\fR;
Tcl_FSMatchInDirectoryProc *\fImatchInDirectoryProc\fR;
Tcl_FSUtimeProc *\fIutimeProc\fR;
Tcl_FSLinkProc *\fIlinkProc\fR;
Tcl_FSListVolumesProc *\fIlistVolumesProc\fR;
Tcl_FSFileAttrStringsProc *\fIfileAttrStringsProc\fR;
Tcl_FSFileAttrsGetProc *\fIfileAttrsGetProc\fR;
Tcl_FSFileAttrsSetProc *\fIfileAttrsSetProc\fR;
Tcl_FSCreateDirectoryProc *\fIcreateDirectoryProc\fR;
Tcl_FSRemoveDirectoryProc *\fIremoveDirectoryProc\fR;
Tcl_FSDeleteFileProc *\fIdeleteFileProc\fR;
Tcl_FSCopyFileProc *\fIcopyFileProc\fR;
Tcl_FSRenameFileProc *\fIrenameFileProc\fR;
Tcl_FSCopyDirectoryProc *\fIcopyDirectoryProc\fR;
Tcl_FSLstatProc *\fIlstatProc\fR;
Tcl_FSLoadFileProc *\fIloadFileProc\fR;
Tcl_FSGetCwdProc *\fIgetCwdProc\fR;
Tcl_FSChdirProc *\fIchdirProc\fR;
} Tcl_Filesystem;
.CE
.PP
Except for the first three fields in this structure which contain
simple data elements, all entries contain addresses of functions called
by the generic filesystem layer to perform the complete range of
filesystem related actions.
.PP
The many functions in this structure are broken down into three
categories: infrastructure functions (almost all of which must be
implemented), operational functions (which must be implemented if a
complete filesystem is provided), and efficiency functions (which need
only be implemented if they can be done so efficiently, or if they have
side-effects which are required by the filesystem; Tcl has less
efficient emulations it can fall back on). It is important to note
that, in the current version of Tcl, most of these fallbacks are only
used to handle commands initiated in Tcl, not in C. What this means is,
that if a 'file rename' command is issued in Tcl, and the relevant
filesystem(s) do not implement their \fITcl_FSRenameFileProc\fR, Tcl's
core will instead fallback on a combination of other filesystem
functions (it will use \fITcl_FSCopyFileProc\fR followed by
\fITcl_FSDeleteFileProc\fR, and if \fITcl_FSCopyFileProc\fR is not
implemented there is a further fallback). However, if a
\fITcl_FSRenameFile\fR command is issued at the C level, no such
fallbacks occur. This is true except for the last four entries in the
filesystem table (lstat, load, getcwd and chdir)
for which fallbacks do in fact occur at the C level.
.PP
As an example, here is the filesystem lookup table used by the
"vfs" extension which allows filesystem actions to be implemented
in Tcl.
.CS
static Tcl_Filesystem vfsFilesystem = {
"tclvfs",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
&VfsPathInFilesystem,
&VfsDupInternalRep,
&VfsFreeInternalRep,
/* No internal to normalized, since we don't create any
* pure 'internal' Tcl_Obj path representations */
NULL,
/* No create native rep function, since we don't use it
* and don't choose to support uses of 'Tcl_FSNewNativePath' */
NULL,
/* Normalize path isn't needed - we assume paths only have
* one representation */
NULL,
&VfsFilesystemPathType,
&VfsFilesystemSeparator,
&VfsStat,
&VfsAccess,
&VfsOpenFileChannel,
&VfsMatchInDirectory,
&VfsUtime,
/* We choose not to support symbolic links inside our vfs's */
NULL,
&VfsListVolumes,
&VfsFileAttrStrings,
&VfsFileAttrsGet,
&VfsFileAttrsSet,
&VfsCreateDirectory,
&VfsRemoveDirectory,
&VfsDeleteFile,
/* No copy file - fallback will occur at Tcl level */
NULL,
/* No rename file - fallback will occur at Tcl level */
NULL,
/* No copy directory - fallback will occur at Tcl level */
NULL,
/* Core will use stat for lstat */
NULL,
/* No load - fallback on core implementation */
NULL,
/* We don't need a getcwd or chdir - fallback on Tcl's versions */
NULL,
NULL
};
.CE
.PP
Any functions which take path names in Tcl_Obj form take
those names in UTF\-8 form. The filesystem infrastructure API is
designed to support efficient, cached conversion of these UTF\-8 paths
to other native representations.
.SH TYPENAME
.PP
The \fItypeName\fR field contains a null-terminated string that
identifies the type of the filesystem implemented, e.g.
\fBnative\fR or \fBzip\fR or \fBvfs\fR.
.PP
.SH "STRUCTURE LENGTH"
.PP
The \fIstructureLength\fR field is generally implemented as
\fIsizeof(Tcl_Filesystem)\fR, and is there to allow easier
binary backwards compatibility if the size of the structure
changes in a future Tcl release.
.SH VERSION
.PP
The \fIversion\fR field should be set to \fBTCL_FILESYSTEM_VERSION_1\fR.
.SH "FILESYSTEM INFRASTRUCTURE"
.PP
These fields contain addresses of functions which are used to associate
a particular filesystem with a file path, and deal with the internal
handling of path representations, for example copying and freeing such
representations.
.SH PATHINFILESYSTEMPROC
.PP
The \fIpathInFilesystemProc\fR field contains the address of a function
which is called to determine whether a given path object belongs to this
filesystem or not. Tcl will only call the rest of the filesystem
functions with a path for which this function has returned \fBTCL_OK\fR.
If the path does not belong, -1 should be returned (the behaviour of Tcl
for any other return value is not defined). If \fBTCL_OK\fR is returned,
then the optional \fBclientDataPtr\fR output parameter can be used to
return an internal (filesystem specific) representation of the path,
which will be cached inside the path object, and may be retrieved
efficiently by the other filesystem functions. Tcl will simultaneously
cache the fact that this path belongs to this filesystem. Such caches
are invalidated when filesystem structures are added or removed from
Tcl's internal list of known filesystems.
.PP
.CS
typedef int Tcl_FSPathInFilesystemProc(
Tcl_Obj *\fIpathPtr\fR,
ClientData *\fIclientDataPtr\fR);
.CE
.SH DUPINTERNALREPPROC
.PP
This function makes a copy of a path's internal representation, and is
called when Tcl needs to duplicate a path object. If NULL, Tcl will
simply not copy the internal representation, which may then need to be
regenerated later.
.PP
.CS
typedef ClientData Tcl_FSDupInternalRepProc(
ClientData \fIclientData\fR);
.CE
.SH FREEINTERNALREPPROC
Free the internal representation. This must be implemented if internal
representations need freeing (i.e. if some memory is allocated when an
internal representation is generated), but may otherwise be NULL.
.PP
.CS
typedef void Tcl_FSFreeInternalRepProc(
ClientData \fIclientData\fR);
.CE
.SH INTERNALTONORMALIZEDPROC
.PP
Function to convert internal representation to a normalized path. Only
required if the filesystem creates pure path objects with no string/path
representation. The return value is a Tcl object whose string
representation is the normalized path.
.PP
.CS
typedef Tcl_Obj* Tcl_FSInternalToNormalizedProc(
ClientData \fIclientData\fR);
.CE
.SH CREATEINTERNALREPPROC
.PP
Function to take a path object, and calculate an internal
representation for it, and store that native representation in the
object. May be NULL if paths have no internal representation, or if
the \fITcl_FSPathInFilesystemProc\fR for this filesystem always
immediately creates an internal representation for paths it accepts.
.PP
.CS
typedef ClientData Tcl_FSCreateInternalRepProc(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SH NORMALIZEPATHPROC
.PP
Function to normalize a path. Should be implemented for all
filesystems which can have multiple string representations for the same
path object. In Tcl, every 'path' must have a single unique 'normalized'
string representation. Depending on the filesystem,
there may be more than one unnormalized string representation which
refers to that path (e.g. a relative path, a path with different
character case if the filesystem is case insensitive, a path contain a
reference to a home directory such as '~', a path containing symbolic
links, etc). If the very last component in the path is a symbolic
link, it should not be converted into the object it points to (but
its case or other aspects should be made unique). All other path
components should be converted from symbolic links. This one
exception is required to agree with Tcl's semantics with 'file
delete', 'file rename', 'file copy' operating on symbolic links.
This function may be called with 'nextCheckpoint' either
at the beginning of the path (i.e. zero), at the end of the path, or
at any intermediate file separator in the path. It will never
point to any other arbitrary position in the path. In the last of
the three valid cases, the implementation can assume that the path
up to and including the file separator is known and normalized.
.PP
.CS
typedef int Tcl_FSNormalizePathProc(
Tcl_Interp *\fIinterp\fR,
Tcl_Obj *\fIpathPtr\fR,
int \fInextCheckpoint\fR);
.CE
.SH "FILESYSTEM OPERATIONS"
.PP
The fields in this section of the structure contain addresses of
functions which are called to carry out the basic filesystem
operations. A filesystem which expects to be used with the complete
standard Tcl command set must implement all of these. If some of
them are not implemented, then certain Tcl commands may fail when
operating on paths within that filesystem. However, in some instances
this may be desirable (for example, a read-only filesystem should not
implement the last four functions, and a filesystem which does not
support symbolic links need not implement the \fBreadlink\fR function,
etc. The Tcl core expects filesystems to behave in this way).
.SH FILESYSTEMPATHTYPEPROC
.PP
Function to determine the type of a path in this filesystem. May be
NULL, in which case no type information will be available to users of
the filesystem. The 'type' is used only for informational purposes,
and should be returned as the string representation of the Tcl_Obj
which is returned. A typical return value might be "networked", "zip"
or "ftp". The Tcl_Obj result is owned by the filesystem and so Tcl will
increment the refCount of that object if it wishes to retain a reference
to it.
.PP
.CS
typedef Tcl_Obj* Tcl_FSFilesystemPathTypeProc(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SH FILESYSTEMSEPARATORPROC
.PP
Function to return the separator character(s) for this filesystem.
Must be implemented, otherwise the \fBfile separator\fR command will not
function correctly. The usual return value will be a Tcl_Obj
containing the string "/".
.PP
.CS
typedef Tcl_Obj* Tcl_FSFilesystemSeparatorProc(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SH STATPROC
.PP
Function to process a \fBTcl_FSStat()\fR call. Must be implemented for any
reasonable filesystem, since many Tcl level commands depend crucially
upon it (e.g. \fBfile atime\fR, \fBfile isdirectory\fR, \fBfile size\fR,
\fBglob\fR).
.PP
.CS
typedef int Tcl_FSStatProc(
Tcl_Obj *\fIpathPtr\fR,
Tcl_StatBuf *\fIstatPtr\fR);
.CE
.PP
The \fBTcl_FSStatProc\fR fills the stat structure \fIstatPtr\fR with
information about the specified file. You do not need any access
rights to the file to get this information but you need search rights
to all directories named in the path leading to the file. The stat
structure includes info regarding device, inode (always 0 on Windows),
privilege mode, nlink (always 1 on Windows), user id (always 0 on
Windows), group id (always 0 on Windows), rdev (same as device on
Windows), size, last access time, last modification time, and
last metadata change time.
.PP
If the file represented by \fIpathPtr\fR exists, the
\fBTcl_FSStatProc\fR returns 0 and the stat structure is filled with
data. Otherwise, -1 is returned, and no stat info is given.
.SH ACCESSPROC
.PP
Function to process a \fBTcl_FSAccess()\fR call. Must be implemented for
any reasonable filesystem, since many Tcl level commands depend crucially
upon it (e.g. \fBfile exists\fR, \fBfile readable\fR).
.PP
.CS
typedef int Tcl_FSAccessProc(
Tcl_Obj *\fIpathPtr\fR,
int \fImode\fR);
.CE
.PP
The \fBTcl_FSAccessProc\fR checks whether the process would be allowed
to read, write or test for existence of the file (or other file system
object) whose name is pathname. If pathname is a symbolic link, then
permissions of the file referred by this symbolic link should be tested.
.PP
On success (all requested permissions granted), zero is returned. On
error (at least one bit in mode asked for a permission that is denied,
or some other error occurred), -1 is returned.
.PP
.SH OPENFILECHANNELPROC
.PP
Function to process a \fBTcl_FSOpenFileChannel()\fR call. Must be
implemented for any reasonable filesystem, since any operations
which require open or accessing a file's contents will use it
(e.g. \fBopen\fR, \fBencoding\fR, and many Tk commands).
.PP
.CS
typedef Tcl_Channel Tcl_FSOpenFileChannelProc(
Tcl_Interp *\fIinterp\fR,
Tcl_Obj *\fIpathPtr\fR,
int \fImode\fR,
int \fIpermissions\fR);
.CE
.PP
The \fBTcl_FSOpenFileChannelProc\fR opens a file specified by
\fIpathPtr\fR and returns a channel handle that can be used to perform
input and output on the file. This API is modeled after the \fBfopen\fR
procedure of the Unix standard I/O library. The syntax and meaning of
all arguments is similar to those given in the Tcl \fBopen\fR command
when opening a file, where the \fImode\fR argument is a combination of
the POSIX flags O_RDONLY, O_WRONLY, etc. If an error occurs while
opening the channel, the \fBTcl_FSOpenFileChannelProc\fR returns NULL and
records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR.
In addition, if \fIinterp\fR is non-NULL, the
\fBTcl_FSOpenFileChannelProc\fR leaves an error message in \fIinterp\fR's
result after any error.
.PP
The newly created channel must not registered in the supplied
interpreter; that task is up to the caller of
\fBTcl_FSOpenFileChannel\fR (if necessary). If one of
the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it
as a replacement for the standard channel.
.SH MATCHINDIRECTORYPROC
.PP
Function to process a \fBTcl_FSMatchInDirectory()\fR call. If not
implemented, then glob and recursive copy functionality will be lacking
in the filesystem (and this may impact commands like 'encoding names'
which use glob functionality internally).
.PP
.CS
typedef int Tcl_FSMatchInDirectoryProc(
Tcl_Interp* \fIinterp\fR,
Tcl_Obj *\fIresult\fR,
Tcl_Obj *\fIpathPtr\fR,
CONST char *\fIpattern\fR,
Tcl_GlobTypeData * \fItypes\fR);
.CE
.PP
The function should return all files or directories (or other filesystem
objects) which match the given pattern and accord with the \fItypes\fR
specification given. There are two ways in which this function may be
called. If \fIpattern\fR is NULL, then \fIpathPtr\fR is a full path
specification of a single file or directory which should be checked for
existence and correct type. Otherwise, \fIpathPtr\fR is a directory, the
contents of which the function should search for files or directories
which have the correct type. In either case, \fIpathPtr\fR can be
assumed to be both non-NULL and non-empty. It is not currently
documented whether \fIpathPtr\fR will have a file separator at its end of
not, so code should be flexible to both possibilities.
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the matching process. Error messages are placed in
\fIinterp\fR; on a \fBTCL_OK\fR result, results should be added to the
\fIresult\fR object given (which can be assumed to be a valid
unshared Tcl list). The matches added
to \fIresult\fR should include any path prefix given in \fIpathPtr\fR
(this usually means they will be absolute path specifications).
Note that if no matches are found, that simply leads to an empty
result; errors are only signaled for actual file or filesystem
problems which may occur during the matching process.
.PP
The \fBTcl_GlobTypeData\fR structure passed in the \fItypes\fR
parameter contains the following fields:
.CS
typedef struct Tcl_GlobTypeData {
/* Corresponds to bcdpfls as in 'find -t' */
int \fItype\fR;
/* Corresponds to file permissions */
int \fIperm\fR;
/* Acceptable mac type */
Tcl_Obj *\fImacType\fR;
/* Acceptable mac creator */
Tcl_Obj *\fImacCreator\fR;
} Tcl_GlobTypeData;
.CE
.PP
There are two specific cases which it is important to handle correctly,
both when \fItypes\fR is non-NULL. The two cases are when \fItypes->types
& TCL_GLOB_TYPE_DIR\fR or \fItypes->types & TCL_GLOB_TYPE_MOUNT\fR are
true (and in particular when the other flags are false). In the first of
these cases, the function must list the contained directories. Tcl uses
this to implement recursive globbing, so it is critical that filesystems
implement directory matching correctly. In the second of these cases,
with \fBTCL_GLOB_TYPE_MOUNT\fR, the filesystem must list the mount points
which lie within the given \fIpathPtr\fR (and in this case, \fIpathPtr\fR
need not lie within the same filesystem - different to all other cases in
which this function is called). Support for this is critical if Tcl is
to have seamless transitions between from one filesystem to another.
.SH UTIMEPROC
.PP
Function to process a \fBTcl_FSUtime()\fR call. Required to allow setting
(not reading) of times with 'file mtime', 'file atime' and the
open-r/open-w/fcopy implementation of 'file copy'.
.PP
.CS
typedef int Tcl_FSUtimeProc(
Tcl_Obj *\fIpathPtr\fR,
struct utimbuf *\fItval\fR);
.CE
.PP
The access and modification times of the file specified by \fIpathPtr\fR
should be changed to the values given in the \fItval\fR structure.
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the process.
.SH LINKPROC
.PP
Function to process a \fBTcl_FSLink()\fR call. Should be implemented
only if the filesystem supports links, and may otherwise be NULL.
.PP
.CS
typedef Tcl_Obj* Tcl_FSLinkProc(
Tcl_Obj *\fIlinkNamePtr\fR,
Tcl_Obj *\fItoPtr\fR,
int \fIlinkAction\fR);
.CE
.PP
If \fItoPtr\fR is NULL, the function is being asked to read the
contents of a link. The result is a Tcl_Obj specifying the contents of
the link given by \fIlinkNamePtr\fR, or NULL if the link could
not be read. The result is owned by the caller, which should call
Tcl_DecrRefCount when the result is no longer needed. If \fItoPtr\fR
is not NULL, the function should attempt to create a link. The result
in this case should be \fItoPtr\fR if the link was successful and NULL
otherwise. In this case the result is not owned by the caller. See
the documentation for \fBTcl_FSLink\fR for the correct interpretation
of the \fIlinkAction\fR flags.
.SH LISTVOLUMESPROC
.PP
Function to list any filesystem volumes added by this filesystem.
Should be implemented only if the filesystem adds volumes at the head
of the filesystem, so that they can be returned by 'file volumes'.
.PP
.CS
typedef Tcl_Obj* Tcl_FSListVolumesProc(void);
.CE
.PP
The result should be a list of volumes added by this filesystem, or
NULL (or an empty list) if no volumes are provided. The result object
is considered to be owned by the filesystem (not by Tcl's core), but
should be given a refCount for Tcl. Tcl will use the contents of the
list and then decrement that refCount. This allows filesystems to
choose whether they actually want to retain a 'master list' of volumes
or not (if not, they generate the list on the fly and pass it to Tcl
with a refCount of 1 and then forget about the list, if yes, then
they simply increment the refCount of their master list and pass it
to Tcl which will copy the contents and then decrement the count back
to where it was).
.PP
Therefore, Tcl considers return values from this proc to be read-only.
.PP
.SH FILEATTRSTRINGSPROC
.PP
Function to list all attribute strings which are valid for this
filesystem. If not implemented the filesystem will not support
the \fBfile attributes\fR command. This allows arbitrary additional
information to be attached to files in the filesystem. If it is
not implemented, there is no need to implement the \fBget\fR and \fBset\fR
methods.
.PP
.CS
typedef CONST char** Tcl_FSFileAttrStringsProc(
Tcl_Obj *\fIpathPtr\fR,
Tcl_Obj** \fIobjPtrRef\fR);
.CE
.PP
The called function may either return an array of strings, or may
instead return NULL and place a Tcl list into the given objPtrRef. Tcl
will take that list and first increment its refCount before using it.
On completion of that use, Tcl will decrement its refCount. Hence if
the list should be disposed of by Tcl when done, it should have a
refCount of zero, and if the list should not be disposed of, the
filesystem should ensure it retains a refCount on the object.
.SH FILEATTRSGETPROC
.PP
Function to process a \fBTcl_FSFileAttrsGet()\fR call, used by 'file
attributes'.
.PP
.CS
typedef int Tcl_FSFileAttrsGetProc(
Tcl_Interp *\fIinterp\fR,
int \fIindex\fR,
Tcl_Obj *\fIpathPtr\fR,
Tcl_Obj **\fIobjPtrRef\fR);
.CE
.PP
Returns a standard Tcl return code. The attribute value retrieved,
which corresponds to the \fIindex\fR'th element in the list returned by
the Tcl_FSFileAttrStringsProc, is a Tcl_Obj placed in objPtrRef (if
TCL_OK was returned) and is likely to have a refCount of zero. Either
way we must either store it somewhere (e.g. the Tcl result), or
Incr/Decr its refCount to ensure it is properly freed.
.SH FILEATTRSSETPROC
.PP
Function to process a \fBTcl_FSFileAttrsSet()\fR call, used by 'file
attributes'. If the filesystem is read-only, there is no need
to implement this.
.PP
.CS
typedef int Tcl_FSFileAttrsSetProc(
Tcl_Interp *\fIinterp\fR,
int \fIindex\fR,
Tcl_Obj *\fIpathPtr\fR,
Tcl_Obj *\fIobjPtr\fR);
.CE
.PP
The attribute value of the \fIindex\fR'th element in the list returned by
the Tcl_FSFileAttrStringsProc should be set to the \fIobjPtr\fR given.
.SH CREATEDIRECTORYPROC
.PP
Function to process a \fBTcl_FSCreateDirectory()\fR call. Should be
implemented unless the FS is read-only.
.PP
.CS
typedef int Tcl_FSCreateDirectoryProc(
Tcl_Obj *\fIpathPtr\fR);
.CE
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the process. If successful, a new directory should have
been added to the filesystem in the location specified by
\fIpathPtr\fR.
.SH REMOVEDIRECTORYPROC
.PP
Function to process a 'Tcl_FSRemoveDirectory()' call. Should be
implemented unless the FS is read-only.
.PP
.CS
typedef int Tcl_FSRemoveDirectoryProc(
Tcl_Obj *\fIpathPtr\fR,
int \fIrecursive\fR,
Tcl_Obj **\fIerrorPtr\fR);
.CE
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the process. If successful, the directory specified by
\fIpathPtr\fR should have been removed from the filesystem. If the
\fIrecursive\fR flag is given, then a non-empty directory should
be deleted without error. If an error does occur, the name of
the file or directory which caused the error should be placed in
\fIerrorPtr\fR.
.SH DELETEFILEPROC
.PP
Function to process a \fBTcl_FSDeleteFile()\fR call. Should be implemented
unless the FS is read-only.
.PP
.CS
typedef int Tcl_FSDeleteFileProc(
Tcl_Obj *\fIpathPtr\fR);
.CE
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the process. If successful, the file specified by
\fIpathPtr\fR should have been removed from the filesystem. Note that,
if the filesystem supports symbolic links, Tcl will always call this
function and not Tcl_FSRemoveDirectoryProc when needed to delete them
(even if they are symbolic links to directories).
.SH "FILESYSTEM EFFICIENCY"
.PP
.SH LSTATPROC
.PP
Function to process a \fBTcl_FSLstat()\fR call. If not implemented, Tcl
will attempt to use the \fIstatProc\fR defined above instead. Therefore
it need only be implemented if a filesystem can differentiate between
\fBstat\fR and \fBlstat\fR calls.
.PP
.CS
typedef int Tcl_FSLstatProc(
Tcl_Obj *\fIpathPtr\fR,
Tcl_StatBuf *\fIstatPtr\fR);
.CE
.PP
The behavior of this function is very similar to that of the
Tcl_FSStatProc defined above, except that if it is applied
to a symbolic link, it returns information about the link, not
about the target file.
.PP
.SH COPYFILEPROC
.PP
Function to process a \fBTcl_FSCopyFile()\fR call. If not implemented Tcl
will fall back on open-r, open-w and fcopy as a copying mechanism.
Therefore it need only be implemented if the filesystem can perform
that action more efficiently.
.PP
.CS
typedef int Tcl_FSCopyFileProc(
Tcl_Obj *\fIsrcPathPtr\fR,
Tcl_Obj *\fIdestPathPtr\fR);
.CE
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the copying process. Note that, \fIdestPathPtr\fR is the
name of the file which should become the copy of \fIsrcPathPtr\fR. It
is never the name of a directory into which \fIsrcPathPtr\fR could be
copied (i.e. the function is much simpler than the Tcl level 'file
copy' subcommand). Note that,
if the filesystem supports symbolic links, Tcl will always call this
function and not Tcl_FSCopyDirectoryProc when needed to copy them
(even if they are symbolic links to directories).
.SH RENAMEFILEPROC
.PP
Function to process a \fBTcl_FSRenameFile()\fR call. If not implemented,
Tcl will fall back on a copy and delete mechanism. Therefore it need
only be implemented if the filesystem can perform that action more
efficiently.
.PP
.CS
typedef int Tcl_FSRenameFileProc(
Tcl_Obj *\fIsrcPathPtr\fR,
Tcl_Obj *\fIdestPathPtr\fR);
.CE
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the renaming process.
.SH COPYDIRECTORYPROC
.PP
Function to process a \fBTcl_FSCopyDirectory()\fR call. If not
implemented, Tcl will fall back on a recursive create-dir, file copy
mechanism. Therefore it need only be implemented if the filesystem can
perform that action more efficiently.
.PP
.CS
typedef int Tcl_FSCopyDirectoryProc(
Tcl_Obj *\fIsrcPathPtr\fR,
Tcl_Obj *\fIdestPathPtr\fR,
Tcl_Obj **\fIerrorPtr\fR);
.CE
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the copying process. If an error does occur, the name of
the file or directory which caused the error should be placed in
\fIerrorPtr\fR. Note that, \fIdestPathPtr\fR is the name of the
directory-name which should become the mirror-image of
\fIsrcPathPtr\fR. It is not the name of a directory into which
\fIsrcPathPtr\fR should be copied (i.e. the function is much simpler
than the Tcl level 'file copy' subcommand).
.SH LOADFILEPROC
.PP
Function to process a \fBTcl_FSLoadFile()\fR call. If not implemented, Tcl
will fall back on a copy to native-temp followed by a Tcl_FSLoadFile on
that temporary copy. Therefore it need only be implemented if the
filesystem can load code directly, or it can be implemented simply to
return TCL_ERROR to disable load functionality in this filesystem
entirely.
.PP
.CS
typedef int Tcl_FSLoadFileProc(
Tcl_Interp * \fIinterp\fR,
Tcl_Obj *\fIpathPtr\fR,
Tcl_LoadHandle * \fIhandlePtr\fR,
Tcl_FSUnloadFileProc * \fIunloadProcPtr\fR);
.CE
.PP
Returns a standard Tcl completion code. If an error occurs, an error
message is left in the interp's result. The function dynamically loads
a binary code file into memory. On a successful
load, the \fIhandlePtr\fR should be filled with a token for
the dynamically loaded file, and the \fIunloadProcPtr\fR should be
filled in with the address of a procedure. The procedure will be
called with the given Tcl_LoadHandle as its only parameter when Tcl
needs to unload the file.
.SH UNLOADFILEPROC
.PP
Function to unload a previously successfully loaded file. If load was
implemented, then this should also be implemented, if there is any
cleanup action required.
.PP
.CS
typedef void Tcl_FSUnloadFileProc(
Tcl_LoadHandle \fIloadHandle\fR);
.CE
.SH GETCWDPROC
.PP
Function to process a \fBTcl_FSGetCwd()\fR call. Most filesystems need not
implement this. It will usually only be called once, if 'getcwd' is
called before 'chdir'. May be NULL.
.PP
.CS
typedef Tcl_Obj* Tcl_FSGetCwdProc(
Tcl_Interp *\fIinterp\fR);
.CE
.PP
If the filesystem supports a native notion of a current working
directory (which might perhaps change independent of Tcl), this
function should return that cwd as the result, or NULL if the current
directory could not be determined (e.g. the user does not have
appropriate permissions on the cwd directory). If NULL is returned, an
error message is left in the interp's result.
.PP
.SH CHDIRPROC
.PP
Function to process a \fBTcl_FSChdir()\fR call. If filesystems do not
implement this, it will be emulated by a series of directory access
checks. Otherwise, virtual filesystems which do implement it need only
respond with a positive return result if the dirName is a valid,
accessible directory in their filesystem. They need not remember the
result, since that will be automatically remembered for use by GetCwd.
Real filesystems should carry out the correct action (i.e. call the
correct system 'chdir' api).
.PP
.CS
typedef int Tcl_FSChdirProc(
Tcl_Obj *\fIpathPtr\fR);
.CE
.PP
The \fBTcl_FSChdirProc\fR changes the applications current working
directory to the value specified in \fIpathPtr\fR. The function returns
-1 on error or 0 on success.
.SH KEYWORDS
stat access filesystem vfs
tcl8.4.20/doc/unset.n 0000644 0036047 0045461 00000004135 11737050674 013004 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH unset n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
unset \- Delete variables
.SH SYNOPSIS
\fBunset \fR?\fI\-nocomplain\fR? ?\fI\-\-\fR? ?\fIname name name ...\fR?
.BE
.SH DESCRIPTION
.PP
This command removes one or more variables.
Each \fIname\fR is a variable name, specified in any of the
ways acceptable to the \fBset\fR command.
If a \fIname\fR refers to an element of an array then that
element is removed without affecting the rest of the array.
If a \fIname\fR consists of an array name with no parenthesized
index, then the entire array is deleted.
The \fBunset\fR command returns an empty string as result.
.VS 8.4
If \fI\-nocomplain\fR is specified as the first argument, any possible
errors are suppressed. The option may not be abbreviated, in order to
disambiguate it from possible variable names. The option \fI\-\-\fR
indicates the end of the options, and should be used if you wish to
remove a variable with the same name as any of the options.
.VE 8.4
If an error occurs, any variables after the named one causing the error
are not
deleted. An error can occur when the named variable doesn't exist, or the
name refers to an array element but the variable is a scalar, or the name
refers to a variable in a non-existent namespace.
.SH EXAMPLE
Create an array containing a mapping from some numbers to their
squares and remove the array elements for non-prime numbers:
.CS
array set squares {
1 1 6 36
2 4 7 49
3 9 8 64
4 16 9 81
5 25 10 100
}
puts "The squares are:"
parray squares
\fBunset\fR squares(1) squares(4) squares(6)
\fBunset\fR squares(8) squares(9) squares(10)
puts "The prime squares are:"
parray squares
.CE
.SH "SEE ALSO"
set(n), trace(n), upvar(n)
.SH KEYWORDS
remove, variable
tcl8.4.20/doc/CrtChnlHdlr.3 0000644 0036047 0045461 00000007211 11737050674 013720 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_CreateChannelHandler 3 7.5 Tcl "Tcl Library Procedures"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_CreateChannelHandler, Tcl_DeleteChannelHandler \- call a procedure when a channel becomes readable or writable
.SH SYNOPSIS
.nf
.nf
\fB#include \fR
.sp
void
\fBTcl_CreateChannelHandler\fR(\fIchannel, mask, proc, clientData\fR)
.sp
void
\fBTcl_DeleteChannelHandler\fR(\fIchannel, proc, clientData\fR)
.sp
.SH ARGUMENTS
.AS Tcl_ChannelProc clientData
.AP Tcl_Channel channel in
Tcl channel such as returned by \fBTcl_CreateChannel\fR.
.AP int mask in
Conditions under which \fIproc\fR should be called: OR-ed combination of
\fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify
a zero value to temporarily disable an existing handler.
.AP Tcl_FileProc *proc in
Procedure to invoke whenever the channel indicated by \fIchannel\fR meets
the conditions specified by \fImask\fR.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CreateChannelHandler\fR arranges for \fIproc\fR to be called in the
future whenever input or output becomes possible on the channel identified
by \fIchannel\fR, or whenever an exceptional condition exists for
\fIchannel\fR. The conditions of interest under which \fIproc\fR will be
invoked are specified by the \fImask\fR argument.
See the manual entry for \fBfileevent\fR for a precise description of
what it means for a channel to be readable or writable.
\fIProc\fR must conform to the following prototype:
.CS
typedef void Tcl_ChannelProc(
ClientData \fIclientData\fR,
int \fImask\fR);
.CE
.PP
The \fIclientData\fR argument is the same as the value passed to
\fBTcl_CreateChannelHandler\fR when the handler was created. Typically,
\fIclientData\fR points to a data structure containing application-specific
information about the channel. \fIMask\fR is an integer mask indicating
which of the requested conditions actually exists for the channel; it will
contain a subset of the bits from the \fImask\fR argument to
\fBTcl_CreateChannelHandler\fR when the handler was created.
.PP
Each channel handler is identified by a unique combination of \fIchannel\fR,
\fIproc\fR and \fIclientData\fR.
There may be many handlers for a given channel as long as they don't
have the same \fIchannel\fR, \fIproc\fR, and \fIclientData\fR.
If \fBTcl_CreateChannelHandler\fR is invoked when there is already a handler
for \fIchannel\fR, \fIproc\fR, and \fIclientData\fR, then no new
handler is created; instead, the \fImask\fR is changed for the
existing handler.
.PP
\fBTcl_DeleteChannelHandler\fR deletes a channel handler identified by
\fIchannel\fR, \fIproc\fR and \fIclientData\fR; if no such handler exists,
the call has no effect.
.PP
Channel handlers are invoked via the Tcl event mechanism, so they
are only useful in applications that are event-driven.
Note also that the conditions specified in the \fImask\fR argument
to \fIproc\fR may no longer exist when \fIproc\fR is invoked: for
example, if there are two handlers for \fBTCL_READABLE\fR on the same
channel, the first handler could consume all of the available input
so that the channel is no longer readable when the second handler
is invoked.
For this reason it may be useful to use nonblocking I/O on channels
for which there are event handlers.
.SH "SEE ALSO"
Notifier(3), Tcl_CreateChannel(3), Tcl_OpenFileChannel(3), vwait(n).
.SH KEYWORDS
blocking, callback, channel, events, handler, nonblocking.
tcl8.4.20/doc/concat.n 0000644 0036047 0045461 00000002743 11737050674 013120 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH concat n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
concat \- Join lists together
.SH SYNOPSIS
\fBconcat\fI \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command joins each of its arguments together with spaces after
trimming leading and trailing white-space from each of them. If all the
arguments are lists, this has the same effect as concatenating them
into a single list.
It permits any number of arguments;
if no \fIarg\fRs are supplied, the result is an empty string.
.SH EXAMPLES
Although \fBconcat\fR will concatenate lists (so the command:
.CS
\fBconcat\fR a b {c d e} {f {g h}}
.CE
will return "\fBa b c d e f {g h}\fR" as its result), it will also
concatenate things that are not lists, and hence the command:
.CS
\fBconcat\fR " a b {c " d " e} f"
.CE
will return "\fBa b {c d e} f\fR" as its result.
.PP
Note that the concatenation does not remove spaces from the middle of
its arguments, so the command:
.CS
\fBconcat\fR "a b c" { d e f }
.CE
will return "\fBa b c d e f\fR" (i.e. with three spaces between
the \fBa\fR, the \fBb\fR and the \fBc\fR).
.SH "SEE ALSO"
append(n), eval(n)
.SH KEYWORDS
concatenate, join, lists
tcl8.4.20/doc/exec.n 0000644 0036047 0045461 00000037367 12052456743 012605 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH exec n 7.6 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
exec \- Invoke subprocesses
.SH SYNOPSIS
\fBexec \fR?\fIswitches\fR? \fIarg \fR?\fIarg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command treats its arguments as the specification
of one or more subprocesses to execute.
The arguments take the form of a standard shell pipeline
where each \fIarg\fR becomes one word of a command, and
each distinct command becomes a subprocess.
.PP
If the initial arguments to \fBexec\fR start with \fB\-\fR then
they are treated as command-line switches and are not part
of the pipeline specification. The following switches are
currently supported:
.TP 13
\fB\-keepnewline\fR
Retains a trailing newline in the pipeline's output.
Normally a trailing newline will be deleted.
.TP 13
\fB\-\|\-\fR
Marks the end of switches. The argument following this one will
be treated as the first \fIarg\fR even if it starts with a \fB\-\fR.
.PP
If an \fIarg\fR (or pair of \fIarg\fRs) has one of the forms
described below then it is used by \fBexec\fR to control the
flow of input and output among the subprocess(es).
Such arguments will not be passed to the subprocess(es). In forms
such as ``< \fIfileName\fR'' \fIfileName\fR may either be in a
separate argument from ``<'' or in the same argument with no
intervening space (i.e. ``<\fIfileName\fR'').
.TP 15
|
Separates distinct commands in the pipeline. The standard output
of the preceding command will be piped into the standard input
of the next command.
.TP 15
|&
Separates distinct commands in the pipeline. Both standard output
and standard error of the preceding command will be piped into
the standard input of the next command.
This form of redirection overrides forms such as 2> and >&.
.TP 15
<\0\fIfileName\fR
The file named by \fIfileName\fR is opened and used as the standard
input for the first command in the pipeline.
.TP 15
<@\0\fIfileId\fR
\fIFileId\fR must be the identifier for an open file, such as the return
value from a previous call to \fBopen\fR.
It is used as the standard input for the first command in the pipeline.
\fIFileId\fR must have been opened for reading.
.TP 15
<<\0\fIvalue\fR
\fIValue\fR is passed to the first command as its standard input.
.TP 15
>\0\fIfileName\fR
Standard output from the last command is redirected to the file named
\fIfileName\fR, overwriting its previous contents.
.TP 15
2>\0\fIfileName\fR
Standard error from all commands in the pipeline is redirected to the
file named \fIfileName\fR, overwriting its previous contents.
.TP 15
>&\0\fIfileName\fR
Both standard output from the last command and standard error from all
commands are redirected to the file named \fIfileName\fR, overwriting
its previous contents.
.TP 15
>>\0\fIfileName\fR
Standard output from the last command is
redirected to the file named \fIfileName\fR, appending to it rather
than overwriting it.
.TP 15
2>>\0\fIfileName\fR
Standard error from all commands in the pipeline is
redirected to the file named \fIfileName\fR, appending to it rather
than overwriting it.
.TP 15
>>&\0\fIfileName\fR
Both standard output from the last command and standard error from
all commands are redirected to the file named \fIfileName\fR,
appending to it rather than overwriting it.
.TP 15
>@\0\fIfileId\fR
\fIFileId\fR must be the identifier for an open file, such as the return
value from a previous call to \fBopen\fR.
Standard output from the last command is redirected to \fIfileId\fR's
file, which must have been opened for writing.
.TP 15
2>@\0\fIfileId\fR
\fIFileId\fR must be the identifier for an open file, such as the return
value from a previous call to \fBopen\fR.
Standard error from all commands in the pipeline is
redirected to \fIfileId\fR's file.
The file must have been opened for writing.
.TP 15
>&@\0\fIfileId\fR
\fIFileId\fR must be the identifier for an open file, such as the return
value from a previous call to \fBopen\fR.
Both standard output from the last command and standard error from
all commands are redirected to \fIfileId\fR's file.
The file must have been opened for writing.
.PP
If standard output has not been redirected then the \fBexec\fR
command returns the standard output from the last command
in the pipeline.
If any of the commands in the pipeline exit abnormally or
are killed or suspended, then \fBexec\fR will return an error
and the error message will include the pipeline's output followed by
error messages describing the abnormal terminations; the
\fBerrorCode\fR variable will contain additional information
about the last abnormal termination encountered.
If any of the commands writes to its standard error file and that
standard error isn't redirected,
then \fBexec\fR will return an error; the error message
will include the pipeline's standard output, followed by messages
about abnormal terminations (if any), followed by the standard error
output.
.PP
If the last character of the result or error message
is a newline then that character is normally deleted
from the result or error message.
This is consistent with other Tcl return values, which don't
normally end with newlines.
However, if \fB\-keepnewline\fR is specified then the trailing
newline is retained.
.PP
If standard input isn't redirected with ``<'' or ``<<''
or ``<@'' then the standard input for the first command in the
pipeline is taken from the application's current standard input.
.PP
If the last \fIarg\fR is ``&'' then the pipeline will be
executed in background.
In this case the \fBexec\fR command will return a list whose
elements are the process identifiers for all of the subprocesses
in the pipeline.
The standard output from the last command in the pipeline will
go to the application's standard output if it hasn't been
redirected, and error output from all of
the commands in the pipeline will go to the application's
standard error file unless redirected.
.PP
The first word in each command is taken as the command name;
tilde-substitution is performed on it, and if the result contains
no slashes then the directories
in the PATH environment variable are searched for
an executable by the given name.
If the name contains a slash then it must refer to an executable
reachable from the current directory.
No ``glob'' expansion or other shell-like substitutions
are performed on the arguments to commands.
.VS
.SH "PORTABILITY ISSUES"
.TP
\fBWindows\fR (all versions)
.
Reading from or writing to a socket, using the ``\fB@\0\fIfileId\fR''
notation, does not work. When reading from a socket, a 16-bit DOS
application will hang and a 32-bit application will return immediately with
end-of-file. When either type of application writes to a socket, the
information is instead sent to the console, if one is present, or is
discarded.
.sp
The Tk console text widget does not provide real standard IO capabilities.
Under Tk, when redirecting from standard input, all applications will see an
immediate end-of-file; information redirected to standard output or standard
error will be discarded.
.sp
Either forward or backward slashes are accepted as path separators for
arguments to Tcl commands. When executing an application, the path name
specified for the application may also contain forward or backward slashes
as path separators. Bear in mind, however, that most Windows applications
accept arguments with forward slashes only as option delimiters and
backslashes only in paths. Any arguments to an application that specify a
path name with forward slashes will not automatically be converted to use
the backslash character. If an argument contains forward slashes as the
path separator, it may or may not be recognized as a path name, depending on
the program.
.sp
Additionally, when calling a 16-bit DOS or Windows 3.X application, all path
names must use the short, cryptic, path format (e.g., using ``applba~1.def''
instead of ``applbakery.default''), which can be obtained with the
\fBfile attributes $fileName -shortname\fR command.
.sp
Two or more forward or backward slashes in a row in a path refer to a
network path. For example, a simple concatenation of the root directory
\fBc:/\fR with a subdirectory \fB/windows/system\fR will yield
\fBc://windows/system\fR (two slashes together), which refers to the mount
point called \fBsystem\fR on the machine called \fBwindows\fR (and the
\fBc:/\fR is ignored), and is not equivalent to \fBc:/windows/system\fR,
which describes a directory on the current computer. The \fBfile join\fR
command should be used to concatenate path components.
.sp
.RS
Note that there are two general types of Win32 console applications:
.RS
1) CLI -- CommandLine Interface, simple stdio exchange. \fBnetstat.exe\fR for
example.
.br
2) TUI -- Textmode User Interface, any application that accesses the console
API for doing such things as cursor movement, setting text color, detecting
key presses and mouse movement, etc. An example would be \fBtelnet.exe\fR
from Windows 2000. These types of applications are not common in a windows
environment, but do exist.
.RE
\fBexec\fR will not work well with TUI applications when a console is not
present, as is done when launching applications under wish. It is desirable
to have console applications hidden and detached. This is a designed-in
limitation as \fBexec\fR wants to communicate over pipes. The Expect
extension addresses this issue when communicating with a TUI application.
.sp
.RE
.TP
\fBWindows NT\fR
.
When attempting to execute an application, \fBexec\fR first searches for
the name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and
\fB.bat\fR are appended to the end of the specified name and it searches
for the longer name. If a directory name was not specified as part of the
application name, the following directories are automatically searched in
order when attempting to locate the application:
.sp
.RS
.RS
The directory from which the Tcl executable was loaded.
.br
The current directory.
.br
The Windows NT 32-bit system directory.
.br
The Windows NT 16-bit system directory.
.br
The Windows NT home directory.
.br
The directories listed in the path.
.RE
.sp
In order to execute shell built-in commands like \fBdir\fR and \fBcopy\fR,
the caller must prepend the desired command with ``\fBcmd.exe /c\0\fR''
because built-in commands are not implemented using executables.
.sp
.RE
.TP
\fBWindows 9x\fR
.
When attempting to execute an application, \fBexec\fR first searches for
the name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and
\fB.bat\fR are appended to the end of the specified name and it searches
for the longer name. If a directory name was not specified as part of the
application name, the following directories are automatically searched in
order when attempting to locate the application:
.sp
.RS
.RS
The directory from which the Tcl executable was loaded.
.br
The current directory.
.br
The Windows 9x system directory.
.br
The Windows 9x home directory.
.br
The directories listed in the path.
.RE
.sp
In order to execute shell built-in commands like \fBdir\fR and \fBcopy\fR,
the caller must prepend the desired command with ``\fBcommand.com /c\0\fR''
because built-in commands are not implemented using executables.
.sp
Once a 16-bit DOS application has read standard input from a console and
then quit, all subsequently run 16-bit DOS applications will see the
standard input as already closed. 32-bit applications do not have this
problem and will run correctly, even after a 16-bit DOS application thinks
that standard input is closed. There is no known workaround for this bug
at this time.
.sp
Redirection between the \fBNUL:\fR device and a 16-bit application does not
always work. When redirecting from \fBNUL:\fR, some applications may hang,
others will get an infinite stream of ``0x01'' bytes, and some will actually
correctly get an immediate end-of-file; the behavior seems to depend upon
something compiled into the application itself. When redirecting greater than
4K or so to \fBNUL:\fR, some applications will hang. The above problems do not
happen with 32-bit applications.
.sp
All DOS 16-bit applications are run synchronously. All standard input from
a pipe to a 16-bit DOS application is collected into a temporary file; the
other end of the pipe must be closed before the 16-bit DOS application
begins executing. All standard output or error from a 16-bit DOS
application to a pipe is collected into temporary files; the application
must terminate before the temporary files are redirected to the next stage
of the pipeline. This is due to a workaround for a Windows 95 bug in the
implementation of pipes, and is how the standard Windows 95 DOS shell
handles pipes itself.
.sp
Certain applications, such as \fBcommand.com\fR, should not be executed
interactively. Applications which directly access the console window,
rather than reading from their standard input and writing to their standard
output may fail, hang Tcl, or even hang the system if their own private
console window is not available to them.
.RE
.TP
\fBUnix\fR\0\0\0\0\0\0\0
The \fBexec\fR command is fully functional and works as described.
.SH "UNIX EXAMPLES"
Here are some examples of the use of the \fBexec\fR command on Unix.
.PP
To execute a simple program and get its result:
.CS
\fBexec\fR uname -a
.CE
.PP
To execute a program that can return a non-zero result, you should
wrap the call to \fBexec\fR in \fBcatch\fR and check what the contents
of the global \fBerrorCode\fR variable is if you have an error:
.CS
set status 0
if {[catch {\fBexec\fR grep foo bar.txt} results]} {
if {[lindex $::errorCode 0] eq "CHILDSTATUS"} {
set status [lindex $::errorCode 2]
} else {
# Some kind of unexpected failure
}
}
.CE
.PP
When translating a command from a Unix shell invocation, care should
be taken over the fact that single quote characters have no special
significance to Tcl. Thus:
.CS
awk '{sum += $1} END {print sum}' numbers.list
.CE
would be translated into something like:
.CS
\fBexec\fR awk {{sum += $1} END {print sum}} numbers.list
.CE
.PP
If you are converting invocations involving shell globbing, you should
remember that Tcl does not handle globbing or expand things into
multiple arguments by default. Instead you should write things like
this:
.CS
eval [list \fBexec\fR ls -l] [glob *.tcl]
.CE
.PP
.SH "WINDOWS EXAMPLES"
Here are some examples of the use of the \fBexec\fR command on Windows.
.PP
To start an instance of \fInotepad\fR editing a file without waiting
for the user to finish editing the file:
.CS
\fBexec\fR notepad myfile.txt &
.CE
.PP
To print a text file using \fInotepad\fR:
.CS
\fBexec\fR notepad /p myfile.txt
.CE
.PP
If a program calls other programs, such as is common with compilers,
then you may need to resort to batch files to hide the console windows
that sometimes pop up:
.CS
\fBexec\fR cmp.bat somefile.c -o somefile
.CE
With the file \fIcmp.bat\fR looking something like:
.CS
@gcc %1 %2 %3 %4 %5 %6 %7 %8 %9
.CE
.PP
Sometimes you need to be careful, as different programs may have the
same name and be in the path. It can then happen that typing a command
at the DOS prompt finds \fIa different program\fR than the same
command run via \fBexec\fR. This is because of the (documented)
differences in behaviour between \fBexec\fR and DOS batch files.
.PP
When in doubt, use the command \fBauto_execok\fR: it will return the
complete path to the program as seen by the \fBexec\fR command. This
applies especially when you want to run "internal" commands like
\fIdir\fR from a Tcl script (if you just want to list filenames, use
the \fBglob\fR command.) To do that, use this:
.CS
eval [list \fBexec\fR] [auto_execok dir] [list *.tcl]
.CE
.SH "SEE ALSO"
error(n), open(n)
.SH KEYWORDS
execute, pipeline, redirection, subprocess
tcl8.4.20/doc/DString.3 0000644 0036047 0045461 00000013516 11737050674 013130 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_DStringInit\fR(\fIdsPtr\fR)
.sp
char *
\fBTcl_DStringAppend\fR(\fIdsPtr, string, length\fR)
.sp
char *
\fBTcl_DStringAppendElement\fR(\fIdsPtr, string\fR)
.sp
\fBTcl_DStringStartSublist\fR(\fIdsPtr\fR)
.sp
\fBTcl_DStringEndSublist\fR(\fIdsPtr\fR)
.sp
int
\fBTcl_DStringLength\fR(\fIdsPtr\fR)
.sp
char *
\fBTcl_DStringValue\fR(\fIdsPtr\fR)
.sp
\fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR)
.sp
\fBTcl_DStringTrunc\fR(\fIdsPtr, newLength\fR)
.sp
\fBTcl_DStringFree\fR(\fIdsPtr\fR)
.sp
\fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR)
.sp
\fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR)
.SH ARGUMENTS
.AS Tcl_DString newLength
.AP Tcl_DString *dsPtr in/out
Pointer to structure that is used to manage a dynamic string.
.AP "CONST char" *string in
Pointer to characters to add to dynamic string.
.AP int length in
Number of characters from string to add to dynamic string. If -1,
add all characters up to null terminating character.
.AP int newLength in
New length for dynamic string, not including null terminating
character.
.AP Tcl_Interp *interp in/out
Interpreter whose result is to be set from or moved to the
dynamic string.
.BE
.SH DESCRIPTION
.PP
Dynamic strings provide a mechanism for building up arbitrarily long
strings by gradually appending information. If the dynamic string is
short then there will be no memory allocation overhead; as the string
gets larger, additional space will be allocated as needed.
.PP
\fBTcl_DStringInit\fR initializes a dynamic string to zero length.
The Tcl_DString structure must have been allocated by the caller.
No assumptions are made about the current state of the structure;
anything already in it is discarded.
If the structure has been used previously, \fBTcl_DStringFree\fR should
be called first to free up any memory allocated for the old
string.
.PP
\fBTcl_DStringAppend\fR adds new information to a dynamic string,
allocating more memory for the string if needed.
If \fIlength\fR is less than zero then everything in \fIstring\fR
is appended to the dynamic string; otherwise \fIlength\fR
specifies the number of bytes to append.
\fBTcl_DStringAppend\fR returns a pointer to the characters of
the new string. The string can also be retrieved from the
\fIstring\fR field of the Tcl_DString structure.
.PP
\fBTcl_DStringAppendElement\fR is similar to \fBTcl_DStringAppend\fR
except that it doesn't take a \fIlength\fR argument (it appends
all of \fIstring\fR) and it converts the string to a proper list element
before appending.
\fBTcl_DStringAppendElement\fR adds a separator space before the
new list element unless the new list element is the first in a
list or sub-list (i.e. either the current string is empty, or it
contains the single character ``{'', or the last two characters of
the current string are `` {'').
\fBTcl_DStringAppendElement\fR returns a pointer to the
characters of the new string.
.PP
\fBTcl_DStringStartSublist\fR and \fBTcl_DStringEndSublist\fR can be
used to create nested lists.
To append a list element that is itself a sublist, first
call \fBTcl_DStringStartSublist\fR, then call \fBTcl_DStringAppendElement\fR
for each of the elements in the sublist, then call
\fBTcl_DStringEndSublist\fR to end the sublist.
\fBTcl_DStringStartSublist\fR appends a space character if needed,
followed by an open brace; \fBTcl_DStringEndSublist\fR appends
a close brace.
Lists can be nested to any depth.
.PP
\fBTcl_DStringLength\fR is a macro that returns the current length
of a dynamic string (not including the terminating null character).
\fBTcl_DStringValue\fR is a macro that returns a pointer to the
current contents of a dynamic string.
.PP
.PP
\fBTcl_DStringSetLength\fR changes the length of a dynamic string.
If \fInewLength\fR is less than the string's current length, then
the string is truncated.
If \fInewLength\fR is greater than the string's current length,
then the string will become longer and new space will be allocated
for the string if needed.
However, \fBTcl_DStringSetLength\fR will not initialize the new
space except to provide a terminating null character; it is up to the
caller to fill in the new space.
\fBTcl_DStringSetLength\fR does not free up the string's storage space
even if the string is truncated to zero length, so \fBTcl_DStringFree\fR
will still need to be called.
.PP
\fBTcl_DStringTrunc\fR changes the length of a dynamic string.
This procedure is now deprecated. \fBTcl_DStringSetLength\fR should
be used instead.
.PP
\fBTcl_DStringFree\fR should be called when you're finished using
the string. It frees up any memory that was allocated for the string
and reinitializes the string's value to an empty string.
.PP
\fBTcl_DStringResult\fR sets the result of \fIinterp\fR to the value of
the dynamic string given by \fIdsPtr\fR. It does this by moving
a pointer from \fIdsPtr\fR to the interpreter's result.
This saves the cost of allocating new memory and copying the string.
\fBTcl_DStringResult\fR also reinitializes the dynamic string to
an empty string.
.PP
\fBTcl_DStringGetResult\fR does the opposite of \fBTcl_DStringResult\fR.
It sets the value of \fIdsPtr\fR to the result of \fIinterp\fR and
it clears \fIinterp\fR's result.
If possible it does this by moving a pointer rather than by copying
the string.
.SH KEYWORDS
append, dynamic string, free, result
tcl8.4.20/doc/load.n 0000644 0036047 0045461 00000014734 11737050674 012573 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH load n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
load \- Load machine code and initialize new commands.
.SH SYNOPSIS
\fBload \fIfileName\fR
.br
\fBload \fIfileName packageName\fR
.br
\fBload \fIfileName packageName interp\fR
.BE
.SH DESCRIPTION
.PP
This command loads binary code from a file into the
application's address space and calls an initialization procedure
in the package to incorporate it into an interpreter. \fIfileName\fR
is the name of the file containing the code; its exact form varies
from system to system but on most systems it is a shared library,
such as a \fB.so\fR file under Solaris or a DLL under Windows.
\fIpackageName\fR is the name of the package, and is used to
compute the name of an initialization procedure.
\fIinterp\fR is the path name of the interpreter into which to load
the package (see the \fBinterp\fR manual entry for details);
if \fIinterp\fR is omitted, it defaults to the
interpreter in which the \fBload\fR command was invoked.
.PP
Once the file has been loaded into the application's address space,
one of two initialization procedures will be invoked in the new code.
Typically the initialization procedure will add new commands to a
Tcl interpreter.
The name of the initialization procedure is determined by
\fIpackageName\fR and whether or not the target interpreter
is a safe one. For normal interpreters the name of the initialization
procedure will have the form \fIpkg\fB_Init\fR, where \fIpkg\fR
is the same as \fIpackageName\fR except that the first letter is
converted to upper case and all other letters
are converted to lower case. For example, if \fIpackageName\fR is
\fBfoo\fR or \fBFOo\fR, the initialization procedure's name will
be \fBFoo_Init\fR.
.PP
If the target interpreter is a safe interpreter, then the name
of the initialization procedure will be \fIpkg\fB_SafeInit\fR
instead of \fIpkg\fB_Init\fR.
The \fIpkg\fB_SafeInit\fR function should be written carefully, so that it
initializes the safe interpreter only with partial functionality provided
by the package that is safe for use by untrusted code. For more information
on Safe\-Tcl, see the \fBsafe\fR manual entry.
.PP
The initialization procedure must match the following prototype:
.CS
typedef int Tcl_PackageInitProc(Tcl_Interp *\fIinterp\fR);
.CE
The \fIinterp\fR argument identifies the interpreter in which the
package is to be loaded. The initialization procedure must return
\fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed
successfully; in the event of an error it should set the interpreter's result
to point to an error message. The result of the \fBload\fR command
will be the result returned by the initialization procedure.
.PP
The actual loading of a file will only be done once for each \fIfileName\fR
in an application. If a given \fIfileName\fR is loaded into multiple
interpreters, then the first \fBload\fR will load the code and
call the initialization procedure; subsequent \fBload\fRs will
call the initialization procedure without loading the code again.
It is not possible to unload or reload a package.
.PP
The \fBload\fR command also supports packages that are statically
linked with the application, if those packages have been registered
by calling the \fBTcl_StaticPackage\fR procedure.
If \fIfileName\fR is an empty string, then \fIpackageName\fR must
be specified.
.PP
If \fIpackageName\fR is omitted or specified as an empty string,
Tcl tries to guess the name of the package.
This may be done differently on different platforms.
The default guess, which is used on most UNIX platforms, is to
take the last element of \fIfileName\fR, strip off the first
three characters if they are \fBlib\fR, and use any following
.VS
alphabetic and underline characters as the module name.
.VE
For example, the command \fBload libxyz4.2.so\fR uses the module
name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the
module name \fBlast\fR.
.VS "" br
.PP
If \fIfileName\fR is an empty string, then \fIpackageName\fR must
be specified.
The \fBload\fR command first searches for a statically loaded package
(one that has been registered by calling the \fBTcl_StaticPackage\fR
procedure) by that name; if one is found, it is used.
Otherwise, the \fBload\fR command searches for a dynamically loaded
package by that name, and uses it if it is found. If several
different files have been \fBload\fRed with different versions of
the package, Tcl picks the file that was loaded first.
.VE
.SH "PORTABILITY ISSUES"
.TP
\fBWindows\fR\0\0\0\0\0
.
When a load fails with "library not found" error, it is also possible
that a dependent library was not found. To see the dependent libraries,
type ``dumpbin -imports '' in a DOS console to see what the
library must import.
When loading a DLL in the current directory, Windows will ignore ``./'' as
a path specifier and use a search heuristic to find the DLL instead.
To avoid this, load the DLL with:
.CS
\fBload\fR [file join [pwd] mylib.DLL]
.CE
.SH BUGS
.PP
If the same file is \fBload\fRed by different \fIfileName\fRs, it will
be loaded into the process's address space multiple times. The
behavior of this varies from system to system (some systems may
detect the redundant loads, others may not).
.SH EXAMPLE
The following is a minimal extension:
.PP
.CS
#include
#include
static int fooCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
printf("called with %d arguments\\n", objc);
return TCL_OK;
}
int Foo_Init(Tcl_Interp *interp) {
if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
return TCL_ERROR;
}
printf("creating foo command");
Tcl_CreateObjCommand(interp, "foo", fooCmd, NULL, NULL);
return TCL_OK;
}
.CE
.PP
When built into a shared/dynamic library with a suitable name
(e.g. \fBfoo.dll\fR on Windows, \fBlibfoo.so\fR on Solaris and Linux)
it can then be loaded into Tcl with the following:
.PP
.CS
# Load the extension
switch $tcl_platform(platform) {
windows {
\fBload\fR [file join [pwd] foo.dll]
}
unix {
\fBload\fR [file join [pwd] libfoo[info sharedlibextension]]
}
}
# Now execute the command defined by the extension
foo
.CE
.SH "SEE ALSO"
info sharedlibextension, Tcl_StaticPackage(3), safe(n)
.SH KEYWORDS
binary code, loading, safe interpreter, shared library
tcl8.4.20/doc/CallDel.3 0000644 0036047 0045461 00000004141 11737050674 013050 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_CallWhenDeleted 3 7.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CallWhenDeleted, Tcl_DontCallWhenDeleted \- Arrange for callback when interpreter is deleted
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_CallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR)
.sp
\fBTcl_DontCallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR)
.SH ARGUMENTS
.AS Tcl_InterpDeleteProc clientData
.AP Tcl_Interp *interp in
Interpreter with which to associated callback.
.AP Tcl_InterpDeleteProc *proc in
Procedure to call when \fIinterp\fR is deleted.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CallWhenDeleted\fR arranges for \fIproc\fR to be called by
\fBTcl_DeleteInterp\fR if/when \fIinterp\fR is deleted at some future
time. \fIProc\fR will be invoked just before the interpreter
is deleted, but the interpreter will still be valid at the
time of the call.
\fIProc\fR should have arguments and result that match the
type \fBTcl_InterpDeleteProc\fR:
.CS
typedef void Tcl_InterpDeleteProc(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
The \fIclientData\fR and \fIinterp\fR parameters are
copies of the \fIclientData\fR and \fIinterp\fR arguments given
to \fBTcl_CallWhenDeleted\fR.
Typically, \fIclientData\fR points to an application-specific
data structure that \fIproc\fR uses to perform cleanup when an
interpreter is about to go away.
\fIProc\fR does not return a value.
.PP
\fBTcl_DontCallWhenDeleted\fR cancels a previous call to
\fBTcl_CallWhenDeleted\fR with the same arguments, so that
\fIproc\fR won't be called after all when \fIinterp\fR is
deleted.
If there is no deletion callback that matches \fIinterp\fR,
\fIproc\fR, and \fIclientData\fR then the call to
\fBTcl_DontCallWhenDeleted\fR has no effect.
.SH KEYWORDS
callback, delete, interpreter
tcl8.4.20/doc/packagens.n 0000644 0036047 0045461 00000003614 11737050674 013603 0 ustar dgp 771div '\"
'\" Copyright (c) 1998-2000 by Scriptics Corporation.
'\" All rights reserved.
'\"
.so man.macros
.TH pkg::create n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
pkg::create \- Construct an appropriate \fBpackage ifneeded\fR
command for a given package specification
.SH SYNOPSIS
\fB::pkg::create \fI\-name packageName\fR \fI\-version packageVersion\fR ?\fI\-load filespec\fR? ... ?\fI\-source filespec\fR? ...
.BE
.SH DESCRIPTION
.PP
\fB::pkg::create\fR is a utility procedure that is part of the standard Tcl
library. It is used to create an appropriate \fBpackage ifneeded\fR
command for a given package specification. It can be used to construct a
\fBpkgIndex.tcl\fR file for use with the \fBpackage\fR mechanism.
.SH OPTIONS
The parameters supported are:
.TP
\fB\-name\fR\0\fIpackageName\fR
This parameter specifies the name of the package. It is required.
.TP
\fB\-version\fR\0\fIpackageVersion\fR
This parameter specifies the version of the package. It is required.
.TP
\fB\-load\fR\0\fIfilespec\fR
This parameter specifies a binary library that must be loaded with the
\fBload\fR command. \fIfilespec\fR is a list with two elements. The
first element is the name of the file to load. The second, optional
element is a list of commands supplied by loading that file. If the
list of procedures is empty or omitted, \fB::pkg::create\fR will
set up the library for direct loading (see \fBpkg_mkIndex\fR). Any
number of \fB\-load\fR parameters may be specified.
.TP
\fB\-source\fR\0\fIfilespec\fR
This parameter is similar to the \fB\-load\fR parameter, except that it
specifies a Tcl library that must be loaded with the
\fBsource\fR command. Any number of \fB\-source\fR parameters may be
specified.
.PP
At least one \fB\-load\fR or \fB\-source\fR parameter must be given.
.SH "SEE ALSO"
package(n)
.SH KEYWORDS
auto-load, index, package, version
tcl8.4.20/doc/cd.n 0000644 0036047 0045461 00000002157 11737050674 012236 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH cd n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
cd \- Change working directory
.SH SYNOPSIS
\fBcd \fR?\fIdirName\fR?
.BE
.SH DESCRIPTION
.PP
Change the current working directory to \fIdirName\fR, or to the
home directory (as specified in the HOME environment variable) if
\fIdirName\fR is not given.
Returns an empty string.
Note that the current working directory is a per-process resource; the
\fBcd\fR command changes the working directory for all interpreters
and (in a threaded environment) all threads.
.SH EXAMPLES
Change to the home directory of the user \fBfred\fR:
.CS
\fBcd\fR ~fred
.CE
.PP
Change to the directory \fBlib\fR that is a sibling directory of the
current one:
.CS
\fBcd\fR ../lib
.CE
.SH "SEE ALSO"
filename(n), glob(n), pwd(n)
.SH KEYWORDS
working directory
tcl8.4.20/doc/RecEvalObj.3 0000644 0036047 0045461 00000003556 11737050674 013535 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_RecordAndEvalObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_RecordAndEvalObj \- save command on history list before evaluating
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_RecordAndEvalObj\fR(\fIinterp, cmdPtr, flags\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp;
.AP Tcl_Interp *interp in
Tcl interpreter in which to evaluate command.
.AP Tcl_Obj *cmdPtr in
Points to a Tcl object containing a command (or sequence of commands)
to execute.
.AP int flags in
An OR'ed combination of flag bits. TCL_NO_EVAL means record the
command but don't evaluate it. TCL_EVAL_GLOBAL means evaluate
the command at global level instead of the current stack level.
.BE
.SH DESCRIPTION
.PP
\fBTcl_RecordAndEvalObj\fR is invoked to record a command as an event
on the history list and then execute it using \fBTcl_EvalObjEx\fR
(or \fBTcl_GlobalEvalObj\fR if the TCL_EVAL_GLOBAL bit is set
in \fIflags\fR).
It returns a completion code such as TCL_OK just like \fBTcl_EvalObjEx\fR,
as well as a result object containing additional information
(a result value or error message)
that can be retrieved using \fBTcl_GetObjResult\fR.
If you don't want the command recorded on the history list then
you should invoke \fBTcl_EvalObjEx\fR instead of \fBTcl_RecordAndEvalObj\fR.
Normally \fBTcl_RecordAndEvalObj\fR is only called with top-level
commands typed by the user, since the purpose of history is to
allow the user to re-issue recently-invoked commands.
If the \fIflags\fR argument contains the TCL_NO_EVAL bit then
the command is recorded without being evaluated.
.SH "SEE ALSO"
Tcl_EvalObjEx, Tcl_GetObjResult
.SH KEYWORDS
command, event, execute, history, interpreter, object, record
tcl8.4.20/doc/uplevel.n 0000644 0036047 0045461 00000007521 11737050674 013324 0 ustar dgp 771div '\"
'\" Copyright (c) 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.
'\"
.so man.macros
.TH uplevel n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
uplevel \- Execute a script in a different stack frame
.SH SYNOPSIS
\fBuplevel \fR?\fIlevel\fR?\fI arg \fR?\fIarg ...\fR?
.BE
.SH DESCRIPTION
.PP
All of the \fIarg\fR arguments are concatenated as if they had
been passed to \fBconcat\fR; the result is then evaluated in the
variable context indicated by \fIlevel\fR. \fBUplevel\fR returns
the result of that evaluation.
.PP
If \fIlevel\fR is an integer then
it gives a distance (up the procedure calling stack) to move before
executing the command. If \fIlevel\fR consists of \fB#\fR followed by
a number then the number gives an absolute level number. If \fIlevel\fR
is omitted then it defaults to \fB1\fR. \fILevel\fR cannot be
defaulted if the first \fIcommand\fR argument starts with a digit or \fB#\fR.
.PP
For example, suppose that procedure \fBa\fR was invoked
from top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR.
Suppose that \fBc\fR invokes the \fBuplevel\fR command. If \fIlevel\fR
is \fB1\fR or \fB#2\fR or omitted, then the command will be executed
in the variable context of \fBb\fR. If \fIlevel\fR is \fB2\fR or \fB#1\fR
then the command will be executed in the variable context of \fBa\fR.
If \fIlevel\fR is \fB3\fR or \fB#0\fR then the command will be executed
at top-level (only global variables will be visible).
.PP
The \fBuplevel\fR command causes the invoking procedure to disappear
from the procedure calling stack while the command is being executed.
In the above example, suppose \fBc\fR invokes the command
.CS
\fBuplevel\fR 1 {set x 43; d}
.CE
where \fBd\fR is another Tcl procedure. The \fBset\fR command will
modify the variable \fBx\fR in \fBb\fR's context, and \fBd\fR will execute
at level 3, as if called from \fBb\fR. If it in turn executes
the command
.CS
\fBuplevel\fR {set x 42}
.CE
then the \fBset\fR command will modify the same variable \fBx\fR in \fBb\fR's
context: the procedure \fBc\fR does not appear to be on the call stack
when \fBd\fR is executing. The command ``\fBinfo level\fR'' may
be used to obtain the level of the current procedure.
.PP
\fBUplevel\fR makes it possible to implement new control
constructs as Tcl procedures (for example, \fBuplevel\fR could
be used to implement the \fBwhile\fR construct as a Tcl procedure).
.PP
\fBnamespace eval\fR is another way (besides procedure calls)
that the Tcl naming context can change.
It adds a call frame to the stack to represent the namespace context.
This means each \fBnamespace eval\fR command
counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
For example, \fBinfo level 1\fR will return a list
describing a command that is either
the outermost procedure call or the outermost \fBnamespace eval\fR command.
Also, \fBuplevel #0\fR evaluates a script
at top-level in the outermost namespace (the global namespace).
.SH EXAMPLE
As stated above, the \fBuplevel\fR command is useful for creating new
control constructs. This example shows how (without error handling)
it can be used to create a \fBdo\fR command that is the counterpart of
\fBwhile\fR except for always performing the test after running the
loop body:
.CS
proc do {body while condition} {
if {$while ne "while"} {
error "required word missing"
}
set conditionCmd [list expr $condition]
while {1} {
\fBuplevel\fR 1 $body
if {![\fBuplevel\fR 1 $conditionCmd]} {
break
}
}
}
.CE
.SH "SEE ALSO"
namespace(n), upvar(n)
.SH KEYWORDS
context, level, namespace, stack frame, variables
tcl8.4.20/doc/http.n 0000644 0036047 0045461 00000047707 11737050674 012641 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1998-2000 by Ajuba Solutions.
'\" Copyright (c) 2004 ActiveState Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH "http" n 2.5 http "Tcl Bundled Packages"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
http \- Client-side implementation of the HTTP/1.0 protocol.
.SH SYNOPSIS
\fBpackage require http ?2.5?\fR
.sp
\fB::http::config \fI?options?\fR
.sp
\fB::http::geturl \fIurl ?options?\fR
.sp
\fB::http::formatQuery\fP \fIkey value\fP ?\fIkey value\fP ...?
.sp
\fB::http::reset\fP \fItoken\fP ?\fIwhy\fP?
.sp
\fB::http::wait \fItoken\fR
.sp
\fB::http::status \fItoken\fR
.sp
\fB::http::size \fItoken\fR
.sp
\fB::http::code \fItoken\fR
.sp
\fB::http::ncode \fItoken\fR
.sp
\fB::http::meta \fItoken\fR
.sp
\fB::http::data \fItoken\fR
.sp
\fB::http::error \fItoken\fR
.sp
\fB::http::cleanup \fItoken\fR
.sp
\fB::http::register \fIproto port command\fR
.sp
\fB::http::unregister \fIproto\fR
.BE
.SH DESCRIPTION
.PP
The \fBhttp\fR package provides the client side of the HTTP/1.0
protocol. The package implements the GET, POST, and HEAD operations
of HTTP/1.0. It allows configuration of a proxy host to get through
firewalls. The package is compatible with the \fBSafesock\fR security
policy, so it can be used by untrusted applets to do URL fetching from
a restricted set of hosts. This package can be extended to support
additional HTTP transport protocols, such as HTTPS, by providing
a custom \fBsocket\fR command, via \fB::http::register\fR.
.PP
The \fB::http::geturl\fR procedure does a HTTP transaction.
Its \fIoptions \fR determine whether a GET, POST, or HEAD transaction
is performed.
The return value of \fB::http::geturl\fR is a token for the transaction.
The value is also the name of an array in the ::http namespace
that contains state information about the transaction. The elements
of this array are described in the STATE ARRAY section.
.PP
If the \fB-command\fP option is specified, then
the HTTP operation is done in the background.
\fB::http::geturl\fR returns immediately after generating the
HTTP request and the callback is invoked
when the transaction completes. For this to work, the Tcl event loop
must be active. In Tk applications this is always true. For pure-Tcl
applications, the caller can use \fB::http::wait\fR after calling
\fB::http::geturl\fR to start the event loop.
.SH COMMANDS
.TP
\fB::http::config\fP ?\fIoptions\fR?
The \fB::http::config\fR command is used to set and query the name of the
proxy server and port, and the User-Agent name used in the HTTP
requests. If no options are specified, then the current configuration
is returned. If a single argument is specified, then it should be one
of the flags described below. In this case the current value of
that setting is returned. Otherwise, the options should be a set of
flags and values that define the configuration:
.RS
.TP
\fB\-accept\fP \fImimetypes\fP
The Accept header of the request. The default is */*, which means that
all types of documents are accepted. Otherwise you can supply a
comma-separated list of mime type patterns that you are
willing to receive. For example, "image/gif, image/jpeg, text/*".
.TP
\fB\-proxyhost\fP \fIhostname\fP
The name of the proxy host, if any. If this value is the
empty string, the URL host is contacted directly.
.TP
\fB\-proxyport\fP \fInumber\fP
The proxy port number.
.TP
\fB\-proxyfilter\fP \fIcommand\fP
The command is a callback that is made during
\fB::http::geturl\fR
to determine if a proxy is required for a given host. One argument, a
host name, is added to \fIcommand\fR when it is invoked. If a proxy
is required, the callback should return a two-element list containing
the proxy server and proxy port. Otherwise the filter should return
an empty list. The default filter returns the values of the
\fB\-proxyhost\fR and \fB\-proxyport\fR settings if they are
non-empty.
.TP
\fB\-urlencoding\fP \fIencoding\fP
The \fIencoding\fR used for creating the x-url-encoded URLs with
\fB::http::formatQuery\fR. The default is \fButf-8\fR, as specified by RFC
2718. Prior to http 2.5 this was unspecified, and that behavior can be
returned by specifying the empty string (\fB{}\fR), although
\fIiso8859-1\fR is recommended to restore similar behavior but without the
\fB::http::formatQuery\fR throwing an error processing non-latin-1
characters.
.TP
\fB\-useragent\fP \fIstring\fP
The value of the User-Agent header in the HTTP request. The default
is \fB"Tcl http client package 2.4."\fR
.RE
.TP
\fB::http::geturl\fP \fIurl\fP ?\fIoptions\fP?
The \fB::http::geturl\fR command is the main procedure in the package.
The \fB\-query\fR option causes a POST operation and
the \fB\-validate\fR option causes a HEAD operation;
otherwise, a GET operation is performed. The \fB::http::geturl\fR command
returns a \fItoken\fR value that can be used to get
information about the transaction. See the STATE ARRAY and ERRORS section for
details. The \fB::http::geturl\fR command blocks until the operation
completes, unless the \fB\-command\fR option specifies a callback
that is invoked when the HTTP transaction completes.
\fB::http::geturl\fR takes several options:
.RS
.TP
\fB\-binary\fP \fIboolean\fP
Specifies whether to force interpreting the URL data as binary. Normally
this is auto-detected (anything not beginning with a \fBtext\fR content
type or whose content encoding is \fBgzip\fR or \fBcompress\fR is
considered binary data).
.TP
\fB\-blocksize\fP \fIsize\fP
The block size used when reading the URL.
At most \fIsize\fR bytes are read at once. After each block, a call to the
\fB\-progress\fR callback is made (if that option is specified).
.TP
\fB\-channel\fP \fIname\fP
Copy the URL contents to channel \fIname\fR instead of saving it in
\fBstate(body)\fR.
.TP
\fB\-command\fP \fIcallback\fP
Invoke \fIcallback\fP after the HTTP transaction completes.
This option causes \fB::http::geturl\fP to return immediately.
The \fIcallback\fP gets an additional argument that is the \fItoken\fR returned
from \fB::http::geturl\fR. This token is the name of an array that is
described in the STATE ARRAY section. Here is a template for the
callback:
.RS
.CS
proc httpCallback {token} {
upvar #0 $token state
# Access state as a Tcl array
}
.CE
.RE
.TP
\fB\-handler\fP \fIcallback\fP
Invoke \fIcallback\fP whenever HTTP data is available; if present, nothing
else will be done with the HTTP data. This procedure gets two additional
arguments: the socket for the HTTP data and the \fItoken\fR returned from
\fB::http::geturl\fR. The token is the name of a global array that is described
in the STATE ARRAY section. The procedure is expected to return the number
of bytes read from the socket. Here is a template for the callback:
.RS
.CS
proc httpHandlerCallback {socket token} {
upvar #0 $token state
# Access socket, and state as a Tcl array
...
(example: set data [read $socket 1000];set nbytes [string length $data])
...
return nbytes
}
.CE
.RE
.TP
\fB\-headers\fP \fIkeyvaluelist\fP
This option is used to add extra headers to the HTTP request. The
\fIkeyvaluelist\fR argument must be a list with an even number of
elements that alternate between keys and values. The keys become
header field names. Newlines are stripped from the values so the
header cannot be corrupted. For example, if \fIkeyvaluelist\fR is
\fBPragma no-cache\fR then the following header is included in the
HTTP request:
.CS
Pragma: no-cache
.CE
.TP
\fB\-progress\fP \fIcallback\fP
The \fIcallback\fR is made after each transfer of data from the URL.
The callback gets three additional arguments: the \fItoken\fR from
\fB::http::geturl\fR, the expected total size of the contents from the
\fBContent-Length\fR meta-data, and the current number of bytes
transferred so far. The expected total size may be unknown, in which
case zero is passed to the callback. Here is a template for the
progress callback:
.RS
.CS
proc httpProgress {token total current} {
upvar #0 $token state
}
.CE
.RE
.TP
\fB\-query\fP \fIquery\fP
This flag causes \fB::http::geturl\fR to do a POST request that passes the
\fIquery\fR to the server. The \fIquery\fR must be an x-url-encoding
formatted query. The \fB::http::formatQuery\fR procedure can be used to
do the formatting.
.TP
\fB\-queryblocksize\fP \fIsize\fP
The block size used when posting query data to the URL.
At most
\fIsize\fR
bytes are written at once. After each block, a call to the
\fB\-queryprogress\fR
callback is made (if that option is specified).
.TP
\fB\-querychannel\fP \fIchannelID\fP
This flag causes \fB::http::geturl\fR to do a POST request that passes the
data contained in \fIchannelID\fR to the server. The data contained in
\fIchannelID\fR must be an x-url-encoding
formatted query unless the \fB\-type\fP option below is used.
If a Content-Length header is not specified via the \fB\-headers\fR options,
\fB::http::geturl\fR attempts to determine the size of the post data
in order to create that header. If it is
unable to determine the size, it returns an error.
.TP
\fB\-queryprogress\fP \fIcallback\fP
The \fIcallback\fR is made after each transfer of data to the URL
(i.e. POST) and acts exactly like the \fB\-progress\fR option (the
callback format is the same).
.TP
\fB\-timeout\fP \fImilliseconds\fP
If \fImilliseconds\fR is non-zero, then \fB::http::geturl\fR sets up a timeout
to occur after the specified number of milliseconds.
A timeout results in a call to \fB::http::reset\fP and to
the \fB-command\fP callback, if specified.
The return value of \fB::http::status\fP is \fBtimeout\fP
after a timeout has occurred.
.TP
\fB\-type\fP \fImime-type\fP
Use \fImime-type\fR as the \fBContent-Type\fR value, instead of the
default value (\fBapplication/x-www-form-urlencoded\fR) during a
POST operation.
.TP
\fB\-validate\fP \fIboolean\fP
If \fIboolean\fR is non-zero, then \fB::http::geturl\fR does an HTTP HEAD
request. This request returns meta information about the URL, but the
contents are not returned. The meta information is available in the
\fBstate(meta) \fR variable after the transaction. See the STATE
ARRAY section for details.
.RE
.TP
\fB::http::formatQuery\fP \fIkey value\fP ?\fIkey value\fP ...?
This procedure does x-url-encoding of query data. It takes an even
number of arguments that are the keys and values of the query. It
encodes the keys and values, and generates one string that has the
proper & and = separators. The result is suitable for the
\fB\-query\fR value passed to \fB::http::geturl\fR.
.TP
\fB::http::reset\fP \fItoken\fP ?\fIwhy\fP?
This command resets the HTTP transaction identified by \fItoken\fR, if
any. This sets the \fBstate(status)\fP value to \fIwhy\fP, which defaults to \fBreset\fR, and then calls the registered \fB\-command\fR callback.
.TP
\fB::http::wait\fP \fItoken\fP
This is a convenience procedure that blocks and waits for the
transaction to complete. This only works in trusted code because it
uses \fBvwait\fR. Also, it's not useful for the case where
\fB::http::geturl\fP is called \fIwithout\fP the \fB-command\fP option
because in this case the \fB::http::geturl\fP call doesn't return
until the HTTP transaction is complete, and thus there's nothing to
wait for.
.TP
\fB::http::data\fP \fItoken\fP
This is a convenience procedure that returns the \fBbody\fP element
(i.e., the URL data) of the state array.
.TP
\fB::http::error\fP \fItoken\fP
This is a convenience procedure that returns the \fBerror\fP element
of the state array.
.TP
\fB::http::status\fP \fItoken\fP
This is a convenience procedure that returns the \fBstatus\fP element of
the state array.
.TP
\fB::http::code\fP \fItoken\fP
This is a convenience procedure that returns the \fBhttp\fP element of the
state array.
.TP
\fB::http::ncode\fP \fItoken\fP
This is a convenience procedure that returns just the numeric return
code (200, 404, etc.) from the \fBhttp\fP element of the state array.
.TP
\fB::http::size\fP \fItoken\fP
This is a convenience procedure that returns the \fBcurrentsize\fP
element of the state array, which represents the number of bytes
received from the URL in the \fB::http::geturl\fP call.
.TP
\fB::http::meta\fP \fItoken\fP
This is a convenience procedure that returns the \fBmeta\fP
element of the state array which contains the HTTP response
headers. See below for an explanation of this element.
.TP
\fB::http::cleanup\fP \fItoken\fP
This procedure cleans up the state associated with the connection
identified by \fItoken\fP. After this call, the procedures
like \fB::http::data\fP cannot be used to get information
about the operation. It is \fIstrongly\fP recommended that you call
this function after you're done with a given HTTP request. Not doing
so will result in memory not being freed, and if your app calls
\fB::http::geturl\fP enough times, the memory leak could cause a
performance hit...or worse.
.TP
\fB::http::register\fP \fIproto port command\fP
This procedure allows one to provide custom HTTP transport types
such as HTTPS, by registering a prefix, the default port, and the
command to execute to create the Tcl \fBchannel\fR. E.g.:
.RS
.CS
package require http
package require tls
::http::register https 443 ::tls::socket
set token [::http::geturl https://my.secure.site/]
.CE
.RE
.TP
\fB::http::unregister\fP \fIproto\fP
This procedure unregisters a protocol handler that was previously
registered via \fB::http::register\fR.
.SH "ERRORS"
The \fB::http::geturl\fP procedure will raise errors in the following cases:
invalid command line options,
an invalid URL,
a URL on a non-existent host,
or a URL at a bad port on an existing host.
These errors mean that it
cannot even start the network transaction.
It will also raise an error if it gets an I/O error while
writing out the HTTP request header.
For synchronous \fB::http::geturl\fP calls (where \fB-command\fP is
not specified), it will raise an error if it gets an I/O error while
reading the HTTP reply headers or data. Because \fB::http::geturl\fP
doesn't return a token in these cases, it does all the required
cleanup and there's no issue of your app having to call
\fB::http::cleanup\fP.
.PP
For asynchronous \fB::http::geturl\fP calls, all of the above error
situations apply, except that if there's any error while
reading the
HTTP reply headers or data, no exception is thrown. This is because
after writing the HTTP headers, \fB::http::geturl\fP returns, and the
rest of the HTTP transaction occurs in the background. The command
callback can check if any error occurred during the read by calling
\fB::http::status\fP to check the status and if its \fIerror\fP,
calling \fB::http::error\fP to get the error message.
.PP
Alternatively, if the main program flow reaches a point where it needs
to know the result of the asynchronous HTTP request, it can call
\fB::http::wait\fP and then check status and error, just as the
callback does.
.PP
In any case, you must still call
\fB::http::cleanup\fP to delete the state array when you're done.
.PP
There are other possible results of the HTTP transaction
determined by examining the status from \fB::http::status\fP.
These are described below.
.TP
ok
If the HTTP transaction completes entirely, then status will be \fBok\fP.
However, you should still check the \fB::http::code\fP value to get
the HTTP status. The \fB::http::ncode\fP procedure provides just
the numeric error (e.g., 200, 404 or 500) while the \fB::http::code\fP
procedure returns a value like "HTTP 404 File not found".
.TP
eof
If the server closes the socket without replying, then no error
is raised, but the status of the transaction will be \fBeof\fP.
.TP
error
The error message will also be stored in the \fBerror\fP status
array element, accessible via \fB::http::error\fP.
.PP
Another error possibility is that \fB::http::geturl\fP is unable to
write all the post query data to the server before the server
responds and closes the socket.
The error message is saved in the \fBposterror\fP status array
element and then \fB::http::geturl\fP attempts to complete the
transaction.
If it can read the server's response
it will end up with an \fBok\fP status, otherwise it will have
an \fBeof\fP status.
.SH "STATE ARRAY"
The \fB::http::geturl\fR procedure returns a \fItoken\fR that can be used to
get to the state of the HTTP transaction in the form of a Tcl array.
Use this construct to create an easy-to-use array variable:
.CS
upvar #0 $token state
.CE
Once the data associated with the URL is no longer needed, the state
array should be unset to free up storage.
The \fB::http::cleanup\fP procedure is provided for that purpose.
The following elements of
the array are supported:
.RS
.TP
\fBbody\fR
The contents of the URL. This will be empty if the \fB\-channel\fR
option has been specified. This value is returned by the \fB::http::data\fP command.
.TP
\fBcharset\fR
The value of the charset attribute from the \fBContent-Type\fR meta-data
value. If none was specified, this defaults to the RFC standard
\fBiso8859-1\fR, or the value of \fB$::http::defaultCharset\fR. Incoming
text data will be automatically converted from this charset to utf-8.
.TP
\fBcoding\fR
A copy of the \fBContent-Encoding\fR meta-data value.
.TP
\fBcurrentsize\fR
The current number of bytes fetched from the URL.
This value is returned by the \fB::http::size\fP command.
.TP
\fBerror\fR
If defined, this is the error string seen when the HTTP transaction
was aborted.
.TP
\fBhttp\fR
The HTTP status reply from the server. This value
is returned by the \fB::http::code\fP command. The format of this value is:
.RS
.CS
\fIHTTP/1.0 code string\fP
.CE
The \fIcode\fR is a three-digit number defined in the HTTP standard.
A code of 200 is OK. Codes beginning with 4 or 5 indicate errors.
Codes beginning with 3 are redirection errors. In this case the
\fBLocation\fR meta-data specifies a new URL that contains the
requested information.
.RE
.TP
\fBmeta\fR
The HTTP protocol returns meta-data that describes the URL contents.
The \fBmeta\fR element of the state array is a list of the keys and
values of the meta-data. This is in a format useful for initializing
an array that just contains the meta-data:
.RS
.CS
array set meta $state(meta)
.CE
Some of the meta-data keys are listed below, but the HTTP standard defines
more, and servers are free to add their own.
.TP
\fBContent-Type\fR
The type of the URL contents. Examples include \fBtext/html\fR,
\fBimage/gif,\fR \fBapplication/postscript\fR and
\fBapplication/x-tcl\fR.
.TP
\fBContent-Length\fR
The advertised size of the contents. The actual size obtained by
\fB::http::geturl\fR is available as \fBstate(size)\fR.
.TP
\fBLocation\fR
An alternate URL that contains the requested data.
.RE
.TP
\fBposterror\fR
The error, if any, that occurred while writing
the post query data to the server.
.TP
\fBstatus\fR
Either \fBok\fR, for successful completion, \fBreset\fR for
user-reset, \fBtimeout\fP if a timeout occurred before the transaction
could complete, or \fBerror\fR for an error condition. During the
transaction this value is the empty string.
.TP
\fBtotalsize\fR
A copy of the \fBContent-Length\fR meta-data value.
.TP
\fBtype\fR
A copy of the \fBContent-Type\fR meta-data value.
.TP
\fBurl\fR
The requested URL.
.RE
.SH EXAMPLE
.CS
# Copy a URL to a file and print meta-data
proc httpcopy { url file {chunk 4096} } {
set out [open $file w]
set token [\fB::http::geturl\fR $url -channel $out \\
-progress httpCopyProgress -blocksize $chunk]
close $out
# This ends the line started by httpCopyProgress
puts stderr ""
upvar #0 $token state
set max 0
foreach {name value} $state(meta) {
if {[string length $name] > $max} {
set max [string length $name]
}
if {[regexp -nocase ^location$ $name]} {
# Handle URL redirects
puts stderr "Location:$value"
return [httpcopy [string trim $value] $file $chunk]
}
}
incr max
foreach {name value} $state(meta) {
puts [format "%-*s %s" $max $name: $value]
}
return $token
}
proc httpCopyProgress {args} {
puts -nonewline stderr .
flush stderr
}
.CE
.SH "SEE ALSO"
safe(n), socket(n), safesock(n)
.SH KEYWORDS
security policy, socket
tcl8.4.20/doc/SourceRCFile.3 0000644 0036047 0045461 00000001470 12052456743 014035 0 ustar dgp 771div '\"
'\" Copyright (c) 1998-2000 by Scriptics Corporation.
'\" All rights reserved.
'\"
.so man.macros
.TH Tcl_SourceRCFile 3 8.3 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SourceRCFile \- source the Tcl rc file
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
void
\fBTcl_SourceRCFile\fR(\fIinterp\fR)
.SH ARGUMENTS
.AP Tcl_Interp *interp in
Tcl interpreter to source rc file into.
.BE
.SH DESCRIPTION
.PP
\fBTcl_SourceRCFile\fR is used to source the Tcl rc file at startup.
It is typically invoked by Tcl_Main or Tk_Main. The name of the file
sourced is obtained from the global variable \fBtcl_rcFileName\fR in
the interpreter given by \fIinterp\fR. If this variable is not
defined, or if the file it indicates cannot be found, no action is
taken.
.SH KEYWORDS
application-specific initialization, main program, rc file
tcl8.4.20/doc/package.n 0000644 0036047 0045461 00000023010 11737050674 013232 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH package n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
package \- Facilities for package loading and version control
.SH SYNOPSIS
.nf
\fBpackage forget ?\fIpackage package ...\fR?
\fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR?
\fBpackage names\fR
\fBpackage present \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR?
\fBpackage provide \fIpackage \fR?\fIversion\fR?
\fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR?
\fBpackage unknown \fR?\fIcommand\fR?
\fBpackage vcompare \fIversion1 version2\fR
\fBpackage versions \fIpackage\fR
\fBpackage vsatisfies \fIversion1 version2\fR
.fi
.BE
.SH DESCRIPTION
.PP
This command keeps a simple database of the packages available for
use by the current interpreter and how to load them into the
interpreter.
It supports multiple versions of each package and arranges
for the correct version of a package to be loaded based on what
is needed by the application.
This command also detects and reports version clashes.
Typically, only the \fBpackage require\fR and \fBpackage provide\fR
commands are invoked in normal Tcl scripts; the other commands are used
primarily by system scripts that maintain the package database.
.PP
The behavior of the \fBpackage\fR command is determined by its first argument.
The following forms are permitted:
.TP
\fBpackage forget ?\fIpackage package ...\fR?
Removes all information about each specified package from this interpreter,
including information provided by both \fBpackage ifneeded\fR and
\fBpackage provide\fR.
.TP
\fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR?
This command typically appears only in system configuration
scripts to set up the package database.
It indicates that a particular version of
a particular package is available if needed, and that the package
can be added to the interpreter by executing \fIscript\fR.
The script is saved in a database for use by subsequent
\fBpackage require\fR commands; typically, \fIscript\fR
sets up auto-loading for the commands in the package (or calls
\fBload\fR and/or \fBsource\fR directly), then invokes
\fBpackage provide\fR to indicate that the package is present.
There may be information in the database for several different
versions of a single package.
If the database already contains information for \fIpackage\fR
and \fIversion\fR, the new \fIscript\fR replaces the existing
one.
If the \fIscript\fR argument is omitted, the current script for
version \fIversion\fR of package \fIpackage\fR is returned,
or an empty string if no \fBpackage ifneeded\fR command has
been invoked for this \fIpackage\fR and \fIversion\fR.
.TP
\fBpackage names\fR
Returns a list of the names of all packages in the
interpreter for which a version has been provided (via
\fBpackage provide\fR) or for which a \fBpackage ifneeded\fR
script is available.
The order of elements in the list is arbitrary.
.TP
\fBpackage present \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR?
This command is equivalent to \fBpackage require\fR except that it
does not try and load the package if it is not already loaded.
.TP
\fBpackage provide \fIpackage \fR?\fIversion\fR?
This command is invoked to indicate that version \fIversion\fR
of package \fIpackage\fR is now present in the interpreter.
It is typically invoked once as part of an \fBifneeded\fR script,
and again by the package itself when it is finally loaded.
An error occurs if a different version of \fIpackage\fR has been
provided by a previous \fBpackage provide\fR command.
If the \fIversion\fR argument is omitted, then the command
returns the version number that is currently provided, or an
empty string if no \fBpackage provide\fR command has been
invoked for \fIpackage\fR in this interpreter.
.TP
\fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR?
This command is typically invoked by Tcl code that wishes to use
a particular version of a particular package. The arguments
indicate which package is wanted, and the command ensures that
a suitable version of the package is loaded into the interpreter.
If the command succeeds, it returns the version number that is
loaded; otherwise it generates an error.
If both the \fB\-exact\fR
switch and the \fIversion\fR argument are specified then only the
given version is acceptable. If \fB\-exact\fR is omitted but
\fIversion\fR is specified, then versions later than \fIversion\fR
are also acceptable as long as they have the same major version
number as \fIversion\fR.
If both \fB\-exact\fR and \fIversion\fR are omitted then any
version whatsoever is acceptable.
If a version of \fIpackage\fR has already been provided (by invoking
the \fBpackage provide\fR command), then its version number must
satisfy the criteria given by \fB\-exact\fR and \fIversion\fR and
the command returns immediately.
Otherwise, the command searches the database of information provided by
previous \fBpackage ifneeded\fR commands to see if an acceptable
version of the package is available.
If so, the script for the highest acceptable version number is evaluated
in the global namespace;
it must do whatever is necessary to load the package,
including calling \fBpackage provide\fR for the package.
If the \fBpackage ifneeded\fR database does not contain an acceptable
version of the package and a \fBpackage unknown\fR command has been
specified for the interpreter then that command is evaluated in the
global namespace; when
it completes, Tcl checks again to see if the package is now provided
or if there is a \fBpackage ifneeded\fR script for it.
If all of these steps fail to provide an acceptable version of the
package, then the command returns an error.
.TP
\fBpackage unknown \fR?\fIcommand\fR?
This command supplies a ``last resort'' command to invoke during
\fBpackage require\fR if no suitable version of a package can be found
in the \fBpackage ifneeded\fR database.
If the \fIcommand\fR argument is supplied, it contains the first part
of a command; when the command is invoked during a \fBpackage require\fR
command, Tcl appends two additional arguments giving the desired package
name and version.
For example, if \fIcommand\fR is \fBfoo bar\fR and later the command
\fBpackage require test 2.4\fR is invoked, then Tcl will execute
the command \fBfoo bar test 2.4\fR to load the package.
If no version number is supplied to the \fBpackage require\fR command,
then the version argument for the invoked command will be an empty string.
If the \fBpackage unknown\fR command is invoked without a \fIcommand\fR
argument, then the current \fBpackage unknown\fR script is returned,
or an empty string if there is none.
If \fIcommand\fR is specified as an empty string, then the current
\fBpackage unknown\fR script is removed, if there is one.
.TP
\fBpackage vcompare \fIversion1 version2\fR
Compares the two version numbers given by \fIversion1\fR and \fIversion2\fR.
Returns -1 if \fIversion1\fR is an earlier version than \fIversion2\fR,
0 if they are equal, and 1 if \fIversion1\fR is later than \fBversion2\fR.
.TP
\fBpackage versions \fIpackage\fR
Returns a list of all the version numbers of \fIpackage\fR
for which information has been provided by \fBpackage ifneeded\fR
commands.
.TP
\fBpackage vsatisfies \fIversion1 version2\fR
Returns 1 if scripts written for \fIversion2\fR will work unchanged
with \fIversion1\fR (i.e. \fIversion1\fR is equal to or greater
than \fIversion2\fR and they both have the same major version
number), 0 otherwise.
.SH "VERSION NUMBERS"
.PP
Version numbers consist of one or more decimal numbers separated
by dots, such as 2 or 1.162 or 3.1.13.1.
The first number is called the major version number.
Larger numbers correspond to later versions of a package, with
leftmost numbers having greater significance.
For example, version 2.1 is later than 1.3 and version
3.4.6 is later than 3.3.5.
Missing fields are equivalent to zeroes: version 1.3 is the
same as version 1.3.0 and 1.3.0.0, so it is earlier than 1.3.1 or 1.3.0.2.
A later version number is assumed to be upwards compatible with
an earlier version number as long as both versions have the same
major version number.
For example, Tcl scripts written for version 2.3 of a package should
work unchanged under versions 2.3.2, 2.4, and 2.5.1.
Changes in the major version number signify incompatible changes:
if code is written to use version 2.1 of a package, it is not guaranteed
to work unmodified with either version 1.7.3 or version 3.1.
.SH "PACKAGE INDICES"
.PP
The recommended way to use packages in Tcl is to invoke \fBpackage require\fR
and \fBpackage provide\fR commands in scripts, and use the procedure
\fBpkg_mkIndex\fR to create package index files.
Once you've done this, packages will be loaded automatically
in response to \fBpackage require\fR commands.
See the documentation for \fBpkg_mkIndex\fR for details.
.SH EXAMPLES
To state that a Tcl script requires the Tk and http packages, put this
at the top of the script:
.CS
\fBpackage require\fR Tk
\fBpackage require\fR http
.CE
.PP
To test to see if the Snack package is available and load if it is
(often useful for optional enhancements to programs where the loss of
the functionality is not critical) do this:
.CS
if {[catch {\fBpackage require\fR Snack}]} {
# Error thrown - package not found.
# Set up a dummy interface to work around the absence
} else {
# We have the package, configure the app to use it
}
.CE
.SH "SEE ALSO"
msgcat(n), packagens(n), pkgMkIndex(n)
.SH KEYWORDS
package, version
tcl8.4.20/doc/CrtCloseHdlr.3 0000644 0036047 0045461 00000003371 11737050674 014104 0 ustar dgp 771div '\"
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_CreateCloseHandler 3 7.5 Tcl "Tcl Library Procedures"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_CreateCloseHandler, Tcl_DeleteCloseHandler \- arrange for callbacks when channels are closed
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
void
\fBTcl_CreateCloseHandler\fR(\fIchannel, proc, clientData\fR)
.sp
void
\fBTcl_DeleteCloseHandler\fR(\fIchannel, proc, clientData\fR)
.sp
.SH ARGUMENTS
.AS Tcl_CloseProc callbackData in
.AP Tcl_Channel channel in
The channel for which to create or delete a close callback.
.AP Tcl_CloseProc *proc in
The procedure to call as the callback.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CreateCloseHandler\fR arranges for \fIproc\fR to be called when
\fIchannel\fR is closed with \fBTcl_Close\fR or
\fBTcl_UnregisterChannel\fR, or using the Tcl \fBclose\fR command.
\fIProc\fR should match the following prototype:
.PP
.CS
typedef void Tcl_CloseProc(
ClientData \fIclientData\fR);
.CE
.PP
The \fIclientData\fR is the same as the value provided in the call to
\fBTcl_CreateCloseHandler\fR.
.PP
\fBTcl_DeleteCloseHandler\fR removes a close callback for \fIchannel\fR.
The \fIproc\fR and \fIclientData\fR identify which close callback to
remove; \fBTcl_DeleteCloseHandler\fR does nothing if its \fIproc\fR and
\fIclientData\fR arguments do not match the \fIproc\fR and \fIclientData\fR
for a close handler for \fIchannel\fR.
.SH "SEE ALSO"
close(n), Tcl_Close(3), Tcl_UnregisterChannel(3)
.SH KEYWORDS
callback, channel closing
tcl8.4.20/doc/proc.n 0000644 0036047 0045461 00000007265 11737050674 012620 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH proc n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
proc \- Create a Tcl procedure
.SH SYNOPSIS
\fBproc \fIname args body\fR
.BE
.SH DESCRIPTION
.PP
The \fBproc\fR command creates a new Tcl procedure named
\fIname\fR, replacing
any existing command or procedure there may have been by that name.
Whenever the new command is invoked, the contents of \fIbody\fR will
be executed by the Tcl interpreter.
Normally, \fIname\fR is unqualified
(does not include the names of any containing namespaces),
and the new procedure is created in the current namespace.
If \fIname\fR includes any namespace qualifiers,
the procedure is created in the specified namespace.
\fIArgs\fR specifies the formal arguments to the
procedure. It consists of a list, possibly empty, each of whose
elements specifies
one argument. Each argument specifier is also a list with either
one or two fields. If there is only a single field in the specifier
then it is the name of the argument; if there are two fields, then
the first is the argument name and the second is its default value.
.PP
When \fIname\fR is invoked a local variable
will be created for each of the formal arguments to the procedure; its
value will be the value of corresponding argument in the invoking command
or the argument's default value.
Arguments with default values need not be
specified in a procedure invocation. However, there must be enough
actual arguments for all the
formal arguments that don't have defaults, and there must not be any extra
actual arguments. There is one special case to permit procedures with
variable numbers of arguments. If the last formal argument has the name
\fBargs\fR, then a call to the procedure may contain more actual arguments
than the procedure has formals. In this case, all of the actual arguments
starting at the one that would be assigned to \fBargs\fR are combined into
a list (as if the \fBlist\fR command had been used); this combined value
is assigned to the local variable \fBargs\fR.
.PP
When \fIbody\fR is being executed, variable names normally refer to
local variables, which are created automatically when referenced and
deleted when the procedure returns. One local variable is automatically
created for each of the procedure's arguments.
Global variables can only be accessed by invoking
the \fBglobal\fR command or the \fBupvar\fR command.
Namespace variables can only be accessed by invoking
the \fBvariable\fR command or the \fBupvar\fR command.
.PP
The \fBproc\fR command returns an empty string. When a procedure is
invoked, the procedure's return value is the value specified in a
\fBreturn\fR command. If the procedure doesn't execute an explicit
\fBreturn\fR, then its return value is the value of the last command
executed in the procedure's body.
If an error occurs while executing the procedure
body, then the procedure-as-a-whole will return that same error.
.SH EXAMPLES
This is a procedure that accepts arbitrarily many arguments and prints
them out, one by one.
.CS
\fBproc\fR printArguments args {
foreach arg $args {
puts $arg
}
}
.CE
.PP
This procedure is a bit like the \fBincr\fR command, except it
multiplies the contents of the named variable by the value, which
defaults to \fB2\fR:
.CS
\fBproc\fR mult {varName {multiplier 2}} {
upvar 1 $varName var
set var [expr {$var * $multiplier}]
}
.CE
.SH "SEE ALSO"
info(n), unknown(n)
.SH KEYWORDS
argument, procedure
tcl8.4.20/doc/regexp.n 0000644 0036047 0045461 00000014250 11737050674 013137 0 ustar dgp 771div '\"
'\" Copyright (c) 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.
'\"
.so man.macros
.TH regexp n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
regexp \- Match a regular expression against a string
.SH SYNOPSIS
\fBregexp \fR?\fIswitches\fR? \fIexp string \fR?\fImatchVar\fR? ?\fIsubMatchVar subMatchVar ...\fR?
.BE
.SH DESCRIPTION
.PP
Determines whether the regular expression \fIexp\fR matches part or
all of \fIstring\fR and returns 1 if it does, 0 if it doesn't, unless
\fB-inline\fR is specified (see below).
(Regular expression matching is described in the \fBre_syntax\fR
reference page.)
.LP
If additional arguments are specified after \fIstring\fR then they
are treated as the names of variables in which to return
information about which part(s) of \fIstring\fR matched \fIexp\fR.
\fIMatchVar\fR will be set to the range of \fIstring\fR that
matched all of \fIexp\fR. The first \fIsubMatchVar\fR will contain
the characters in \fIstring\fR that matched the leftmost parenthesized
subexpression within \fIexp\fR, the next \fIsubMatchVar\fR will
contain the characters that matched the next parenthesized
subexpression to the right in \fIexp\fR, and so on.
.PP
If the initial arguments to \fBregexp\fR start with \fB\-\fR then
they are treated as switches. The following switches are
currently supported:
.TP 15
\fB\-about\fR
Instead of attempting to match the regular expression, returns a list
containing information about the regular expression. The first
element of the list is a subexpression count. The second element is a
list of property names that describe various attributes of the regular
expression. This switch is primarily intended for debugging purposes.
.TP 15
\fB\-expanded\fR
Enables use of the expanded regular expression syntax where
whitespace and comments are ignored. This is the same as specifying
the \fB(?x)\fR embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-indices\fR
Changes what is stored in the \fIsubMatchVar\fRs.
Instead of storing the matching characters from \fIstring\fR,
each variable
will contain a list of two decimal strings giving the indices
in \fIstring\fR of the first and last characters in the matching
range of characters.
.TP 15
\fB\-line\fR
Enables newline-sensitive matching. By default, newline is a
completely ordinary character with no special meaning. With this
flag, `[^' bracket expressions and `.' never match newline, `^'
matches an empty string after any newline in addition to its normal
function, and `$' matches an empty string before any newline in
addition to its normal function. This flag is equivalent to
specifying both \fB\-linestop\fR and \fB\-lineanchor\fR, or the
\fB(?n)\fR embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-linestop\fR
Changes the behavior of `[^' bracket expressions and `.' so that they
stop at newlines. This is the same as specifying the \fB(?p)\fR
embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-lineanchor\fR
Changes the behavior of `^' and `$' (the ``anchors'') so they match the
beginning and end of a line respectively. This is the same as
specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR
manual page).
.TP 15
\fB\-nocase\fR
Causes upper-case characters in \fIstring\fR to be treated as
lower case during the matching process.
.VS 8.3
.TP 15
\fB\-all\fR
Causes the regular expression to be matched as many times as possible
in the string, returning the total number of matches found. If this
is specified with match variables, they will contain information for
the last match only.
.TP 15
\fB\-inline\fR
Causes the command to return, as a list, the data that would otherwise
be placed in match variables. When using \fB-inline\fR,
match variables may not be specified. If used with \fB-all\fR, the
list will be concatenated at each iteration, such that a flat list is
always returned. For each match iteration, the command will append the
overall match data, plus one element for each subexpression in the
regular expression. Examples are:
.CS
regexp -inline -- {\\w(\\w)} " inlined "
=> {in n}
regexp -all -inline -- {\\w(\\w)} " inlined "
=> {in n li i ne e}
.CE
.TP 15
\fB\-start\fR \fIindex\fR
Specifies a character index offset into the string to start
matching the regular expression at. When using this switch, `^'
will not match the beginning of the line, and \\A will still
match the start of the string at \fIindex\fR. If \fB\-indices\fR
is specified, the indices will be indexed starting from the
absolute beginning of the input string.
\fIindex\fR will be constrained to the bounds of the input string.
.VE 8.3
.TP 15
\fB\-\|\-\fR
Marks the end of switches. The argument following this one will
be treated as \fIexp\fR even if it starts with a \fB\-\fR.
.PP
If there are more \fIsubMatchVar\fR's than parenthesized
subexpressions within \fIexp\fR, or if a particular subexpression
in \fIexp\fR doesn't match the string (e.g. because it was in a
portion of the expression that wasn't matched), then the corresponding
\fIsubMatchVar\fR will be set to ``\fB\-1 \-1\fR'' if \fB\-indices\fR
has been specified or to an empty string otherwise.
.SH EXAMPLES
Find the first occurrence of a word starting with \fBfoo\fR in a
string that is not actually an instance of \fBfoobar\fR, and get the
letters following it up to the end of the word into a variable:
.CS
\fBregexp\fR {\\)(\\w*)} $string \-> restOfWord
.CE
Note that the whole matched substring has been placed in the variable
\fB\->\fR which is a name chosen to look nice given that we are not
actually interested in its contents.
.PP
Find the index of the word \fBbadger\fR (in any case) within a string
and store that in the variable \fBlocation\fR:
.CS
\fBregexp\fR \-indices {(?i)\\} $string location
.CE
.PP
Count the number of octal digits in a string:
.CS
\fBregexp\fR \-all {[0\-7]} $string
.CE
.PP
List all words (consisting of all sequences of non-whitespace
characters) in a string:
.CS
\fBregexp\fR \-all \-inline {\\S+} $string
.CE
.SH "SEE ALSO"
re_syntax(n), regsub(n)
.SH KEYWORDS
match, regular expression, string
tcl8.4.20/doc/ParseCmd.3 0000644 0036047 0045461 00000050203 11737050674 013246 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_ParseCommand\fR(\fIinterp, string, numBytes, nested, parsePtr\fR)
.sp
int
\fBTcl_ParseExpr\fR(\fIinterp, string, numBytes, parsePtr\fR)
.sp
int
\fBTcl_ParseBraces\fR(\fIinterp, string, numBytes, parsePtr, append, termPtr\fR)
.sp
int
\fBTcl_ParseQuotedString\fR(\fIinterp, string, numBytes, parsePtr, append, termPtr\fR)
.sp
int
\fBTcl_ParseVarName\fR(\fIinterp, string, numBytes, parsePtr, append\fR)
.sp
CONST char *
\fBTcl_ParseVar\fR(\fIinterp, string, termPtr\fR)
.sp
\fBTcl_FreeParse\fR(\fIusedParsePtr\fR)
.sp
Tcl_Obj *
\fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR)
.sp
int
\fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR)
.SH ARGUMENTS
.AS Tcl_Interp *usedParsePtr
.AP Tcl_Interp *interp out
For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR
and \fBTcl_EvalTokensStandard\fR, used only for error reporting;
if NULL, then no error messages are left after errors.
For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR,
determines the context for evaluating the
script and also is used for error reporting; must not be NULL.
.AP "CONST char" *string in
Pointer to first character in string to parse.
.AP int numBytes in
Number of bytes in \fIstring\fR, not including any terminating null
character. If less than 0 then the script consists of all characters
in \fIstring\fR up to the first null character.
.AP int nested in
Non-zero means that the script is part of a command substitution so an
unquoted close bracket should be treated as a command terminator. If zero,
close brackets have no special meaning.
.AP int append in
Non-zero means that \fI*parsePtr\fR already contains valid tokens; the new
tokens should be appended to those already present. Zero means that
\fI*parsePtr\fR is uninitialized; any information in it is ignored.
This argument is normally 0.
.AP Tcl_Parse *parsePtr out
Points to structure to fill in with information about the parsed
command, expression, variable name, etc.
Any previous information in this structure
is ignored, unless \fIappend\fR is non-zero in a call to
\fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR,
or \fBTcl_ParseVarName\fR.
.AP "CONST char" **termPtr out
If not NULL, points to a location where
\fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and
\fBTcl_ParseVar\fR will store a pointer to the character
just after the terminating character (the close-brace, the last
character of the variable name, or the close-quote (respectively))
if the parse was successful.
.AP Tcl_Parse *usedParsePtr in
Points to structure that was filled in by a previous call to
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseVarName\fR, etc.
.BE
.SH DESCRIPTION
.PP
These procedures parse Tcl commands or portions of Tcl commands such as
expressions or references to variables.
Each procedure takes a pointer to a script (or portion thereof)
and fills in the structure pointed to by \fIparsePtr\fR
with a collection of tokens describing the information that was parsed.
The procedures normally return \fBTCL_OK\fR.
However, if an error occurs then they return \fBTCL_ERROR\fR,
leave an error message in \fIinterp's\fR result
(if \fIinterp\fR is not NULL),
and leave nothing in \fIparsePtr\fR.
.PP
\fBTcl_ParseCommand\fR is a procedure that parses Tcl
scripts. Given a pointer to a script, it
parses the first command from the script. If the command was parsed
successfully, \fBTcl_ParseCommand\fR returns \fBTCL_OK\fR and fills in the
structure pointed to by \fIparsePtr\fR with information about the
structure of the command (see below for details).
If an error occurred in parsing the command then
\fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's
result, and no information is left at \fI*parsePtr\fR.
.PP
\fBTcl_ParseExpr\fR parses Tcl expressions.
Given a pointer to a script containing an expression,
\fBTcl_ParseExpr\fR parses the expression.
If the expression was parsed successfully,
\fBTcl_ParseExpr\fR returns \fBTCL_OK\fR and fills in the
structure pointed to by \fIparsePtr\fR with information about the
structure of the expression (see below for details).
If an error occurred in parsing the command then
\fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's
result, and no information is left at \fI*parsePtr\fR.
.PP
\fBTcl_ParseBraces\fR parses a string or command argument
enclosed in braces such as
\fB{hello}\fR or \fB{string \\t with \\t tabs}\fR
from the beginning of its argument \fIstring\fR.
The first character of \fIstring\fR must be \fB{\fR.
If the braced string was parsed successfully,
\fBTcl_ParseBraces\fR returns \fBTCL_OK\fR,
fills in the structure pointed to by \fIparsePtr\fR
with information about the structure of the string
(see below for details),
and stores a pointer to the character just after the terminating \fB}\fR
in the location given by \fI*termPtr\fR.
If an error occurs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
.PP
\fBTcl_ParseQuotedString\fR parses a double-quoted string such as
\fB"sum is [expr $a+$b]"\fR
from the beginning of the argument \fIstring\fR.
The first character of \fIstring\fR must be \fB"\fR.
If the double-quoted string was parsed successfully,
\fBTcl_ParseQuotedString\fR returns \fBTCL_OK\fR,
fills in the structure pointed to by \fIparsePtr\fR
with information about the structure of the string
(see below for details),
and stores a pointer to the character just after the terminating \fB"\fR
in the location given by \fI*termPtr\fR.
If an error occurs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
.PP
\fBTcl_ParseVarName\fR parses a Tcl variable reference such as
\fB$abc\fR or \fB$x([expr $index + 1])\fR from the beginning of its
\fIstring\fR argument.
The first character of \fIstring\fR must be \fB$\fR.
If a variable name was parsed successfully, \fBTcl_ParseVarName\fR
returns \fBTCL_OK\fR and fills in the structure pointed to by
\fIparsePtr\fR with information about the structure of the variable name
(see below for details). If an error
occurs while parsing the command then \fBTCL_ERROR\fR is returned, an
error message is left in \fIinterp\fR's result (if \fIinterp\fR isn't
NULL), and no information is left at \fI*parsePtr\fR.
.PP
\fBTcl_ParseVar\fR parse a Tcl variable reference such as \fB$abc\fR
or \fB$x([expr $index + 1])\fR from the beginning of its \fIstring\fR
argument. The first character of \fIstring\fR must be \fB$\fR. If
the variable name is parsed successfully, \fBTcl_ParseVar\fR returns a
pointer to the string value of the variable. If an error occurs while
parsing, then NULL is returned and an error message is left in
\fIinterp\fR's result.
.PP
The information left at \fI*parsePtr\fR
by \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR
may include dynamically allocated memory.
If these five parsing procedures return \fBTCL_OK\fR
then the caller must invoke \fBTcl_FreeParse\fR to release
the storage at \fI*parsePtr\fR.
These procedures ignore any existing information in
\fI*parsePtr\fR (unless \fIappend\fR is non-zero),
so if repeated calls are being made to any of them
then \fBTcl_FreeParse\fR must be invoked once after each call.
.PP
\fBTcl_EvalTokensStandard\fR evaluates a sequence of parse tokens from
a Tcl_Parse structure. The tokens typically consist
of all the tokens in a word or all the tokens that make up the index for
a reference to an array variable. \fBTcl_EvalTokensStandard\fR performs the
substitutions requested by the tokens and concatenates the
resulting values.
The return value from \fBTcl_EvalTokensStandard\fR is a Tcl completion
code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR,
\fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly
some other integer value originating in an extension.
In addition, a result value or error message is left in \fIinterp\fR's
result; it can be retrieved using \fBTcl_GetObjResult\fR.
.PP
\fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in
the return convention used: it returns the result in a new Tcl_Obj.
The reference count of the object returned as result has been
incremented, so the caller must
invoke \fBTcl_DecrRefCount\fR when it is finished with the object.
If an error or other exception occurs while evaluating the tokens
(such as a reference to a non-existent variable) then the return value
is NULL and an error message is left in \fIinterp\fR's result. The use
of \fBTcl_EvalTokens\fR is deprecated.
.SH "TCL_PARSE STRUCTURE"
.PP
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR
return parse information in two data structures, Tcl_Parse and Tcl_Token:
.CS
typedef struct Tcl_Parse {
CONST char *\fIcommentStart\fR;
int \fIcommentSize\fR;
CONST char *\fIcommandStart\fR;
int \fIcommandSize\fR;
int \fInumWords\fR;
Tcl_Token *\fItokenPtr\fR;
int \fInumTokens\fR;
...
} Tcl_Parse;
typedef struct Tcl_Token {
int \fItype\fR;
CONST char *\fIstart\fR;
int \fIsize\fR;
int \fInumComponents\fR;
} Tcl_Token;
.CE
.PP
The first five fields of a Tcl_Parse structure
are filled in only by \fBTcl_ParseCommand\fR.
These fields are not used by the other parsing procedures.
.PP
\fBTcl_ParseCommand\fR fills in a Tcl_Parse structure
with information that describes one Tcl command and any comments that
precede the command.
If there are comments,
the \fIcommentStart\fR field points to the \fB#\fR character that begins
the first comment and \fIcommentSize\fR indicates the number of bytes
in all of the comments preceding the command, including the newline
character that terminates the last comment.
If the command is not preceded by any comments, \fIcommentSize\fR is 0.
\fBTcl_ParseCommand\fR also sets the \fIcommandStart\fR field
to point to the first character of the first
word in the command (skipping any comments and leading space) and
\fIcommandSize\fR gives the total number of bytes in the command,
including the character pointed to by \fIcommandStart\fR up to and
including the newline, close bracket, or semicolon character that
terminates the command. The \fInumWords\fR field gives the
total number of words in the command.
.PP
All parsing procedures set the remaining fields,
\fItokenPtr\fR and \fInumTokens\fR.
The \fItokenPtr\fR field points to the first in an array of Tcl_Token
structures that describe the components of the entity being parsed.
The \fInumTokens\fR field gives the total number of tokens
present in the array.
Each token contains four fields.
The \fItype\fR field selects one of several token types
that are described below. The \fIstart\fR field
points to the first character in the token and the \fIsize\fR field
gives the total number of characters in the token. Some token types,
such as \fBTCL_TOKEN_WORD\fR and \fBTCL_TOKEN_VARIABLE\fR, consist of
several component tokens, which immediately follow the parent token;
the \fInumComponents\fR field describes how many of these there are.
The \fItype\fR field has one of the following values:
.TP 20
\fBTCL_TOKEN_WORD\fR
This token ordinarily describes one word of a command
but it may also describe a quoted or braced string in an expression.
The token describes a component of the script that is
the result of concatenating together a sequence of subcomponents,
each described by a separate subtoken.
The token starts with the first non-blank
character of the component (which may be a double-quote or open brace)
and includes all characters in the component up to but not including the
space, semicolon, close bracket, close quote, or close brace that
terminates the component. The \fInumComponents\fR field counts the total
number of sub-tokens that make up the word, including sub-tokens
of \fBTCL_TOKEN_VARIABLE\fR and \fBTCL_TOKEN_BS\fR tokens.
.TP
\fBTCL_TOKEN_SIMPLE_WORD\fR
This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that
the word is guaranteed to consist of a single \fBTCL_TOKEN_TEXT\fR
sub-token. The \fInumComponents\fR field is always 1.
.TP
\fBTCL_TOKEN_TEXT\fR
The token describes a range of literal text that is part of a word.
The \fInumComponents\fR field is always 0.
.TP
\fBTCL_TOKEN_BS\fR
The token describes a backslash sequence such as \fB\en\fR or \fB\e0xa3\fR.
The \fInumComponents\fR field is always 0.
.TP
\fBTCL_TOKEN_COMMAND\fR
The token describes a command whose result result must be substituted into
the word. The token includes the square brackets that surround the
command. The \fInumComponents\fR field is always 0 (the nested command
is not parsed; call \fBTcl_ParseCommand\fR recursively if you want to
see its tokens).
.TP
\fBTCL_TOKEN_VARIABLE\fR
The token describes a variable substitution, including the
\fB$\fR, variable name, and array index (if there is one) up through the
close parenthesis that terminates the index. This token is followed
by one or more additional tokens that describe the variable name and
array index. If \fInumComponents\fR is 1 then the variable is a
scalar and the next token is a \fBTCL_TOKEN_TEXT\fR token that gives the
variable name. If \fInumComponents\fR is greater than 1 then the
variable is an array: the first sub-token is a \fBTCL_TOKEN_TEXT\fR
token giving the array name and the remaining sub-tokens are
\fBTCL_TOKEN_TEXT\fR, \fBTCL_TOKEN_BS\fR, \fBTCL_TOKEN_COMMAND\fR, and
\fBTCL_TOKEN_VARIABLE\fR tokens that must be concatenated to produce the
array index. The \fInumComponents\fR field includes nested sub-tokens
that are part of \fBTCL_TOKEN_VARIABLE\fR tokens in the array index.
.TP
\fBTCL_TOKEN_SUB_EXPR\fR
The token describes one subexpression of an expression
(or an entire expression).
A subexpression may consist of a value
such as an integer literal, variable substitution,
or parenthesized subexpression;
it may also consist of an operator and its operands.
The token starts with the first non-blank character of the subexpression
up to but not including the space, brace, close-paren, or bracket
that terminates the subexpression.
This token is followed by one or more additional tokens
that describe the subexpression.
If the first sub-token after the \fBTCL_TOKEN_SUB_EXPR\fR token
is a \fBTCL_TOKEN_OPERATOR\fR token,
the subexpression consists of an operator and its token operands.
If the operator has no operands, the subexpression consists of
just the \fBTCL_TOKEN_OPERATOR\fR token.
Each operand is described by a \fBTCL_TOKEN_SUB_EXPR\fR token.
Otherwise, the subexpression is a value described by
one of the token types \fBTCL_TOKEN_WORD\fR, \fBTCL_TOKEN_TEXT\fR,
\fBTCL_TOKEN_BS\fR, \fBTCL_TOKEN_COMMAND\fR,
\fBTCL_TOKEN_VARIABLE\fR, and \fBTCL_TOKEN_SUB_EXPR\fR.
The \fInumComponents\fR field
counts the total number of sub-tokens that make up the subexpression;
this includes the sub-tokens for any nested \fBTCL_TOKEN_SUB_EXPR\fR tokens.
.TP
\fBTCL_TOKEN_OPERATOR\fR
The token describes one operator of an expression
such as \fB&&\fR or \fBhypot\fR.
An \fBTCL_TOKEN_OPERATOR\fR token is always preceded by a
\fBTCL_TOKEN_SUB_EXPR\fR token
that describes the operator and its operands;
the \fBTCL_TOKEN_SUB_EXPR\fR token's \fInumComponents\fR field
can be used to determine the number of operands.
A binary operator such as \fB*\fR
is followed by two \fBTCL_TOKEN_SUB_EXPR\fR tokens
that describe its operands.
A unary operator like \fB-\fR
is followed by a single \fBTCL_TOKEN_SUB_EXPR\fR token
for its operand.
If the operator is a math function such as \fBlog10\fR,
the \fBTCL_TOKEN_OPERATOR\fR token will give its name and
the following \fBTCL_TOKEN_SUB_EXPR\fR tokens will describe
its operands;
if there are no operands (as with \fBrand\fR),
no \fBTCL_TOKEN_SUB_EXPR\fR tokens follow.
There is one trinary operator, \fB?\fR,
that appears in if-then-else subexpressions
such as \fIx\fB?\fIy\fB:\fIz\fR;
in this case, the \fB?\fR \fBTCL_TOKEN_OPERATOR\fR token
is followed by three \fBTCL_TOKEN_SUB_EXPR\fR tokens for the operands
\fIx\fR, \fIy\fR, and \fIz\fR.
The \fInumComponents\fR field for a \fBTCL_TOKEN_OPERATOR\fR token
is always 0.
.PP
After \fBTcl_ParseCommand\fR returns, the first token pointed to by
the \fItokenPtr\fR field of the
Tcl_Parse structure always has type \fBTCL_TOKEN_WORD\fR or
\fBTCL_TOKEN_SIMPLE_WORD\fR. It is followed by the sub-tokens
that must be concatenated to produce the value of that word.
The next token is the \fBTCL_TOKEN_WORD\fR or \fBTCL_TOKEN_SIMPLE_WORD\fR
token for the second word, followed by sub-tokens for that
word, and so on until all \fInumWords\fR have been accounted
for.
.PP
After \fBTcl_ParseExpr\fR returns, the first token pointed to by
the \fItokenPtr\fR field of the
Tcl_Parse structure always has type \fBTCL_TOKEN_SUB_EXPR\fR.
It is followed by the sub-tokens that must be evaluated
to produce the value of the expression.
Only the token information in the Tcl_Parse structure
is modified: the \fIcommentStart\fR, \fIcommentSize\fR,
\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified
by \fBTcl_ParseExpr\fR.
.PP
After \fBTcl_ParseBraces\fR returns,
the array of tokens pointed to by the \fItokenPtr\fR field of the
Tcl_Parse structure will contain a single \fBTCL_TOKEN_TEXT\fR token
if the braced string does not contain any backslash-newlines.
If the string does contain backslash-newlines,
the array of tokens will contain one or more
\fBTCL_TOKEN_TEXT\fR or \fBTCL_TOKEN_BS\fR sub-tokens
that must be concatenated to produce the value of the string.
If the braced string was just \fB{}\fR
(that is, the string was empty),
the single \fBTCL_TOKEN_TEXT\fR token will have a \fIsize\fR field
containing zero;
this ensures that at least one token appears
to describe the braced string.
Only the token information in the Tcl_Parse structure
is modified: the \fIcommentStart\fR, \fIcommentSize\fR,
\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified
by \fBTcl_ParseBraces\fR.
.PP
After \fBTcl_ParseQuotedString\fR returns,
the array of tokens pointed to by the \fItokenPtr\fR field of the
Tcl_Parse structure depends on the contents of the quoted string.
It will consist of one or more \fBTCL_TOKEN_TEXT\fR, \fBTCL_TOKEN_BS\fR,
\fBTCL_TOKEN_COMMAND\fR, and \fBTCL_TOKEN_VARIABLE\fR sub-tokens.
The array always contains at least one token;
for example, if the argument \fIstring\fR is empty,
the array returned consists of a single \fBTCL_TOKEN_TEXT\fR token
with a zero \fIsize\fR field.
Only the token information in the Tcl_Parse structure
is modified: the \fIcommentStart\fR, \fIcommentSize\fR,
\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified.
.PP
After \fBTcl_ParseVarName\fR returns, the first token pointed to by
the \fItokenPtr\fR field of the
Tcl_Parse structure always has type \fBTCL_TOKEN_VARIABLE\fR. It
is followed by the sub-tokens that make up the variable name as
described above. The total length of the variable name is
contained in the \fIsize\fR field of the first token.
As in \fBTcl_ParseExpr\fR,
only the token information in the Tcl_Parse structure
is modified by \fBTcl_ParseVarName\fR:
the \fIcommentStart\fR, \fIcommentSize\fR,
\fIcommandStart\fR, and \fIcommandSize\fR fields are not modified.
.PP
All of the character pointers in the
Tcl_Parse and Tcl_Token structures refer
to characters in the \fIstring\fR argument passed to
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR.
.PP
There are additional fields in the Tcl_Parse structure after the
\fInumTokens\fR field, but these are for the private use of
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR; they should not be
referenced by code outside of these procedures.
.SH KEYWORDS
backslash substitution, braces, command, expression, parse, token, variable substitution
tcl8.4.20/doc/ExprLong.3 0000644 0036047 0045461 00000007205 11737050674 013312 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-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.
'\"
.so man.macros
.TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString \- evaluate an expression
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_ExprLong\fR(\fIinterp, string, longPtr\fR)
.sp
int
\fBTcl_ExprDouble\fR(\fIinterp, string, doublePtr\fR)
.sp
int
\fBTcl_ExprBoolean\fR(\fIinterp, string, booleanPtr\fR)
.sp
int
\fBTcl_ExprString\fR(\fIinterp, string\fR)
.SH ARGUMENTS
.AS Tcl_Interp *booleanPtr
.AP Tcl_Interp *interp in
Interpreter in whose context to evaluate \fIstring\fR.
.VS 8.4
.AP "CONST char" *string in
.VE
Expression to be evaluated.
.AP long *longPtr out
Pointer to location in which to store the integer value of the
expression.
.AP int *doublePtr out
Pointer to location in which to store the floating-point value of the
expression.
.AP int *booleanPtr out
Pointer to location in which to store the 0/1 boolean value of the
expression.
.BE
.SH DESCRIPTION
.PP
These four procedures all evaluate the expression
given by the \fIstring\fR argument
and return the result in one of four different forms.
The expression can have any of the forms accepted by the \fBexpr\fR command.
Note that these procedures have been largely replaced by the
object-based procedures \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR,
\fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR.
Those object-based procedures evaluate an expression held in a Tcl object
instead of a string.
The object argument can retain an internal representation
that is more efficient to execute.
.PP
The \fIinterp\fR argument refers to an interpreter used to
evaluate the expression (e.g. for variables and nested Tcl
commands) and to return error information.
.PP
For all of these procedures the return value is a standard
Tcl result: \fBTCL_OK\fR means the expression was successfully
evaluated, and \fBTCL_ERROR\fR means that an error occurred while
evaluating the expression.
If \fBTCL_ERROR\fR is returned then
the interpreter's result will hold a message describing the error.
If an error occurs while executing a Tcl command embedded in
the expression then that error will be returned.
.PP
If the expression is successfully evaluated, then its value is
returned in one of four forms, depending on which procedure
is invoked.
\fBTcl_ExprLong\fR stores an integer value at \fI*longPtr\fR.
If the expression's actual value is a floating-point number,
then it is truncated to an integer.
If the expression's actual value is a non-numeric string then
an error is returned.
.PP
\fBTcl_ExprDouble\fR stores a floating-point value at \fI*doublePtr\fR.
If the expression's actual value is an integer, it is converted to
floating-point.
If the expression's actual value is a non-numeric string then
an error is returned.
.PP
\fBTcl_ExprBoolean\fR stores a 0/1 integer value at \fI*booleanPtr\fR.
If the expression's actual value is an integer or floating-point
number, then they store 0 at \fI*booleanPtr\fR if
the value was zero and 1 otherwise.
If the expression's actual value is a non-numeric string then
it must be one of the values accepted by \fBTcl_GetBoolean\fR
such as ``yes'' or ``no'', or else an error occurs.
.PP
\fBTcl_ExprString\fR returns the value of the expression as a
string stored in the interpreter's result.
.SH "SEE ALSO"
Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj
.SH KEYWORDS
boolean, double, evaluate, expression, integer, object, string
tcl8.4.20/doc/read.n 0000644 0036047 0045461 00000006702 11737050674 012563 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH read n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
read \- Read from a channel
.SH SYNOPSIS
\fBread \fR?\fB\-nonewline\fR? \fIchannelId\fR
.sp
\fBread \fIchannelId numChars\fR
.BE
.SH DESCRIPTION
.PP
In the first form, the \fBread\fR command reads all of the data from
\fIchannelId\fR up to the end of the file. If the \fB\-nonewline\fR
switch is specified then the last character of the file is discarded
if it is a newline. In the second form, the extra argument specifies
how many characters to read. Exactly that many characters will be
read and returned, unless there are fewer than \fInumChars\fR left in
the file; in this case all the remaining characters are returned. If
the channel is configured to use a multi-byte encoding, then the
number of characters read may not be the same as the number of bytes
read.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as the
Tcl standard input channel (\fBstdin\fR), the return value from an
invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel
creation command provided by a Tcl extension. The channel must have
been opened for input.
.VE
.PP
If \fIchannelId\fR is in nonblocking mode, the command may not read as
many characters as requested: once all available input has been read,
the command will return the data that is available rather than
blocking for more input. If the channel is configured to use a
multi-byte encoding, then there may actually be some bytes remaining
in the internal buffers that do not form a complete character. These
bytes will not be returned until a complete character is available or
end-of-file is reached. The \fB\-nonewline\fR switch is ignored if
the command returns before reaching the end of the file.
.PP
\fBRead\fR translates end-of-line sequences in the input into
newline characters according to the \fB\-translation\fR option
for the channel.
See the \fBfconfigure\fR manual entry for a discussion on ways in
which \fBfconfigure\fR will alter input.
.SH "USE WITH SERIAL PORTS"
'\" Note: this advice actually applies to many versions of Tcl
For most applications a channel connected to a serial port should be
configured to be nonblocking: \fBfconfigure \fIchannelId \fB\-blocking
\fI0\fR. Then \fBread\fR behaves much like described above. Care
must be taken when using \fBread\fR on blocking serial ports:
.TP
\fBread \fIchannelId numChars\fR
In this form \fBread\fR blocks until \fInumChars\fR have been received
from the serial port.
.TP
\fBread \fIchannelId\fR
In this form \fBread\fR blocks until the reception of the end-of-file
character, see \fBfconfigure -eofchar\fR. If there no end-of-file
character has been configured for the channel, then \fBread\fR will
block forever.
.SH "EXAMPLE"
This example code reads a file all at once, and splits it into a list,
with each line in the file corresponding to an element in the list:
.CS
set fl [open /proc/meminfo]
set data [\fBread\fR $fl]
close $fl
set lines [split $data \\n]
.CE
.SH "SEE ALSO"
file(n), eof(n), fblocked(n), fconfigure(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, channel, end of line, end of file, nonblocking, read, translation, encoding
tcl8.4.20/doc/GetOpnFl.3 0000644 0036047 0045461 00000004036 11737050674 013231 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_GetOpenFile 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetOpenFile \- Get a standard IO File * handle from a channel. (Unix only)
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_GetOpenFile\fR(\fIinterp, string, write, checkUsage, filePtr\fR)
.sp
.SH ARGUMENTS
.AS Tcl_Interp checkUsage
.AP Tcl_Interp *interp in
Tcl interpreter from which file handle is to be obtained.
.AP "CONST char" *string in
String identifying channel, such as \fBstdin\fR or \fBfile4\fR.
.AP int write in
Non-zero means the file will be used for writing, zero means it will
be used for reading.
.AP int checkUsage in
If non-zero, then an error will be generated if the file wasn't opened
for the access indicated by \fIwrite\fR.
.AP ClientData *filePtr out
Points to word in which to store pointer to FILE structure for
the file given by \fIstring\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_GetOpenFile\fR takes as argument a file identifier of the form
returned by the \fBopen\fR command and
returns at \fI*filePtr\fR a pointer to the FILE structure for
the file.
The \fIwrite\fR argument indicates whether the FILE pointer will
be used for reading or writing.
In some cases, such as a channel that connects to a pipeline of
subprocesses, different FILE pointers will be returned for reading
and writing.
\fBTcl_GetOpenFile\fR normally returns TCL_OK.
If an error occurs in \fBTcl_GetOpenFile\fR (e.g. \fIstring\fR didn't
make any sense or \fIcheckUsage\fR was set and the file wasn't opened
for the access specified by \fIwrite\fR) then TCL_ERROR is returned
and the interpreter's result will contain an error message.
In the current implementation \fIcheckUsage\fR is ignored and consistency
checks are always performed.
.VS
.PP
Note that this interface is only supported on the Unix platform.
.VE
.SH KEYWORDS
channel, file handle, permissions, pipeline, read, write
tcl8.4.20/doc/regsub.n 0000644 0036047 0045461 00000013020 11737050674 013126 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH regsub n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
regsub \- Perform substitutions based on regular expression pattern matching
.SH SYNOPSIS
.VS 8.4
\fBregsub \fR?\fIswitches\fR? \fIexp string subSpec \fR?\fIvarName\fR?
.VE 8.4
.BE
.SH DESCRIPTION
.PP
This command matches the regular expression \fIexp\fR against
\fIstring\fR,
.VS 8.4
and either copies \fIstring\fR to the variable whose name is
given by \fIvarName\fR or returns \fIstring\fR if \fIvarName\fR is not
present.
.VE 8.4
(Regular expression matching is described in the \fBre_syntax\fR
reference page.)
If there is a match, then while copying \fIstring\fR to \fIvarName\fR
.VS 8.4
(or to the result of this command if \fIvarName\fR is not present)
.VE 8.4
the portion of \fIstring\fR that
matched \fIexp\fR is replaced with \fIsubSpec\fR.
If \fIsubSpec\fR contains a ``&'' or ``\e0'', then it is replaced
in the substitution with the portion of \fIstring\fR that
matched \fIexp\fR.
If \fIsubSpec\fR contains a ``\e\fIn\fR'', where \fIn\fR is a digit
between 1 and 9, then it is replaced in the substitution with
the portion of \fIstring\fR that matched the \fIn\fR-th
parenthesized subexpression of \fIexp\fR.
Additional backslashes may be used in \fIsubSpec\fR to prevent special
interpretation of ``&'' or ``\e0'' or ``\e\fIn\fR'' or
backslash.
The use of backslashes in \fIsubSpec\fR tends to interact badly
with the Tcl parser's use of backslashes, so it's generally
safest to enclose \fIsubSpec\fR in braces if it includes
backslashes.
.LP
If the initial arguments to \fBregsub\fR start with \fB\-\fR then
they are treated as switches. The following switches are
currently supported:
.TP 10
\fB\-all\fR
All ranges in \fIstring\fR that match \fIexp\fR are found and
substitution is performed for each of these ranges.
Without this switch only the first
matching range is found and substituted.
If \fB\-all\fR is specified, then ``&'' and ``\e\fIn\fR''
sequences are handled for each substitution using the information
from the corresponding match.
.TP 15
\fB\-expanded\fR
Enables use of the expanded regular expression syntax where
whitespace and comments are ignored. This is the same as specifying
the \fB(?x)\fR embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-line\fR
Enables newline-sensitive matching. By default, newline is a
completely ordinary character with no special meaning. With this
flag, `[^' bracket expressions and `.' never match newline, `^'
matches an empty string after any newline in addition to its normal
function, and `$' matches an empty string before any newline in
addition to its normal function. This flag is equivalent to
specifying both \fB\-linestop\fR and \fB\-lineanchor\fR, or the
\fB(?n)\fR embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-linestop\fR
Changes the behavior of `[^' bracket expressions and `.' so that they
stop at newlines. This is the same as specifying the \fB(?p)\fR
embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-lineanchor\fR
Changes the behavior of `^' and `$' (the ``anchors'') so they match the
beginning and end of a line respectively. This is the same as
specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR
manual page).
.TP 10
\fB\-nocase\fR
Upper-case characters in \fIstring\fR will be converted to lower-case
before matching against \fIexp\fR; however, substitutions specified
by \fIsubSpec\fR use the original unconverted form of \fIstring\fR.
.TP 10
\fB\-start\fR \fIindex\fR
Specifies a character index offset into the string to start
matching the regular expression at. When using this switch, `^'
will not match the beginning of the line, and \\A will still
match the start of the string at \fIindex\fR.
\fIindex\fR will be constrained to the bounds of the input string.
.TP 10
\fB\-\|\-\fR
Marks the end of switches. The argument following this one will
be treated as \fIexp\fR even if it starts with a \fB\-\fR.
.PP
.VS 8.4
If \fIvarName\fR is supplied, the command returns a count of the
number of matching ranges that were found and replaced, otherwise the
string after replacement is returned.
.VE 8.4
See the manual entry for \fBregexp\fR for details on the interpretation
of regular expressions.
.SH EXAMPLES
Replace (in the string in variable \fIstring\fR) every instance of
\fBfoo\fR which is a word by itself with \fBbar\fR:
.CS
\fBregsub\fR -all {\e} $string bar string
.CE
.PP
Insert double-quotes around the first instance of the word
\fBinteresting\fR, however it is capitalised.
.CS
\fBregsub\fR -nocase {\e} $string {"&"} string
.CE
.PP
Convert all non-ASCII and Tcl-significant characters into \eu escape
sequences by using \fBregsub\fR and \fBsubst\fR in combination:
.CS
# This RE is just a character class for everything "bad"
set RE {[][{}\e$\es\eu0100-\euffff]}
# We will substitute with a fragment of Tcl script in brackets
set substitution {[format \e\e\e\eu%04x [scan "\e\e&" %c]]}
# Now we apply the substitution to get a subst-string that
# will perform the computational parts of the conversion.
set quoted [subst [\fBregsub\fR -all $RE $string $substitution]]
.CE
.SH "SEE ALSO"
regexp(n), re_syntax(n), subst(n)
.SH KEYWORDS
match, pattern, regular expression, substitute
tcl8.4.20/doc/Eval.3 0000644 0036047 0045461 00000020664 11737050674 012447 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
.VS
int
\fBTcl_EvalObjEx\fR(\fIinterp, objPtr, flags\fR)
.sp
int
\fBTcl_EvalFile\fR(\fIinterp, fileName\fR)
.sp
int
\fBTcl_EvalObjv\fR(\fIinterp, objc, objv, flags\fR)
.sp
int
\fBTcl_Eval\fR(\fIinterp, script\fR)
.sp
int
\fBTcl_EvalEx\fR(\fIinterp, script, numBytes, flags\fR)
.sp
int
\fBTcl_GlobalEval\fR(\fIinterp, script\fR)
.sp
int
\fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR)
.sp
int
\fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR)
.sp
int
\fBTcl_VarEvalVA\fR(\fIinterp, argList\fR)
.SH ARGUMENTS
.AS Tcl_Interp **termPtr;
.AP Tcl_Interp *interp in
Interpreter in which to execute the script. The interpreter's result is
modified to hold the result or error message from the script.
.AP Tcl_Obj *objPtr in
A Tcl object containing the script to execute.
.AP int flags in
ORed combination of flag bits that specify additional options.
\fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported.
.AP "CONST char" *fileName in
Name of a file containing a Tcl script.
.AP int objc in
The number of objects in the array pointed to by \fIobjPtr\fR;
this is also the number of words in the command.
.AP Tcl_Obj **objv in
Points to an array of pointers to objects; each object holds the
value of a single word in the command to execute.
.AP int numBytes in
The number of bytes in \fIscript\fR, not including any
null terminating character. If \-1, then all characters up to the
first null byte are used.
.AP "CONST char" *script in
Points to first byte of script to execute (null-terminated and UTF-8).
.AP char *string in
String forming part of a Tcl script.
.AP va_list argList in
An argument list which must have been initialised using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.BE
.SH DESCRIPTION
.PP
The procedures described here are invoked to execute Tcl scripts in
various forms.
\fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others.
It executes the commands in the script stored in \fIobjPtr\fR
until either an error occurs or the end of the script is reached.
If this is the first time \fIobjPtr\fR has been executed,
its commands are compiled into bytecode instructions
which are then executed. The
bytecodes are saved in \fIobjPtr\fR so that the compilation step
can be skipped if the object is evaluated again in the future.
.PP
The return value from \fBTcl_EvalObjEx\fR (and all the other procedures
described here) is a Tcl completion code with
one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR,
\fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other
integer value originating in an extension.
In addition, a result value or error message is left in \fIinterp\fR's
result; it can be retrieved using \fBTcl_GetObjResult\fR.
.PP
\fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates
its contents as a Tcl script. It returns the same information as
\fBTcl_EvalObjEx\fR.
If the file couldn't be read then a Tcl error is returned to describe
why the file couldn't be read.
.VS 8.4
The eofchar for files is '\\32' (^Z) for all platforms.
If you require a ``^Z'' in code for string comparison, you can use
``\\032'' or ``\\u001a'', which will be safely substituted by the Tcl
interpreter into ``^Z''.
.VE 8.4
.PP
\fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a
script. The \fIobjc\fR and \fIobjv\fR arguments contain the values
of the words for the Tcl command, one word in each object in
\fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns
a completion code and result just like \fBTcl_EvalObjEx\fR.
.PP
\fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that the script to
be executed is supplied as a string instead of an object and no compilation
occurs. The string should be a proper UTF-8 string as converted by
\fBTcl_ExternalToUtfDString\fR or \fBTcl_ExternalToUtf\fR when it is known
to possibly contain upper ASCII characters who's possible combinations
might be a UTF-8 special code. The string is parsed and executed directly
(using \fBTcl_EvalObjv\fR) instead of compiling it and executing the
bytecodes. In situations where it is known that the script will never be
executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR.
\fBTcl_Eval\fR returns a completion code and result just like
\fBTcl_EvalObjEx\fR. Note: for backward compatibility with versions before
Tcl 8.0, \fBTcl_Eval\fR copies the object result in \fIinterp\fR to
\fIinterp->result\fR (use is deprecated) where it can be accessed directly.
This makes \fBTcl_Eval\fR somewhat slower than \fBTcl_EvalEx\fR, which
doesn't do the copy.
.PP
\fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes
additional arguments \fInumBytes\fR and \fIflags\fR. For the
efficiency reason given above, \fBTcl_EvalEx\fR is generally preferred
over \fBTcl_Eval\fR.
.PP
\fBTcl_GlobalEval\fR and \fBTcl_GlobalEvalObj\fR are older procedures
that are now deprecated. They are similar to \fBTcl_EvalEx\fR and
\fBTcl_EvalObjEx\fR except that the script is evaluated in the global
namespace and its variable context consists of global variables only
(it ignores any Tcl procedures that are active). These functions are
equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below).
.PP
\fBTcl_VarEval\fR takes any number of string arguments
of any length, concatenates them into a single string,
then calls \fBTcl_Eval\fR to execute that string as a Tcl command.
It returns the result of the command and also modifies
\fIinterp->result\fR in the same way as \fBTcl_Eval\fR.
The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end
of arguments. \fBTcl_VarEval\fR is now deprecated.
.PP
\fBTcl_VarEvalVA\fR is the same as \fBTcl_VarEval\fR except that
instead of taking a variable number of arguments it takes an argument
list. Like \fBTcl_VarEval\fR, \fBTcl_VarEvalVA\fR is deprecated.
.SH "FLAG BITS"
Any ORed combination of the following values may be used for the
\fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR:
.TP 23
\fBTCL_EVAL_DIRECT\fR
This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by
other procedures. If this flag bit is set, the script is not
compiled to bytecodes; instead it is executed directly
as is done by \fBTcl_EvalEx\fR. The
\fBTCL_EVAL_DIRECT\fR flag is useful in situations where the
contents of an object are going to change immediately, so the
bytecodes won't be reused in a future execution. In this case,
it's faster to execute the script directly.
.TP 23
\fBTCL_EVAL_GLOBAL\fR
If this flag is set, the script is processed at global level. This
means that it is evaluated in the global namespace and its variable
context consists of global variables only (it ignores any Tcl
procedures at are active).
.SH "MISCELLANEOUS DETAILS"
.PP
During the processing of a Tcl command it is legal to make nested
calls to evaluate other commands (this is how procedures and
some control structures are implemented).
If a code other than \fBTCL_OK\fR is returned
from a nested \fBTcl_EvalObjEx\fR invocation,
then the caller should normally return immediately,
passing that same return code back to its caller,
and so on until the top-level application is reached.
A few commands, like \fBfor\fR, will check for certain
return codes, like \fBTCL_BREAK\fR and \fBTCL_CONTINUE\fR, and process them
specially without returning.
.PP
\fBTcl_EvalObjEx\fR keeps track of how many nested \fBTcl_EvalObjEx\fR
invocations are in progress for \fIinterp\fR.
If a code of \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR is
about to be returned from the topmost \fBTcl_EvalObjEx\fR
invocation for \fIinterp\fR,
it converts the return code to \fBTCL_ERROR\fR
and sets \fIinterp\fR's result to an error message indicating that
the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was
invoked in an inappropriate place.
This means that top-level applications should never see a return code
from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR.
.VE
.SH KEYWORDS
execute, file, global, object, result, script
tcl8.4.20/doc/GetInt.3 0000644 0036047 0045461 00000006052 11737050674 012745 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_GetInt 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
int
\fBTcl_GetInt\fR(\fIinterp, string, intPtr\fR)
.sp
int
\fBTcl_GetDouble\fR(\fIinterp, string, doublePtr\fR)
.sp
int
\fBTcl_GetBoolean\fR(\fIinterp, string, boolPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp *doublePtr
.AP Tcl_Interp *interp in
Interpreter to use for error reporting.
.AP "CONST char" *string in
Textual value to be converted.
.AP int *intPtr out
Points to place to store integer value converted from \fIstring\fR.
.AP double *doublePtr out
Points to place to store double-precision floating-point
value converted from \fIstring\fR.
.AP int *boolPtr out
Points to place to store boolean value (0 or 1) converted from \fIstring\fR.
.BE
.SH DESCRIPTION
.PP
These procedures convert from strings to integers or double-precision
floating-point values or booleans (represented as 0- or 1-valued
integers). Each of the procedures takes a \fIstring\fR argument,
converts it to an internal form of a particular type, and stores
the converted value at the location indicated by the procedure's
third argument. If all goes well, each of the procedures returns
TCL_OK. If \fIstring\fR doesn't have the proper syntax for the
desired type then TCL_ERROR is returned, an error message is left
in the interpreter's result, and nothing is stored at *\fIintPtr\fR
or *\fIdoublePtr\fR or *\fIboolPtr\fR.
.PP
\fBTcl_GetInt\fR expects \fIstring\fR to consist of a collection
of integer digits, optionally signed and optionally preceded by
white space. If the first two characters of \fIstring\fR are ``0x''
then \fIstring\fR is expected to be in hexadecimal form; otherwise,
if the first character of \fIstring\fR is ``0'' then \fIstring\fR
is expected to be in octal form; otherwise, \fIstring\fR is
expected to be in decimal form.
.PP
\fBTcl_GetDouble\fR expects \fIstring\fR to consist of a floating-point
number, which is: white space; a sign; a sequence of digits; a
decimal point; a sequence of digits; the letter ``e''; and a
signed decimal exponent. Any of the fields may be omitted, except that
the digits either before or after the decimal point must be present
and if the ``e'' is present then it must be followed by the
exponent number.
.PP
\fBTcl_GetBoolean\fR expects \fIstring\fR to specify a boolean
value. If \fIstring\fR is any of \fB0\fR, \fBfalse\fR,
\fBno\fR, or \fBoff\fR, then \fBTcl_GetBoolean\fR stores a zero
value at \fI*boolPtr\fR.
If \fIstring\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR,
then 1 is stored at \fI*boolPtr\fR.
Any of these values may be abbreviated, and upper-case spellings
are also acceptable.
.SH KEYWORDS
boolean, conversion, double, floating-point, integer
tcl8.4.20/doc/filename.n 0000644 0036047 0045461 00000015432 12052456743 013426 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH filename n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
filename \- File name conventions supported by Tcl commands
.BE
.SH INTRODUCTION
.PP
All Tcl commands and C procedures that take file names as arguments
expect the file names to be in one of three forms, depending on the
current platform. On each platform, Tcl supports file names in the
standard forms(s) for that platform. In addition, on all platforms,
Tcl supports a Unix-like syntax intended to provide a convenient way
of constructing simple file names. However, scripts that are intended
to be portable should not assume a particular form for file names.
Instead, portable scripts must use the \fBfile split\fR and \fBfile
join\fR commands to manipulate file names (see the \fBfile\fR manual
entry for more details).
.SH "PATH TYPES"
.PP
File names are grouped into three general types based on the starting point
for the path used to specify the file: absolute, relative, and
volume-relative. Absolute names are completely qualified, giving a path to
the file relative to a particular volume and the root directory on that
volume. Relative names are unqualified, giving a path to the file relative
to the current working directory. Volume-relative names are partially
qualified, either giving the path relative to the root directory on the
current volume, or relative to the current directory of the specified
volume. The \fBfile pathtype\fR command can be used to determine the
type of a given path.
.SH "PATH SYNTAX"
.PP
The rules for native names depend on the value reported in the Tcl
array element \fBtcl_platform(platform)\fR:
.TP 10
\fBunix\fR
On Unix platforms, Tcl uses path names where the components are
separated by slashes. Path names may be relative or absolute, and
file names may contain any character other than slash. The file names
\fB\&.\fR and \fB\&..\fR are special and refer to the current directory
and the parent of the current directory respectively. Multiple
adjacent slash characters are interpreted as a single separator.
The following examples illustrate various forms of path names:
.RS
.TP 15
\fB/\fR
Absolute path to the root directory.
.TP 15
\fB/etc/passwd\fR
Absolute path to the file named \fBpasswd\fR in the directory
\fBetc\fR in the root directory.
.TP 15
\fB\&.\fR
Relative path to the current directory.
.TP 15
\fBfoo\fR
Relative path to the file \fBfoo\fR in the current directory.
.TP 15
\fBfoo/bar\fR
Relative path to the file \fBbar\fR in the directory \fBfoo\fR in the
current directory.
.TP 15
\fB\&../foo\fR
Relative path to the file \fBfoo\fR in the directory above the current
directory.
.RE
.TP
\fBwindows\fR
On Microsoft Windows platforms, Tcl supports both drive-relative and UNC
style names. Both \fB/\fR and \fB\e\fR may be used as directory separators
in either type of name. Drive-relative names consist of an optional drive
specifier followed by an absolute or relative path. UNC paths follow the
general form \fB\e\eservername\esharename\epath\efile\fR, but must at
the very least contain the server and share components, i.e.
\fB\e\eservername\esharename\fR. In both forms,
the file names \fB.\fR and \fB..\fR are special and refer to the current
directory and the parent of the current directory respectively. The
following examples illustrate various forms of path names:
.RS
.TP 15
\fB\&\e\eHost\eshare/file\fR
Absolute UNC path to a file called \fBfile\fR in the root directory of
the export point \fBshare\fR on the host \fBHost\fR. Note that
repeated use of \fBfile dirname\fR on this path will give
\fB//Host/share\fR, and will never give just \fB//Host\fR.
.TP 15
\fBc:foo\fR
Volume-relative path to a file \fBfoo\fR in the current directory on drive
\fBc\fR.
.TP 15
\fBc:/foo\fR
Absolute path to a file \fBfoo\fR in the root directory of drive
\fBc\fR.
.TP 15
\fBfoo\ebar\fR
Relative path to a file \fBbar\fR in the \fBfoo\fR directory in the current
directory on the current volume.
.TP 15
\fB\&\efoo\fR
Volume-relative path to a file \fBfoo\fR in the root directory of the current
volume.
.TP 15
\fB\&\e\efoo\fR
Volume-relative path to a file \fBfoo\fR in the root directory of the current
volume. This is not a valid UNC path, so the assumption is that the
extra backslashes are superfluous.
.RE
.SH "TILDE SUBSTITUTION"
.PP
In addition to the file name rules described above, Tcl also supports
\fIcsh\fR-style tilde substitution. If a file name starts with a
tilde, then the file name will be interpreted as if the first element
is replaced with the location of the home directory for the given
user. If the tilde is followed immediately by a separator, then the
\fB$HOME\fR environment variable is substituted. Otherwise the
characters between the tilde and the next separator are taken as a
user name, which is used to retrieve the user's home directory for
substitution.
.PP
The Windows platform does not support tilde substitution
when a user name follows the tilde. On these platforms, attempts to
use a tilde followed by a user name will generate an error that the
user does not exist when Tcl attempts to interpret that part of the
path or otherwise access the file. The behaviour of these paths
when not trying to interpret them is the same as on Unix. File
names that have a tilde without a user name will be correctly
substituted using the \fB$HOME\fR environment variable, just like
for Unix.
.SH "PORTABILITY ISSUES"
.PP
Not all file systems are case sensitive, so scripts should avoid code
that depends on the case of characters in a file name. In addition,
the character sets allowed on different devices may differ, so scripts
should choose file names that do not contain special characters like:
\fB<>:"/\e|\fR. The safest approach is to use names consisting of
alphanumeric characters only. Also Windows 3.1 only supports file
names with a root of no more than 8 characters and an extension of no
more than 3 characters.
.PP
On Windows platforms there are file and path length restrictions.
Complete paths or filenames longer than about 260 characters will lead
to errors in most file operations.
.PP
Another Windows peculiarity is that any number of trailing dots '.' in
filenames are totally ignored, so, for example, attempts to create a
file or directory with a name "foo." will result in the creation of a
file/directory with name "foo". This fact is reflected in the
results of 'file normalize'. Furthermore, a file name consisting only
of dots '.........' or dots with trailing characters '.....abc' is
illegal.
.SH KEYWORDS
current directory, absolute file name, relative file name,
volume-relative file name, portability
.SH "SEE ALSO"
file(n), glob(n)
tcl8.4.20/doc/SplitPath.3 0000644 0036047 0045461 00000006500 11737050674 013461 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH Tcl_SplitPath 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SplitPath, Tcl_JoinPath, Tcl_GetPathType \- manipulate platform-dependent file paths
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_SplitPath\fR(\fIpath, argcPtr, argvPtr\fR)
.sp
char *
\fBTcl_JoinPath\fR(\fIargc, argv, resultPtr\fR)
.sp
Tcl_PathType
\fBTcl_GetPathType\fR(\fIpath\fR)
.SH ARGUMENTS
.AS Tcl_DString ***argvPtr
.AP "CONST char * CONST" *argvPtr in
File path in a form appropriate for the current platform (see the
\fBfilename\fR manual entry for acceptable forms for path names).
.AP int *argcPtr out
Filled in with number of path elements in \fIpath\fR.
.AP "CONST char" ***argvPtr out
\fI*argvPtr\fR will be filled in with the address of an array of
pointers to the strings that are the extracted elements of \fIpath\fR.
There will be \fI*argcPtr\fR valid entries in the array, followed by
a NULL entry.
.AP int argc in
Number of elements in \fIargv\fR.
.AP "CONST char * CONST" *argv in
Array of path elements to merge together into a single path.
.AP Tcl_DString *resultPtr in/out
A pointer to an initialized \fBTcl_DString\fR to which the result of
\fBTcl_JoinPath\fR will be appended.
.BE
.SH DESCRIPTION
.PP
These procedures have been superceded by the objectified procedures in
the \fBFileSystem\fR man page, which are more efficient.
.PP
These procedures may be used to disassemble and reassemble file
paths in a platform independent manner: they provide C-level access to
the same functionality as the \fBfile split\fR, \fBfile join\fR, and
\fBfile pathtype\fR commands.
.PP
\fBTcl_SplitPath\fR breaks a path into its constituent elements,
returning an array of pointers to the elements using \fIargcPtr\fR and
\fIargvPtr\fR. The area of memory pointed to by \fI*argvPtr\fR is
dynamically allocated; in addition to the array of pointers, it also
holds copies of all the path elements. It is the caller's
responsibility to free all of this storage.
For example, suppose that you have called \fBTcl_SplitPath\fR with the
following code:
.CS
int argc;
char *path;
char **argv;
\&...
Tcl_SplitPath(string, &argc, &argv);
.CE
Then you should eventually free the storage with a call like the
following:
.CS
Tcl_Free((char *) argv);
.CE
.PP
\fBTcl_JoinPath\fR is the inverse of \fBTcl_SplitPath\fR: it takes a
collection of path elements given by \fIargc\fR and \fIargv\fR and
generates a result string that is a properly constructed path. The
result string is appended to \fIresultPtr\fR. \fIResultPtr\fR must
refer to an initialized \fBTcl_DString\fR.
.PP
If the result of \fBTcl_SplitPath\fR is passed to \fBTcl_JoinPath\fR,
the result will refer to the same location, but may not be in the same
form. This is because \fBTcl_SplitPath\fR and \fBTcl_JoinPath\fR
eliminate duplicate path separators and return a normalized form for
each platform.
.PP
\fBTcl_GetPathType\fR returns the type of the specified \fIpath\fR,
where \fBTcl_PathType\fR is one of \fBTCL_PATH_ABSOLUTE\fR,
\fBTCL_PATH_RELATIVE\fR, or \fBTCL_PATH_VOLUME_RELATIVE\fR. See the
\fBfilename\fR manual entry for a description of the path types for
each platform.
.SH KEYWORDS
file, filename, join, path, split, type
tcl8.4.20/doc/case.n 0000644 0036047 0045461 00000004776 11737050674 012574 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH case n 7.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
case \- Evaluate one of several scripts, depending on a given value
.SH SYNOPSIS
\fBcase\fI string \fR?\fBin\fR? \fIpatList body \fR?\fIpatList body \fR...?
.sp
\fBcase\fI string \fR?\fBin\fR? {\fIpatList body \fR?\fIpatList body \fR...?}
.BE
.SH DESCRIPTION
.PP
\fINote: the \fBcase\fI command is obsolete and is supported only
for backward compatibility. At some point in the future it may be
removed entirely. You should use the \fBswitch\fI command instead.\fR
.PP
The \fBcase\fR command matches \fIstring\fR against each of
the \fIpatList\fR arguments in order.
Each \fIpatList\fR argument is a list of one or
more patterns. If any of these patterns matches \fIstring\fR then
\fBcase\fR evaluates the following \fIbody\fR argument
by passing it recursively to the Tcl interpreter and returns the result
of that evaluation.
Each \fIpatList\fR argument consists of a single
pattern or list of patterns. Each pattern may contain any of the wild-cards
described under \fBstring match\fR. If a \fIpatList\fR
argument is \fBdefault\fR, the corresponding body will be evaluated
if no \fIpatList\fR matches \fIstring\fR. If no \fIpatList\fR argument
matches \fIstring\fR and no default is given, then the \fBcase\fR
command returns an empty string.
.PP
Two syntaxes are provided for the \fIpatList\fR and \fIbody\fR arguments.
The first uses a separate argument for each of the patterns and commands;
this form is convenient if substitutions are desired on some of the
patterns or commands.
The second form places all of the patterns and commands together into
a single argument; the argument must have proper list structure, with
the elements of the list being the patterns and commands.
The second form makes it easy to construct multi-line case commands,
since the braces around the whole list make it unnecessary to include a
backslash at the end of each line.
Since the \fIpatList\fR arguments are in braces in the second form,
no command or variable substitutions are performed on them; this makes
the behavior of the second form different than the first form in some
cases.
.SH "SEE ALSO"
switch(n)
.SH KEYWORDS
case, match, regular expression
tcl8.4.20/doc/fblocked.n 0000644 0036047 0045461 00000004527 11737050674 013424 0 ustar dgp 771div '\"
'\" 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.
'\"
.so man.macros
.TH fblocked n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
fblocked \- Test whether the last input operation exhausted all available input
.SH SYNOPSIS
\fBfblocked \fIchannelId\fR
.BE
.SH DESCRIPTION
.PP
The \fBfblocked\fR command returns 1 if the most recent input operation
on \fIchannelId\fR returned less information than requested because all
available input was exhausted.
For example, if \fBgets\fR is invoked when there are only three
characters available for input and no end-of-line sequence, \fBgets\fR
returns an empty string and a subsequent call to \fBfblocked\fR will
return 1.
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.VE
.SH EXAMPLE
The \fBfblocked\fR command is particularly useful when writing network
servers, as it allows you to write your code in a line-by-line style
without preventing the servicing of other connections. This can be
seen in this simple echo-service:
.PP
.CS
# This is called whenever a new client connects to the server
proc connect {chan host port} {
set clientName [format <%s:%d> $host $port]
puts "connection from $clientName"
fconfigure $chan -blocking 0 -buffering line
fileevent $chan readable [list echoLine $chan $clientName]
}
# This is called whenever either at least one byte of input
# data is available, or the channel was closed by the client.
proc echoLine {chan clientName} {
gets $chan line
if {[eof $chan]} {
puts "finishing connection from $clientName"
close $chan
} elseif {![\fBfblocked\fR $chan]} {
# Didn't block waiting for end-of-line
puts "$clientName - $line"
puts $chan $line
}
}
# Create the server socket and enter the event-loop to wait
# for incoming connections...
socket -server connect 12345
vwait forever
.CE
.SH "SEE ALSO"
gets(n), open(n), read(n), socket(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, nonblocking
tcl8.4.20/doc/trace.n 0000644 0036047 0045461 00000040765 11737050674 012755 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH trace n "8.4" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
trace \- Monitor variable accesses, command usages and command executions
.SH SYNOPSIS
\fBtrace \fIoption\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command causes Tcl commands to be executed whenever certain operations are
invoked. The legal \fIoption\fR's (which may be abbreviated) are:
.TP
\fBtrace add \fItype name ops ?args?\fR
Where \fItype\fR is \fBcommand\fR, \fBexecution\fR, or \fBvariable\fR.
.RS
.TP
\fBtrace add command\fR \fIname ops command\fR
Arrange for \fIcommand\fR to be executed whenever command \fIname\fR
is modified in one of the ways given by the list \fIops\fR. \fIName\fR will be
resolved using the usual namespace resolution rules used by
procedures. If the command does not exist, an error will be thrown.
.RS
.PP
\fIOps\fR indicates which operations are of interest, and is a list of
one or more of the following items:
.TP
\fBrename\fR
Invoke \fIcommand\fR whenever the command is renamed. Note that
renaming to the empty string is considered deletion, and will not
be traced with '\fBrename\fR'.
.TP
\fBdelete\fR
Invoke \fIcommand\fR when the command is deleted. Commands can be
deleted explicitly by using the \fBrename\fR command to rename the
command to an empty string. Commands are also deleted when the
interpreter is deleted, but traces will not be invoked because there is no
interpreter in which to execute them.
.PP
When the trace triggers, depending on the operations being traced, a
number of arguments are appended to \fIcommand\fR so that the actual
command is as follows:
.CS
\fIcommand oldName newName op\fR
.CE
\fIOldName\fR and \fInewName\fR give the traced command's current
(old) name, and the name to which it is being renamed (the empty
string if this is a 'delete' operation).
\fIOp\fR indicates what operation is being performed on the
command, and is one of \fBrename\fR or \fBdelete\fR as
defined above. The trace operation cannot be used to stop a command
from being deleted. Tcl will always remove the command once the trace
is complete. Recursive renaming or deleting will not cause further traces
of the same type to be evaluated, so a delete trace which itself
deletes the command, or a rename trace which itself renames the
command will not cause further trace evaluations to occur.
Both \fIoldName\fR and \fInewName\fR are fully qualified with any namespace(s)
in which they appear.
.RE
.TP
\fBtrace add execution\fR \fIname ops command\fR
Arrange for \fIcommand\fR to be executed whenever command \fIname\fR
is executed, with traces occurring at the points indicated by the list
\fIops\fR. \fIName\fR will be
resolved using the usual namespace resolution rules used by
procedures. If the command does not exist, an error will be thrown.
.RS
.PP
\fIOps\fR indicates which operations are of interest, and is a list of
one or more of the following items:
.TP
\fBenter\fR
Invoke \fIcommand\fR whenever the command \fIname\fR is executed,
just before the actual execution takes place.
.TP
\fBleave\fR
Invoke \fIcommand\fR whenever the command \fIname\fR is executed,
just after the actual execution takes place.
.TP
\fBenterstep\fR
Invoke \fIcommand\fR for every Tcl command which is executed
inside the procedure \fIname\fR, just before the actual execution
takes place. For example if we have 'proc foo {} { puts "hello" }',
then an \fIenterstep\fR trace would be
invoked just before \fIputs "hello"\fR is executed.
Setting an \fIenterstep\fR trace on a \fIcommand\fR
will not result in an error and is simply ignored.
.TP
\fBleavestep\fR
Invoke \fIcommand\fR for every Tcl command which is executed
inside the procedure \fIname\fR, just after the actual execution
takes place.
Setting a \fIleavestep\fR trace on a \fIcommand\fR
will not result in an error and is simply ignored.
.PP
When the trace triggers, depending on the operations being traced, a
number of arguments are appended to \fIcommand\fR so that the actual
command is as follows:
.PP
For \fBenter\fR and \fBenterstep\fR operations:
.CS
\fIcommand command-string op\fR
.CE
\fICommand-string\fR gives the complete current command being
executed (the traced command for a \fBenter\fR operation, an
arbitrary command for a \fBenterstep\fR operation), including
all arguments in their fully expanded form.
\fIOp\fR indicates what operation is being performed on the
command execution, and is one of \fBenter\fR or \fBenterstep\fR as
defined above. The trace operation can be used to stop the
command from executing, by deleting the command in question. Of
course when the command is subsequently executed, an 'invalid command'
error will occur.
.PP
For \fBleave\fR and \fBleavestep\fR operations:
.CS
\fIcommand command-string code result op\fR
.CE
\fICommand-string\fR gives the complete current command being
executed (the traced command for a \fBenter\fR operation, an
arbitrary command for a \fBenterstep\fR operation), including
all arguments in their fully expanded form.
\fICode\fR gives the result code of that execution, and \fIresult\fR
the result string.
\fIOp\fR indicates what operation is being performed on the
command execution, and is one of \fBleave\fR or \fBleavestep\fR as
defined above.
Note that the creation of many \fBenterstep\fR or
\fBleavestep\fR traces can lead to unintuitive results, since the
invoked commands from one trace can themselves lead to further
command invocations for other traces.
.PP
\fICommand\fR executes in the same context as the code that invoked
the traced operation: thus the \fIcommand\fR, if invoked from a procedure,
will have access to the same local variables as code in the procedure.
This context may be different than the context in which the trace was
created. If \fIcommand\fR invokes a procedure (which it normally does)
then the procedure will have to use upvar or uplevel commands if it wishes
to access the local variables of the code which invoked the trace operation.
.PP
While \fIcommand\fR is executing during an execution trace, traces
on \fIname\fR are temporarily disabled. This allows the \fIcommand\fR
to execute \fIname\fR in its body without invoking any other traces again.
If an error occurs while executing the \fIcommand\fR body, then the
command \fIname\fR as a whole will return that same error.
.PP
When multiple traces are set on \fIname\fR, then for \fIenter\fR
and \fIenterstep\fR operations, the traced commands are invoked
in the reverse order of how the traces were originally created;
and for \fIleave\fR and \fIleavestep\fR operations, the traced
commands are invoked in the original order of creation.
.PP
The behavior of execution traces is currently undefined for a command
\fIname\fR imported into another namespace.
.RE
.TP
\fBtrace add variable\fI name ops command\fR
Arrange for \fIcommand\fR to be executed whenever variable \fIname\fR
is accessed in one of the ways given by the list \fIops\fR. \fIName\fR may
refer to a normal variable, an element of an array, or to an array
as a whole (i.e. \fIname\fR may be just the name of an array, with no
parenthesized index). If \fIname\fR refers to a whole array, then
\fIcommand\fR is invoked whenever any element of the array is
manipulated. If the variable does not exist, it will be created but
will not be given a value, so it will be visible to \fBnamespace which\fR
queries, but not to \fBinfo exists\fR queries.
.RS
.PP
\fIOps\fR indicates which operations are of interest, and is a list of
one or more of the following items:
.TP
\fBarray\fR
Invoke \fIcommand\fR whenever the variable is accessed or modified via
the \fBarray\fR command, provided that \fIname\fR is not a scalar
variable at the time that the \fBarray\fR command is invoked. If
\fIname\fR is a scalar variable, the access via the \fBarray\fR
command will not trigger the trace.
.TP
\fBread\fR
Invoke \fIcommand\fR whenever the variable is read.
.TP
\fBwrite\fR
Invoke \fIcommand\fR whenever the variable is written.
.TP
\fBunset\fR
Invoke \fIcommand\fR whenever the variable is unset. Variables
can be unset explicitly with the \fBunset\fR command, or
implicitly when procedures return (all of their local variables
are unset). Variables are also unset when interpreters are
deleted, but traces will not be invoked because there is no
interpreter in which to execute them.
.PP
When the trace triggers, three arguments are appended to
\fIcommand\fR so that the actual command is as follows:
.CS
\fIcommand name1 name2 op\fR
.CE
\fIName1\fR and \fIname2\fR give the name(s) for the variable
being accessed: if the variable is a scalar then \fIname1\fR
gives the variable's name and \fIname2\fR is an empty string;
if the variable is an array element then \fIname1\fR gives the
name of the array and name2 gives the index into the array;
if an entire array is being deleted and the trace was registered
on the overall array, rather than a single element, then \fIname1\fR
gives the array name and \fIname2\fR is an empty string.
\fIName1\fR and \fIname2\fR are not necessarily the same as the
name used in the \fBtrace variable\fR command: the \fBupvar\fR
command allows a procedure to reference a variable under a
different name.
\fIOp\fR indicates what operation is being performed on the
variable, and is one of \fBread\fR, \fBwrite\fR, or \fBunset\fR as
defined above.
.PP
\fICommand\fR executes in the same context as the code that invoked
the traced operation: if the variable was accessed as part of a Tcl
procedure, then \fIcommand\fR will have access to the same local
variables as code in the procedure. This context may be different
than the context in which the trace was created. If \fIcommand\fR
invokes a procedure (which it normally does) then the procedure will
have to use \fBupvar\fR or \fBuplevel\fR if it wishes to access the
traced variable. Note also that \fIname1\fR may not necessarily be
the same as the name used to set the trace on the variable;
differences can occur if the access is made through a variable defined
with the \fBupvar\fR command.
.PP
For read and write traces, \fIcommand\fR can modify the variable to
affect the result of the traced operation. If \fIcommand\fR modifies
the value of a variable during a read or write trace, then the new
value will be returned as the result of the traced operation. The
return value from \fIcommand\fR is ignored except that if it returns
an error of any sort then the traced operation also returns an error
with the same error message returned by the trace command (this
mechanism can be used to implement read-only variables, for example).
For write traces, \fIcommand\fR is invoked after the variable's value
has been changed; it can write a new value into the variable to
override the original value specified in the write operation. To
implement read-only variables, \fIcommand\fR will have to restore the
old value of the variable.
.PP
While \fIcommand\fR is executing during a read or write trace, traces
on the variable are temporarily disabled. This means that reads and
writes invoked by \fIcommand\fR will occur directly, without invoking
\fIcommand\fR (or any other traces) again. However, if \fIcommand\fR
unsets the variable then unset traces will be invoked.
.PP
When an unset trace is invoked, the variable has already been deleted:
it will appear to be undefined with no traces. If an unset occurs
because of a procedure return, then the trace will be invoked in the
variable context of the procedure being returned to: the stack frame
of the returning procedure will no longer exist. Traces are not
disabled during unset traces, so if an unset trace command creates a
new trace and accesses the variable, the trace will be invoked. Any
errors in unset traces are ignored.
.PP
If there are multiple traces on a variable they are invoked in order
of creation, most-recent first. If one trace returns an error, then
no further traces are invoked for the variable. If an array element
has a trace set, and there is also a trace set on the array as a
whole, the trace on the overall array is invoked before the one on the
element.
.PP
Once created, the trace remains in effect either until the trace is
removed with the \fBtrace remove variable\fR command described below,
until the variable is unset, or until the interpreter is deleted.
Unsetting an element of array will remove any traces on that element,
but will not remove traces on the overall array.
.PP
This command returns an empty string.
.RE
.RE
.TP
\fBtrace remove \fItype name opList command\fR
Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR.
.RS
.TP
\fBtrace remove command\fI name opList command\fR
If there is a trace set on command \fIname\fR with the operations and
command given by \fIopList\fR and \fIcommand\fR, then the trace is
removed, so that \fIcommand\fR will never again be invoked. Returns
an empty string. If \fIname\fR doesn't exist, the command will throw
an error.
.TP
\fBtrace remove execution\fI name opList command\fR
If there is a trace set on command \fIname\fR with the operations and
command given by \fIopList\fR and \fIcommand\fR, then the trace is
removed, so that \fIcommand\fR will never again be invoked. Returns
an empty string. If \fIname\fR doesn't exist, the command will throw
an error.
.TP
\fBtrace remove variable\fI name opList command\fR
If there is a trace set on variable \fIname\fR with the operations and
command given by \fIopList\fR and \fIcommand\fR, then the trace is
removed, so that \fIcommand\fR will never again be invoked. Returns
an empty string.
.RE
.TP
\fBtrace info \fItype name\fR
Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR.
.RS
.TP
\fBtrace info command\fI name\fR
Returns a list containing one element for each trace currently set on
command \fIname\fR. Each element of the list is itself a list
containing two elements, which are the \fIopList\fR and \fIcommand\fR
associated with the trace. If \fIname\fR doesn't have any traces set,
then the result of the command will be an empty string. If \fIname\fR
doesn't exist, the command will throw an error.
.TP
\fBtrace info execution\fI name\fR
Returns a list containing one element for each trace currently set on
command \fIname\fR. Each element of the list is itself a list
containing two elements, which are the \fIopList\fR and \fIcommand\fR
associated with the trace. If \fIname\fR doesn't have any traces set,
then the result of the command will be an empty string. If \fIname\fR
doesn't exist, the command will throw an error.
.TP
\fBtrace info variable\fI name\fR
Returns a list containing one element for each trace currently set on
variable \fIname\fR. Each element of the list is itself a list
containing two elements, which are the \fIopList\fR and \fIcommand\fR
associated with the trace. If \fIname\fR doesn't exist or doesn't
have any traces set, then the result of the command will be an empty
string.
.RE
.PP
For backwards compatibility, three other subcommands are available:
.RS
.TP
\fBtrace variable \fIname ops command\fR
This is equivalent to \fBtrace add variable \fIname ops command\fR.
.TP
\fBtrace vdelete \fIname ops command\fR
This is equivalent to \fBtrace remove variable \fIname ops command\fR
.TP
\fBtrace vinfo \fIname\fR
This is equivalent to \fBtrace info variable \fIname\fR
.RE
.PP
These subcommands are deprecated and will likely be removed in a
future version of Tcl. They use an older syntax in which \fBarray\fR,
\fBread\fR, \fBwrite\fR, \fBunset\fR are replaced by \fBa\fR, \fBr\fR,
\fBw\fR and \fBu\fR respectively, and the \fIops\fR argument is not a
list, but simply a string concatenation of the operations, such as
\fBrwua\fR.
.SH EXAMPLES
Print a message whenever either of the global variables \fBfoo\fR and
\fBbar\fR are updated, even if they have a different local name at the
time (which can be done with the \fBupvar\fR command):
.CS
proc tracer {varname args} {
upvar #0 $varname var
puts "$varname was updated to be \e"$var\e""
}
\fBtrace add\fR variable foo write "tracer foo"
\fBtrace add\fR variable bar write "tracer bar"
.CE
.PP
Ensure that the global variable \fBfoobar\fR always contains the
product of the global variables \fBfoo\fR and \fBbar\fR:
.CS
proc doMult args {
global foo bar foobar
set foobar [expr {$foo * $bar}]
}
\fBtrace add\fR variable foo write doMult
\fBtrace add\fR variable bar write doMult
.CE
.SH "SEE ALSO"
set(n), unset(n)
.SH KEYWORDS
read, command, rename, variable, write, trace, unset
tcl8.4.20/doc/unknown.n 0000644 0036047 0045461 00000007342 11737050674 013350 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH unknown n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
unknown \- Handle attempts to use non-existent commands
.SH SYNOPSIS
\fBunknown \fIcmdName \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command is invoked by the Tcl interpreter whenever a script
tries to invoke a command that doesn't exist. The default implementation
of \fBunknown\fR is a library procedure defined when Tcl initializes an
interpreter. You can override the default \fBunknown\fR to change its
functionality. Note that there is no default implementation of
\fBunknown\fR in a safe interpreter.
.PP
If the Tcl interpreter encounters a command name for which there
is not a defined command, then Tcl checks for the existence of
a command named \fBunknown\fR.
If there is no such command, then the interpreter returns an
error.
If the \fBunknown\fR command exists, then it is invoked with
arguments consisting of the fully-substituted name and arguments
for the original non-existent command.
The \fBunknown\fR command typically does things like searching
through library directories for a command procedure with the name
\fIcmdName\fR, or expanding abbreviated command names to full-length,
or automatically executing unknown commands as sub-processes.
In some cases (such as expanding abbreviations) \fBunknown\fR will
change the original command slightly and then (re-)execute it.
The result of the \fBunknown\fR command is used as the result for
the original non-existent command.
.PP
The default implementation of \fBunknown\fR behaves as follows.
It first calls the \fBauto_load\fR library procedure to load the command.
If this succeeds, then it executes the original command with its
original arguments.
If the auto-load fails then \fBunknown\fR calls \fBauto_execok\fR
to see if there is an executable file by the name \fIcmd\fR.
If so, it invokes the Tcl \fBexec\fR command
with \fIcmd\fR and all the \fIargs\fR as arguments.
If \fIcmd\fR can't be auto-executed, \fBunknown\fR checks to
see if the command was invoked at top-level and outside of any
script. If so, then \fBunknown\fR takes two additional steps.
First, it sees if \fIcmd\fR has one of the following three forms:
\fB!!\fR, \fB!\fIevent\fR, or \fB^\fIold\fB^\fInew\fR?\fB^\fR?.
If so, then \fBunknown\fR carries out history substitution
in the same way that \fBcsh\fR would for these constructs.
Finally, \fBunknown\fR checks to see if \fIcmd\fR is
a unique abbreviation for an existing Tcl command.
If so, it expands the command name and executes the command with
the original arguments.
If none of the above efforts has been able to execute
the command, \fBunknown\fR generates an error return.
If the global variable \fBauto_noload\fR is defined, then the auto-load
step is skipped.
If the global variable \fBauto_noexec\fR is defined then the
auto-exec step is skipped.
Under normal circumstances the return value from \fBunknown\fR
is the return value from the command that was eventually
executed.
.SH EXAMPLE
Arrange for the \fBunknown\fR command to have its standard behavior
except for first logging the fact that a command was not found:
.PP
.CS
# Save the original one so we can chain to it
rename \fBunknown\fR _original_unknown
# Provide our own implementation
proc \fBunknown\fR args {
puts stderr "WARNING: unknown command: $args"
uplevel 1 [list _original_unknown {expand}$args]
}
.CE
.SH "SEE ALSO"
info(n), proc(n), interp(n), library(n)
.SH KEYWORDS
error, non-existent command
tcl8.4.20/doc/CrtInterp.3 0000644 0036047 0045461 00000013457 11737050674 013474 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpDeleted \- create and delete Tcl command interpreters
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Interp *
\fBTcl_CreateInterp\fR()
.sp
\fBTcl_DeleteInterp\fR(\fIinterp\fR)
.sp
int
\fBTcl_InterpDeleted\fR(\fIinterp\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp
.AP Tcl_Interp *interp in
Token for interpreter to be destroyed.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CreateInterp\fR creates a new interpreter structure and returns
a token for it. The token is required in calls to most other Tcl
procedures, such as \fBTcl_CreateCommand\fR, \fBTcl_Eval\fR, and
\fBTcl_DeleteInterp\fR.
Clients are only allowed to access a few of the fields of
Tcl_Interp structures; see the \fBTcl_Interp\fR
and \fBTcl_CreateCommand\fR man pages for details.
The new interpreter is initialized with the built-in Tcl commands
and with the variables documented in tclvars(n). To bind in
additional commands, call \fBTcl_CreateCommand\fR.
.PP
\fBTcl_DeleteInterp\fR marks an interpreter as deleted; the interpreter
will eventually be deleted when all calls to \fBTcl_Preserve\fR for it have
been matched by calls to \fBTcl_Release\fR. At that time, all of the
resources associated with it, including variables, procedures, and
application-specific command bindings, will be deleted. After
\fBTcl_DeleteInterp\fR returns any attempt to use \fBTcl_Eval\fR on the
interpreter will fail and return \fBTCL_ERROR\fR. After the call to
\fBTcl_DeleteInterp\fR it is safe to examine the interpreter's result,
query or set the values of variables, define, undefine or retrieve
procedures, and examine the runtime evaluation stack. See below, in the
section \fBINTERPRETERS AND MEMORY MANAGEMENT\fR for details.
.PP
\fBTcl_InterpDeleted\fR returns nonzero if \fBTcl_DeleteInterp\fR was
called with \fIinterp\fR as its argument; this indicates that the
interpreter will eventually be deleted, when the last call to
\fBTcl_Preserve\fR for it is matched by a call to \fBTcl_Release\fR. If
nonzero is returned, further calls to \fBTcl_Eval\fR in this interpreter
will return \fBTCL_ERROR\fR.
.PP
\fBTcl_InterpDeleted\fR is useful in deletion callbacks to distinguish
between when only the memory the callback is responsible for is being
deleted and when the whole interpreter is being deleted. In the former case
the callback may recreate the data being deleted, but this would lead to an
infinite loop if the interpreter were being deleted.
.SH "INTERPRETERS AND MEMORY MANAGEMENT"
.PP
\fBTcl_DeleteInterp\fR can be called at any time on an interpreter that may
be used by nested evaluations and C code in various extensions. Tcl
implements a simple mechanism that allows callers to use interpreters
without worrying about the interpreter being deleted in a nested call, and
without requiring special code to protect the interpreter, in most cases.
This mechanism ensures that nested uses of an interpreter can safely
continue using it even after \fBTcl_DeleteInterp\fR is called.
.PP
The mechanism relies on matching up calls to \fBTcl_Preserve\fR with calls
to \fBTcl_Release\fR. If \fBTcl_DeleteInterp\fR has been called, only when
the last call to \fBTcl_Preserve\fR is matched by a call to
\fBTcl_Release\fR, will the interpreter be freed. See the manual entry for
\fBTcl_Preserve\fR for a description of these functions.
.PP
The rules for when the user of an interpreter must call \fBTcl_Preserve\fR
and \fBTcl_Release\fR are simple:
.TP
Interpreters Passed As Arguments
Functions that are passed an interpreter as an argument can safely use the
interpreter without any special protection. Thus, when you write an
extension consisting of new Tcl commands, no special code is needed to
protect interpreters received as arguments. This covers the majority of all
uses.
.TP
Interpreter Creation And Deletion
When a new interpreter is created and used in a call to \fBTcl_Eval\fR,
\fBTcl_VarEval\fR, \fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or
\fBTcl_GetVar\fR, a pair of calls to \fBTcl_Preserve\fR and
\fBTcl_Release\fR should be wrapped around all uses of the interpreter.
Remember that it is unsafe to use the interpreter once \fBTcl_Release\fR
has been called. To ensure that the interpreter is properly deleted when
it is no longer needed, call \fBTcl_InterpDeleted\fR to test if some other
code already called \fBTcl_DeleteInterp\fR; if not, call
\fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fR in your own code.
.TP
Retrieving An Interpreter From A Data Structure
When an interpreter is retrieved from a data structure (e.g. the client
data of a callback) for use in \fBTcl_Eval\fR, \fBTcl_VarEval\fR,
\fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or \fBTcl_GetVar\fR, a pair of
calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around
all uses of the interpreter; it is unsafe to reuse the interpreter once
\fBTcl_Release\fR has been called. If an interpreter is stored inside a
callback data structure, an appropriate deletion cleanup mechanism should
be set up by the code that creates the data structure so that the
interpreter is removed from the data structure (e.g. by setting the field
to NULL) when the interpreter is deleted. Otherwise, you may be using an
interpreter that has been freed and whose memory may already have been
reused.
.PP
All uses of interpreters in Tcl and Tk have already been protected.
Extension writers should ensure that their code also properly protects any
additional interpreters used, as described above.
.SH "SEE ALSO"
Tcl_Preserve(3), Tcl_Release(3)
.SH KEYWORDS
command, create, delete, interpreter
tcl8.4.20/doc/eof.n 0000644 0036047 0045461 00000003051 11737050674 012413 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH eof n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
eof \- Check for end of file condition on channel
.SH SYNOPSIS
\fBeof \fIchannelId\fR
.BE
.SH DESCRIPTION
.PP
Returns 1 if an end of file condition occurred during the most
recent input operation on \fIchannelId\fR (such as \fBgets\fR),
0 otherwise.
.PP
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.SH EXAMPLES
Read and print out the contents of a file line-by-line:
.CS
set f [open somefile.txt]
while {1} {
set line [gets $f]
if {[\fBeof\fR $f]} {
close $f
break
}
puts "Read line: $line"
}
.CE
.PP
Read and print out the contents of a file by fixed-size records:
.CS
set f [open somefile.dat]
fconfigure $f -translation binary
set recordSize 40
while {1} {
set record [read $f $recordSize]
if {[\fBeof\fR $f]} {
close $f
break
}
puts "Read record: $record"
}
.CE
.SH "SEE ALSO"
file(n), open(n), close(n), fblocked(n), Tcl_StandardChannels(3)
.SH KEYWORDS
channel, end of file
tcl8.4.20/doc/lindex.n 0000644 0036047 0045461 00000005307 11737050674 013133 0 ustar dgp 771div '\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH lindex n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
lindex \- Retrieve an element from a list
.SH SYNOPSIS
\fBlindex \fIlist ?index...?\fR
.BE
.SH DESCRIPTION
.PP
.VS 8.4
The \fBlindex\fP command accepts a parameter, \fIlist\fP, which
it treats as a Tcl list. It also accepts zero or more \fIindices\fP into
the list. The indices may be presented either consecutively on the
command line, or grouped in a
Tcl list and presented as a single argument.
.PP
If no indices are presented, the command takes the form:
.CS
lindex list
.CE
or
.CS
lindex list {}
.CE
In this case, the return value of \fBlindex\fR is simply the value of the
\fIlist\fR parameter.
.PP
When presented with a single index, the \fBlindex\fR command
treats \fIlist\fR as a Tcl list and returns the
.VE
\fIindex\fR'th element from it (0 refers to the first element of the list).
In extracting the element, \fBlindex\fR observes the same rules
concerning braces and quotes and backslashes as the Tcl command
interpreter; however, variable
substitution and command substitution do not occur.
If \fIindex\fR is negative or greater than or equal to the number
of elements in \fIvalue\fR, then an empty
string is returned.
If \fIindex\fR has the value \fBend\fR, it refers to the last element
in the list, and \fBend\-\fIinteger\fR refers to the last element in
the list minus the specified integer offset.
.PP
.VS 8.4
If additional \fIindex\fR arguments are supplied, then each argument is
used in turn to select an element from the previous indexing operation,
allowing the script to select elements from sublists. The command,
.CS
lindex $a 1 2 3
.CE
or
.CS
lindex $a {1 2 3}
.CE
is synonymous with
.CS
lindex [lindex [lindex $a 1] 2] 3
.CE
.SH EXAMPLES
.CS
\fBlindex\fR {a b c} \fI=> a b c\fR
\fBlindex\fR {a b c} {} \fI=> a b c\fR
\fBlindex\fR {a b c} 0 \fI=> a\fR
\fBlindex\fR {a b c} 2 \fI=> c\fR
\fBlindex\fR {a b c} end \fI=> c\fR
\fBlindex\fR {a b c} end-1 \fI=> b\fR
\fBlindex\fR {{a b c} {d e f} {g h i}} 2 1 \fI=> h\fR
\fBlindex\fR {{a b c} {d e f} {g h i}} {2 1} \fI=> h\fR
\fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} 1 1 0 \fI=> g\fR
\fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} {1 1 0} \fI=> g\fR
.CE
.VE
.SH "SEE ALSO"
list(n), lappend(n), linsert(n), llength(n), lsearch(n),
.VS 8.4
lset(n),
.VE
lsort(n),
lrange(n), lreplace(n)
.SH KEYWORDS
element, index, list
tcl8.4.20/doc/interp.n 0000644 0036047 0045461 00000074677 11737050674 013171 0 ustar dgp 771div '\"
'\" Copyright (c) 1995-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.
'\"
.so man.macros
.TH interp n 7.6 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
interp \- Create and manipulate Tcl interpreters
.SH SYNOPSIS
\fBinterp \fIoption \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command makes it possible to create one or more new Tcl
interpreters that co-exist with the creating interpreter in the
same application. The creating interpreter is called the \fImaster\fR
and the new interpreter is called a \fIslave\fR.
A master can create any number of slaves, and each slave can
itself create additional slaves for which it is master, resulting
in a hierarchy of interpreters.
.PP
Each interpreter is independent from the others: it has its own name
space for commands, procedures, and global variables.
A master interpreter may create connections between its slaves and
itself using a mechanism called an \fIalias\fR. An \fIalias\fR is
a command in a slave interpreter which, when invoked, causes a
command to be invoked in its master interpreter or in another slave
interpreter. The only other connections between interpreters are
through environment variables (the \fBenv\fR variable), which are
normally shared among all interpreters in the application. Note that the
name space for files (such as the names returned by the \fBopen\fR command)
is no longer shared between interpreters. Explicit commands are provided to
share files and to transfer references to open files from one interpreter
to another.
.PP
The \fBinterp\fR command also provides support for \fIsafe\fR
interpreters. A safe interpreter is a slave whose functions have
been greatly restricted, so that it is safe to execute untrusted
scripts without fear of them damaging other interpreters or the
application's environment. For example, all IO channel creation
commands and subprocess creation commands are made inaccessible to safe
interpreters.
.VS
See \fBSAFE INTERPRETERS\fR below for more information on
what features are present in a safe interpreter.
The dangerous functionality is not removed from the safe interpreter;
instead, it is \fIhidden\fR, so that only trusted interpreters can obtain
access to it. For a detailed explanation of hidden commands, see
\fBHIDDEN COMMANDS\fR, below.
The alias mechanism can be used for protected communication (analogous to a
kernel call) between a slave interpreter and its master.
See \fBALIAS INVOCATION\fR, below, for more details
on how the alias mechanism works.
.VE
.PP
A qualified interpreter name is a proper Tcl lists containing a subset of its
ancestors in the interpreter hierarchy, terminated by the string naming the
interpreter in its immediate master. Interpreter names are relative to the
interpreter in which they are used. For example, if \fBa\fR is a slave of
the current interpreter and it has a slave \fBa1\fR, which in turn has a
slave \fBa11\fR, the qualified name of \fBa11\fR in \fBa\fR is the list
\fBa1 a11\fR.
.PP
The \fBinterp\fR command, described below, accepts qualified interpreter
names as arguments; the interpreter in which the command is being evaluated
can always be referred to as \fB{}\fR (the empty list or string). Note that
it is impossible to refer to a master (ancestor) interpreter by name in a
slave interpreter except through aliases. Also, there is no global name by
which one can refer to the first interpreter created in an application.
Both restrictions are motivated by safety concerns.
.SH "THE INTERP COMMAND"
.PP
The \fBinterp\fR command is used to create, delete, and manipulate
slave interpreters, and to share or transfer
channels between interpreters. It can have any of several forms, depending
on the \fIoption\fR argument:
.TP
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR
Returns a Tcl list whose elements are the \fItargetCmd\fR and
\fIarg\fRs associated with the alias represented by \fIsrcToken\fR
(this is the value returned when the alias was
created; it is possible that the name of the source command in the
slave is different from \fIsrcToken\fR).
.TP
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR \fB{}\fR
Deletes the alias for \fIsrcToken\fR in the slave interpreter identified by
\fIsrcPath\fR.
\fIsrcToken\fR refers to the value returned when the alias
was created; if the source command has been renamed, the renamed
command will be deleted.
.TP
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR \fItargetPath\fR \fItargetCmd \fR?\fIarg arg ...\fR?
This command creates an alias between one slave and another (see the
\fBalias\fR slave command below for creating aliases between a slave
and its master). In this command, either of the slave interpreters
may be anywhere in the hierarchy of interpreters under the interpreter
invoking the command.
\fISrcPath\fR and \fIsrcCmd\fR identify the source of the alias.
\fISrcPath\fR is a Tcl list whose elements select a particular
interpreter. For example, ``\fBa b\fR'' identifies an interpreter
\fBb\fR, which is a slave of interpreter \fBa\fR, which is a slave
of the invoking interpreter. An empty list specifies the interpreter
invoking the command. \fIsrcCmd\fR gives the name of a new
command, which will be created in the source interpreter.
\fITargetPath\fR and \fItargetCmd\fR specify a target interpreter
and command, and the \fIarg\fR arguments, if any, specify additional
arguments to \fItargetCmd\fR which are prepended to any arguments specified
in the invocation of \fIsrcCmd\fR.
\fITargetCmd\fR may be undefined at the time of this call, or it may
already exist; it is not created by this command.
The alias arranges for the given target command to be invoked
in the target interpreter whenever the given source command is
invoked in the source interpreter. See \fBALIAS INVOCATION\fR below for
more details.
The command returns a token that uniquely identifies the command created
\fIsrcCmd\fR, even if the command is renamed afterwards. The token may but
does not have to be equal to \fIsrcCmd\fR.
.TP
\fBinterp\fR \fBaliases \fR?\fIpath\fR?
This command returns a Tcl list of the tokens of all the source commands for
aliases defined in the interpreter identified by \fIpath\fR. The tokens
correspond to the values returned when
the aliases were created (which may not be the same
as the current names of the commands).
.TP
\fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR?
Creates a slave interpreter identified by \fIpath\fR and a new command,
called a \fIslave command\fR. The name of the slave command is the last
component of \fIpath\fR. The new slave interpreter and the slave command
are created in the interpreter identified by the path obtained by removing
the last component from \fIpath\fR. For example, if \fIpath is \fBa b
c\fR then a new slave interpreter and slave command named \fBc\fR are
created in the interpreter identified by the path \fBa b\fR.
The slave command may be used to manipulate the new interpreter as
described below. If \fIpath\fR is omitted, Tcl creates a unique name of the
form \fBinterp\fIx\fR, where \fIx\fR is an integer, and uses it for the
interpreter and the slave command. If the \fB\-safe\fR switch is specified
(or if the master interpreter is a safe interpreter), the new slave
interpreter will be created as a safe interpreter with limited
functionality; otherwise the slave will include the full set of Tcl
built-in commands and variables. The \fB\-\|\-\fR switch can be used to
mark the end of switches; it may be needed if \fIpath\fR is an unusual
value such as \fB\-safe\fR. The result of the command is the name of the
new interpreter. The name of a slave interpreter must be unique among all
the slaves for its master; an error occurs if a slave interpreter by the
given name already exists in this master.
The initial recursion limit of the slave interpreter is set to the
current recursion limit of its parent interpreter.
.TP
\fBinterp\fR \fBdelete \fR?\fIpath ...?\fR
Deletes zero or more interpreters given by the optional \fIpath\fR
arguments, and for each interpreter, it also deletes its slaves. The
command also deletes the slave command for each interpreter deleted.
For each \fIpath\fR argument, if no interpreter by that name
exists, the command raises an error.
.TP
\fBinterp\fR \fBeval\fR \fIpath arg \fR?\fIarg ...\fR?
This command concatenates all of the \fIarg\fR arguments in the same
fashion as the \fBconcat\fR command, then evaluates the resulting string as
a Tcl script in the slave interpreter identified by \fIpath\fR. The result
of this evaluation (including error information such as the \fBerrorInfo\fR
and \fBerrorCode\fR variables, if an error occurs) is returned to the
invoking interpreter.
Note that the script will be executed in the current context stack frame of the
\fIpath\fR interpreter; this is so that the implementations (in a master
interpreter) of aliases in a slave interpreter can execute scripts in
the slave that find out information about the slave's current state
and stack frame.
.TP
\fBinterp exists \fIpath\fR
Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR
exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the
invoking interpreter is used.
.VS "" BR
.TP
\fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR?
Makes the hidden command \fIhiddenName\fR exposed, eventually bringing
it back under a new \fIexposedCmdName\fR name (this name is currently
accepted only if it is a valid global name space name without any ::),
in the interpreter
denoted by \fIpath\fR.
If an exposed command with the targeted name already exists, this command
fails.
Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below.
.TP
\fBinterp\fR \fBhide\fR \fIpath\fR \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
Makes the exposed command \fIexposedCmdName\fR hidden, renaming
it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if
\fIhiddenCmdName\fR is not given, in the interpreter denoted
by \fIpath\fR.
If a hidden command with the targeted name already exists, this command
fails.
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
not contain namespace qualifiers, or an error is raised.
Commands to be hidden by \fBinterp hide\fR are looked up in the global
namespace even if the current namespace is not the global one. This
prevents slaves from fooling a master interpreter into hiding the wrong
command, by making the current namespace be different from the global one.
Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below.
.TP
\fBinterp\fR \fBhidden\fR \fIpath\fR
Returns a list of the names of all hidden commands in the interpreter
identified by \fIpath\fR.
.TP
\fBinterp\fR \fBinvokehidden\fR \fIpath\fR ?\fB-global\fR? \fIhiddenCmdName\fR ?\fIarg ...\fR?
Invokes the hidden command \fIhiddenCmdName\fR with the arguments supplied
in the interpreter denoted by \fIpath\fR. No substitutions or evaluation
are applied to the arguments.
If the \fB-global\fR flag is present, the hidden command is invoked at the
global level in the target interpreter; otherwise it is invoked at the
current call frame and can access local variables in that and outer call
frames.
Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below.
.VE
.TP
\fBinterp issafe\fR ?\fIpath\fR?
Returns \fB1\fR if the interpreter identified by the specified \fIpath\fR
is safe, \fB0\fR otherwise.
.VS "" BR
.TP
\fBinterp marktrusted\fR \fIpath\fR
Marks the interpreter identified by \fIpath\fR as trusted. Does
not expose the hidden commands. This command can only be invoked from a
trusted interpreter.
The command has no effect if the interpreter identified by \fIpath\fR is
already trusted.
.VE
.TP
\fBinterp\fR \fBrecursionlimit\fR \fIpath\fR ?\fInewlimit\fR?
Returns the maximum allowable nesting depth for the interpreter
specified by \fIpath\fR. If \fInewlimit\fR is specified,
the interpreter recursion limit will be set so that nesting
of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR
and related procedures in that interpreter will return an error.
The \fInewlimit\fR value is also returned.
The \fInewlimit\fR value must be a positive integer between 1 and the
maximum value of a non-long integer on the platform.
.sp
The command sets the maximum size of the Tcl call stack only. It cannot
by itself prevent stack overflows on the C stack being used by the
application. If your machine has a limit on the size of the C stack, you
may get stack overflows before reaching the limit set by the command. If
this happens, see if there is a mechanism in your system for increasing
the maximum size of the C stack.
.TP
\fBinterp\fR \fBshare\fR \fIsrcPath channelId destPath\fR
Causes the IO channel identified by \fIchannelId\fR to become shared
between the interpreter identified by \fIsrcPath\fR and the interpreter
identified by \fIdestPath\fR. Both interpreters have the same permissions
on the IO channel.
Both interpreters must close it to close the underlying IO channel; IO
channels accessible in an interpreter are automatically closed when an
interpreter is destroyed.
.TP
\fBinterp\fR \fBslaves\fR ?\fIpath\fR?
Returns a Tcl list of the names of all the slave interpreters associated
with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted,
the invoking interpreter is used.
.TP
\fBinterp\fR \fBtarget\fR \fIpath alias\fR
Returns a Tcl list describing the target interpreter for an alias. The
alias is specified with an interpreter path and source command name, just
as in \fBinterp alias\fR above. The name of the target interpreter is
returned as an interpreter path, relative to the invoking interpreter.
If the target interpreter for the alias is the invoking interpreter then an
empty list is returned. If the target interpreter for the alias is not the
invoking interpreter or one of its descendants then an error is generated.
The target command does not have to be defined at the time of this invocation.
.TP
\fBinterp\fR \fBtransfer\fR \fIsrcPath channelId destPath\fR
Causes the IO channel identified by \fIchannelId\fR to become available in
the interpreter identified by \fIdestPath\fR and unavailable in the
interpreter identified by \fIsrcPath\fR.
.SH "SLAVE COMMAND"
.PP
For each slave interpreter created with the \fBinterp\fR command, a
new Tcl command is created in the master interpreter with the same
name as the new interpreter. This command may be used to invoke
various operations on the interpreter. It has the following
general form:
.CS
\fIslave command \fR?\fIarg arg ...\fR?
.CE
\fISlave\fR is the name of the interpreter, and \fIcommand\fR
and the \fIarg\fRs determine the exact behavior of the command.
The valid forms of this command are:
.TP
\fIslave \fBaliases\fR
Returns a Tcl list whose elements are the tokens of all the
aliases in \fIslave\fR. The tokens correspond to the values returned when
the aliases were created (which may not be the same
as the current names of the commands).
.TP
\fIslave \fBalias \fIsrcToken\fR
Returns a Tcl list whose elements are the \fItargetCmd\fR and
\fIarg\fRs associated with the alias represented by \fIsrcToken\fR
(this is the value returned when the alias was
created; it is possible that the actual source command in the
slave is different from \fIsrcToken\fR).
.TP
\fIslave \fBalias \fIsrcToken \fB{}\fR
Deletes the alias for \fIsrcToken\fR in the slave interpreter.
\fIsrcToken\fR refers to the value returned when the alias
was created; if the source command has been renamed, the renamed
command will be deleted.
.TP
\fIslave \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR?
Creates an alias such that whenever \fIsrcCmd\fR is invoked
in \fIslave\fR, \fItargetCmd\fR is invoked in the master.
The \fIarg\fR arguments will be passed to \fItargetCmd\fR as additional
arguments, prepended before any arguments passed in the invocation of
\fIsrcCmd\fR.
See \fBALIAS INVOCATION\fR below for details.
The command returns a token that uniquely identifies the command created
\fIsrcCmd\fR, even if the command is renamed afterwards. The token may but
does not have to be equal to \fIsrcCmd\fR.
.TP
\fIslave \fBeval \fIarg \fR?\fIarg ..\fR?
This command concatenates all of the \fIarg\fR arguments in
the same fashion as the \fBconcat\fR command, then evaluates
the resulting string as a Tcl script in \fIslave\fR.
The result of this evaluation (including error information
such as the \fBerrorInfo\fR and \fBerrorCode\fR variables, if an
error occurs) is returned to the invoking interpreter.
Note that the script will be executed in the current context stack frame
of \fIslave\fR; this is so that the implementations (in a master
interpreter) of aliases in a slave interpreter can execute scripts in
the slave that find out information about the slave's current state
and stack frame.
.VS "" BR
.TP
\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR?
This command exposes the hidden command \fIhiddenName\fR, eventually bringing
it back under a new \fIexposedCmdName\fR name (this name is currently
accepted only if it is a valid global name space name without any ::),
in \fIslave\fR.
If an exposed command with the targeted name already exists, this command
fails.
For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below.
.TP
\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
This command hides the exposed command \fIexposedCmdName\fR, renaming it to
the hidden command \fIhiddenCmdName\fR, or keeping the same name if the
argument is not given, in the \fIslave\fR interpreter.
If a hidden command with the targeted name already exists, this command
fails.
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
not contain namespace qualifiers, or an error is raised.
Commands to be hidden are looked up in the global
namespace even if the current namespace is not the global one. This
prevents slaves from fooling a master interpreter into hiding the wrong
command, by making the current namespace be different from the global one.
For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below.
.TP
\fIslave \fBhidden\fR
Returns a list of the names of all hidden commands in \fIslave\fR.
.TP
\fIslave \fBinvokehidden\fR ?\fB-global\fR \fIhiddenName \fR?\fIarg ..\fR?
This command invokes the hidden command \fIhiddenName\fR with the
supplied arguments, in \fIslave\fR. No substitutions or evaluations are
applied to the arguments.
If the \fB-global\fR flag is given, the command is invoked at the global
level in the slave; otherwise it is invoked at the current call frame and
can access local variables in that or outer call frames.
For more details on hidden commands,
see \fBHIDDEN COMMANDS\fR, below.
.VE
.TP
\fIslave \fBissafe\fR
Returns \fB1\fR if the slave interpreter is safe, \fB0\fR otherwise.
.VS "" BR
.TP
\fIslave \fBmarktrusted\fR
Marks the slave interpreter as trusted. Can only be invoked by a
trusted interpreter. This command does not expose any hidden
commands in the slave interpreter. The command has no effect if the slave
is already trusted.
.VE
.TP
\fIslave\fR \fBrecursionlimit\fR ?\fInewlimit\fR?
Returns the maximum allowable nesting depth for the \fIslave\fR interpreter.
If \fInewlimit\fR is specified, the recursion limit in \fIslave\fR will be
set so that nesting of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR
and related procedures in \fIslave\fR will return an error.
The \fInewlimit\fR value is also returned.
The \fInewlimit\fR value must be a positive integer between 1 and the
maximum value of a non-long integer on the platform.
.sp
The command sets the maximum size of the Tcl call stack only. It cannot
by itself prevent stack overflows on the C stack being used by the
application. If your machine has a limit on the size of the C stack, you
may get stack overflows before reaching the limit set by the command. If
this happens, see if there is a mechanism in your system for increasing
the maximum size of the C stack.
.SH "SAFE INTERPRETERS"
.PP
A safe interpreter is one with restricted functionality, so that
is safe to execute an arbitrary script from your worst enemy without
fear of that script damaging the enclosing application or the rest
of your computing environment. In order to make an interpreter
safe, certain commands and variables are removed from the interpreter.
For example, commands to create files on disk are removed, and the
\fBexec\fR command is removed, since it could be used to cause damage
through subprocesses.
Limited access to these facilities can be provided, by creating
aliases to the master interpreter which check their arguments carefully
and provide restricted access to a safe subset of facilities.
For example, file creation might be allowed in a particular subdirectory
and subprocess invocation might be allowed for a carefully selected and
fixed set of programs.
.PP
A safe interpreter is created by specifying the \fB\-safe\fR switch
to the \fBinterp create\fR command. Furthermore, any slave created
by a safe interpreter will also be safe.
.PP
A safe interpreter is created with exactly the following set of
built-in commands:
.DS
.ta 1.2i 2.4i 3.6i
\fBafter append array binary
break case catch clock
close concat continue eof
error eval expr fblocked
fcopy fileevent flush for
foreach format gets global
if incr info interp
join lappend lindex linsert
list llength lrange lreplace
lsearch lsort namespace package
pid proc puts read
regexp regsub rename return
scan seek set split
string subst switch tell
time trace unset update
uplevel upvar variable vwait
while\fR
.DE
.VS "" BR
The following commands are hidden by \fBinterp create\fR when it
creates a safe interpreter:
.DS
.ta 1.2i 2.4i 3.6i
\fBcd encoding exec exit
fconfigure file glob load
open pwd socket source\fR
.DE
These commands can be recreated later as Tcl procedures or aliases, or
re-exposed by \fBinterp expose\fR.
.PP
The following commands from Tcl's library of support procedures are
not present in a safe interpreter:
.DS
.ta 1.6i 3.2i
\fBauto_exec_ok auto_import auto_load
auto_load_index auto_qualify unknown\fR
.DE
Note in particular that safe interpreters have no default \fBunknown\fR
command, so Tcl's default autoloading facilities are not available.
Autoload access to Tcl's commands that are normally autoloaded:
.DS
.ta 2.1i
\fB
auto_mkindex auto_mkindex_old
auto_reset history
parray pkg_mkIndex
::pkg::create ::safe::interpAddToAccessPath
::safe::interpCreate ::safe::interpConfigure
::safe::interpDelete ::safe::interpFindInAccessPath
::safe::interpInit ::safe::setLogCmd
tcl_endOfWord tcl_findLibrary
tcl_startOfNextWord tcl_startOfPreviousWord
tcl_wordBreakAfter tcl_wordBreakBefore\fR
.DE
can only be provided by explicit definition of an \fBunknown\fR command
in the safe interpreter. This will involve exposing the \fBsource\fR
command. This is most easily accomplished by creating the safe interpreter
with Tcl's \fBSafe\-Tcl\fR mechanism. \fBSafe\-Tcl\fR provides safe
versions of \fBsource\fR, \fBload\fR, and other Tcl commands needed
to support autoloading of commands and the loading of packages.
.VE
.PP
In addition, the \fBenv\fR variable is not present in a safe interpreter,
so it cannot share environment variables with other interpreters. The
\fBenv\fR variable poses a security risk, because users can store
sensitive information in an environment variable. For example, the PGP
manual recommends storing the PGP private key protection password in
the environment variable \fIPGPPASS\fR. Making this variable available
to untrusted code executing in a safe interpreter would incur a
security risk.
.PP
If extensions are loaded into a safe interpreter, they may also restrict
their own functionality to eliminate unsafe commands. For a discussion of
management of extensions for safety see the manual entries for
\fBSafe\-Tcl\fR and the \fBload\fR Tcl command.
.PP
A safe interpreter may not alter the recursion limit of any interpreter,
including itself.
.SH "ALIAS INVOCATION"
.PP
The alias mechanism has been carefully designed so that it can
be used safely when an untrusted script is executing
in a safe slave and the target of the alias is a trusted
master. The most important thing in guaranteeing safety is to
ensure that information passed from the slave to the master is
never evaluated or substituted in the master; if this were to
occur, it would enable an evil script in the slave to invoke
arbitrary functions in the master, which would compromise security.
.PP
When the source for an alias is invoked in the slave interpreter, the
usual Tcl substitutions are performed when parsing that command.
These substitutions are carried out in the source interpreter just
as they would be for any other command invoked in that interpreter.
The command procedure for the source command takes its arguments
and merges them with the \fItargetCmd\fR and \fIarg\fRs for the
alias to create a new array of arguments. If the words
of \fIsrcCmd\fR were ``\fIsrcCmd arg1 arg2 ... argN\fR'',
the new set of words will be
``\fItargetCmd arg arg ... arg arg1 arg2 ... argN\fR'',
where \fItargetCmd\fR and \fIarg\fRs are the values supplied when the
alias was created. \fITargetCmd\fR is then used to locate a command
procedure in the target interpreter, and that command procedure
is invoked with the new set of arguments. An error occurs if
there is no command named \fItargetCmd\fR in the target interpreter.
No additional substitutions are performed on the words: the
target command procedure is invoked directly, without
going through the normal Tcl evaluation mechanism.
Substitutions are thus performed on each word exactly once:
\fItargetCmd\fR and \fIargs\fR were substituted when parsing the command
that created the alias, and \fIarg1 - argN\fR are substituted when
the alias's source command is parsed in the source interpreter.
.PP
When writing the \fItargetCmd\fRs for aliases in safe interpreters,
it is very important that the arguments to that command never be
evaluated or substituted, since this would provide an escape
mechanism whereby the slave interpreter could execute arbitrary
code in the master. This in turn would compromise the security
of the system.
.VS
.SH "HIDDEN COMMANDS"
.PP
Safe interpreters greatly restrict the functionality available to Tcl
programs executing within them.
Allowing the untrusted Tcl program to have direct access to this
functionality is unsafe, because it can be used for a variety of
attacks on the environment.
However, there are times when there is a legitimate need to use the
dangerous functionality in the context of the safe interpreter. For
example, sometimes a program must be \fBsource\fRd into the interpreter.
Another example is Tk, where windows are bound to the hierarchy of windows
for a specific interpreter; some potentially dangerous functions, e.g.
window management, must be performed on these windows within the
interpreter context.
.PP
The \fBinterp\fR command provides a solution to this problem in the form of
\fIhidden commands\fR. Instead of removing the dangerous commands entirely
from a safe interpreter, these commands are hidden so they become
unavailable to Tcl scripts executing in the interpreter. However, such
hidden commands can be invoked by any trusted ancestor of the safe
interpreter, in the context of the safe interpreter, using \fBinterp
invoke\fR. Hidden commands and exposed commands reside in separate name
spaces. It is possible to define a hidden command and an exposed command by
the same name within one interpreter.
.PP
Hidden commands in a slave interpreter can be invoked in the body of
procedures called in the master during alias invocation. For example, an
alias for \fBsource\fR could be created in a slave interpreter. When it is
invoked in the slave interpreter, a procedure is called in the master
interpreter to check that the operation is allowable (e.g. it asks to
source a file that the slave interpreter is allowed to access). The
procedure then it invokes the hidden \fBsource\fR command in the slave
interpreter to actually source in the contents of the file. Note that two
commands named \fBsource\fR exist in the slave interpreter: the alias, and
the hidden command.
.PP
Because a master interpreter may invoke a hidden command as part of
handling an alias invocation, great care must be taken to avoid evaluating
any arguments passed in through the alias invocation.
Otherwise, malicious slave interpreters could cause a trusted master
interpreter to execute dangerous commands on their behalf. See the section
on \fBALIAS INVOCATION\fR for a more complete discussion of this topic.
To help avoid this problem, no substitutions or evaluations are
applied to arguments of \fBinterp invokehidden\fR.
.PP
Safe interpreters are not allowed to invoke hidden commands in themselves
or in their descendants. This prevents safe slaves from gaining access to
hidden functionality in themselves or their descendants.
.PP
The set of hidden commands in an interpreter can be manipulated by a trusted
interpreter using \fBinterp expose\fR and \fBinterp hide\fR. The \fBinterp
expose\fR command moves a hidden command to the
set of exposed commands in the interpreter identified by \fIpath\fR,
potentially renaming the command in the process. If an exposed command by
the targeted name already exists, the operation fails. Similarly,
\fBinterp hide\fR moves an exposed command to the set of hidden commands in
that interpreter. Safe interpreters are not allowed to move commands
between the set of hidden and exposed commands, in either themselves or
their descendants.
.PP
Currently, the names of hidden commands cannot contain namespace
qualifiers, and you must first rename a command in a namespace to the
global namespace before you can hide it.
Commands to be hidden by \fBinterp hide\fR are looked up in the global
namespace even if the current namespace is not the global one. This
prevents slaves from fooling a master interpreter into hiding the wrong
command, by making the current namespace be different from the global one.
.VE
.SH CREDITS
.PP
This mechanism is based on the Safe-Tcl prototype implemented
by Nathaniel Borenstein and Marshall Rose.
.SH EXAMPLES
Creating and using an alias for a command in the current interpreter:
.CS
\fBinterp alias\fR {} getIndex {} lsearch {alpha beta gamma delta}
set idx [getIndex delta]
.CE
.PP
Executing an arbitrary command in a safe interpreter where every
invokation of \fBlappend\fR is logged:
.CS
set i [\fBinterp create\fR -safe]
\fBinterp hide\fR $i lappend
\fBinterp alias\fR $i lappend {} loggedLappend $i
proc loggedLappend {i args} {
puts "logged invokation of lappend $args"
# Be extremely careful about command construction
eval [linsert $args 0 \\
\fBinterp invokehidden\fR $i lappend]
}
\fBinterp eval\fR $i $someUntrustedScript
.CE
.SH "SEE ALSO"
load(n), safe(n), Tcl_CreateSlave(3)
.SH KEYWORDS
alias, master interpreter, safe interpreter, slave interpreter
tcl8.4.20/doc/Hash.3 0000644 0036047 0045461 00000030767 11737050674 012450 0 ustar dgp 771div '\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_Hash 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
\fBTcl_InitHashTable\fR(\fItablePtr, keyType\fR)
.sp
\fBTcl_InitCustomHashTable\fR(\fItablePtr, keyType, typePtr\fR)
.sp
\fBTcl_InitObjHashTable\fR(\fItablePtr\fR)
.sp
\fBTcl_DeleteHashTable\fR(\fItablePtr\fR)
.sp
Tcl_HashEntry *
\fBTcl_CreateHashEntry\fR(\fItablePtr, key, newPtr\fR)
.sp
\fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR)
.sp
Tcl_HashEntry *
\fBTcl_FindHashEntry\fR(\fItablePtr, key\fR)
.sp
ClientData
\fBTcl_GetHashValue\fR(\fIentryPtr\fR)
.sp
\fBTcl_SetHashValue\fR(\fIentryPtr, value\fR)
.sp
char *
\fBTcl_GetHashKey\fR(\fItablePtr, entryPtr\fR)
.sp
Tcl_HashEntry *
\fBTcl_FirstHashEntry\fR(\fItablePtr, searchPtr\fR)
.sp
Tcl_HashEntry *
\fBTcl_NextHashEntry\fR(\fIsearchPtr\fR)
.sp
CONST char *
\fBTcl_HashStats\fR(\fItablePtr\fR)
.SH ARGUMENTS
.AS Tcl_HashSearch *searchPtr
.AP Tcl_HashTable *tablePtr in
Address of hash table structure (for all procedures but
\fBTcl_InitHashTable\fR, this must have been initialized by
previous call to \fBTcl_InitHashTable\fR).
.AP int keyType in
Kind of keys to use for new hash table. Must be either
TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, TCL_CUSTOM_TYPE_KEYS,
TCL_CUSTOM_PTR_KEYS, or an integer value greater than 1.
.AP Tcl_HashKeyType *typePtr in
Address of structure which defines the behaviour of the hash table.
.AP "CONST char" *key in
Key to use for probe into table. Exact form depends on
\fIkeyType\fR used to create table.
.AP int *newPtr out
The word at \fI*newPtr\fR is set to 1 if a new entry was created
and 0 if there was already an entry for \fIkey\fR.
.AP Tcl_HashEntry *entryPtr in
Pointer to hash table entry.
.AP ClientData value in
New value to assign to hash table entry. Need not have type
ClientData, but must fit in same space as ClientData.
.AP Tcl_HashSearch *searchPtr in
Pointer to record to use to keep track of progress in enumerating
all the entries in a hash table.
.BE
.SH DESCRIPTION
.PP
A hash table consists of zero or more entries, each consisting of a
key and a value. Given the key for an entry, the hashing routines can
very quickly locate the entry, and hence its value. There may be at
most one entry in a hash table with a particular key, but many entries
may have the same value. Keys can take one of four forms: strings,
one-word values, integer arrays, or custom keys defined by a
Tcl_HashKeyType structure (See section \fBTHE TCL_HASHKEYTYPE
STRUCTURE\fR below). All of the keys in a given table have the same
form, which is specified when the table is initialized.
.PP
The value of a hash table entry can be anything that fits in the same
space as a ``char *'' pointer. Values for hash table entries are
managed entirely by clients, not by the hash module itself. Typically
each entry's value is a pointer to a data structure managed by client
code.
.PP
Hash tables grow gracefully as the number of entries increases, so
that there are always less than three entries per hash bucket, on
average. This allows for fast lookups regardless of the number of
entries in a table.
.PP
The core provides three functions for the initialization of hash
tables, Tcl_InitHashTable, Tcl_InitObjHashTable and
Tcl_InitCustomHashTable.
.PP
\fBTcl_InitHashTable\fR initializes a structure that describes a new
hash table. The space for the structure is provided by the caller,
not by the hash module. The value of \fIkeyType\fR indicates what
kinds of keys will be used for all entries in the table. All of the
key types described later are allowed, with the exception of
\fBTCL_CUSTOM_TYPE_KEYS\fR and \fBTCL_CUSTOM_PTR_KEYS\fR.
.PP
\fBTcl_InitObjHashTable\fR is a wrapper around
\fBTcl_InitCustomHashTable\fR and initializes a hash table whose keys
are Tcl_Obj *.
.PP
\fBTcl_InitCustomHashTable\fR initializes a structure that describes a
new hash table. The space for the structure is provided by the
caller, not by the hash module. The value of \fIkeyType\fR indicates
what kinds of keys will be used for all entries in the table.
\fIKeyType\fR must have one of the following values:
.IP \fBTCL_STRING_KEYS\fR 25
Keys are null-terminated strings.
They are passed to hashing routines using the address of the
first character of the string.
.IP \fBTCL_ONE_WORD_KEYS\fR 25
Keys are single-word values; they are passed to hashing routines
and stored in hash table entries as ``char *'' values.
The pointer value is the key; it need not (and usually doesn't)
actually point to a string.
.IP \fBTCL_CUSTOM_TYPE_KEYS\fR 25
Keys are of arbitrary type, and are stored in the entry. Hashing
and comparison is determined by \fItypePtr\fR. The Tcl_HashKeyType
structure is described in the section
\fBTHE TCL_HASHKEYTYPE STRUCTURE\fR below.
.IP \fBTCL_CUSTOM_PTR_KEYS\fR 25
Keys are pointers to an arbitrary type, and are stored in the entry. Hashing
and comparison is determined by \fItypePtr\fR. The Tcl_HashKeyType
structure is described in the section
\fBTHE TCL_HASHKEYTYPE STRUCTURE\fR below.
.IP \fIother\fR 25
If \fIkeyType\fR is not one of the above,
then it must be an integer value greater than 1.
In this case the keys will be arrays of ``int'' values, where
\fIkeyType\fR gives the number of ints in each key.
This allows structures to be used as keys.
All keys must have the same size.
Array keys are passed into hashing functions using the address
of the first int in the array.
.PP
\fBTcl_DeleteHashTable\fR deletes all of the entries in a hash
table and frees up the memory associated with the table's
bucket array and entries.
It does not free the actual table structure (pointed to
by \fItablePtr\fR), since that memory is assumed to be managed
by the client.
\fBTcl_DeleteHashTable\fR also does not free or otherwise
manipulate the values of the hash table entries.
If the entry values point to dynamically-allocated memory, then
it is the client's responsibility to free these structures
before deleting the table.
.PP
\fBTcl_CreateHashEntry\fR locates the entry corresponding to a
particular key, creating a new entry in the table if there
wasn't already one with the given key.
If an entry already existed with the given key then \fI*newPtr\fR
is set to zero.
If a new entry was created, then \fI*newPtr\fR is set to a non-zero
value and the value of the new entry will be set to zero.
The return value from \fBTcl_CreateHashEntry\fR is a pointer to
the entry, which may be used to retrieve and modify the entry's
value or to delete the entry from the table.
.PP
\fBTcl_DeleteHashEntry\fR will remove an existing entry from a
table.
The memory associated with the entry itself will be freed, but
the client is responsible for any cleanup associated with the
entry's value, such as freeing a structure that it points to.
.PP
\fBTcl_FindHashEntry\fR is similar to \fBTcl_CreateHashEntry\fR
except that it doesn't create a new entry if the key doesn't exist;
instead, it returns NULL as result.
.PP
\fBTcl_GetHashValue\fR and \fBTcl_SetHashValue\fR are used to
read and write an entry's value, respectively.
Values are stored and retrieved as type ``ClientData'', which is
large enough to hold a pointer value. On almost all machines this is
large enough to hold an integer value too.
.PP
\fBTcl_GetHashKey\fR returns the key for a given hash table entry,
either as a pointer to a string, a one-word (``char *'') key, or
as a pointer to the first word of an array of integers, depending
on the \fIkeyType\fR used to create a hash table.
In all cases \fBTcl_GetHashKey\fR returns a result with type
``char *''.
When the key is a string or array, the result of \fBTcl_GetHashKey\fR
points to information in the table entry; this information will
remain valid until the entry is deleted or its table is deleted.
.PP
\fBTcl_FirstHashEntry\fR and \fBTcl_NextHashEntry\fR may be used
to scan all of the entries in a hash table.
A structure of type ``Tcl_HashSearch'', provided by the client,
is used to keep track of progress through the table.
\fBTcl_FirstHashEntry\fR initializes the search record and
returns the first entry in the table (or NULL if the table is
empty).
Each subsequent call to \fBTcl_NextHashEntry\fR returns the
next entry in the table or
NULL if the end of the table has been reached.
A call to \fBTcl_FirstHashEntry\fR followed by calls to
\fBTcl_NextHashEntry\fR will return each of the entries in
the table exactly once, in an arbitrary order.
It is unadvisable to modify the structure of the table, e.g.
by creating or deleting entries, while the search is in
progress.
.PP
\fBTcl_HashStats\fR returns a dynamically-allocated string with
overall information about a hash table, such as the number of
entries it contains, the number of buckets in its hash array,
and the utilization of the buckets.
It is the caller's responsibility to free the result string
by passing it to \fBckfree\fR.
.PP
The header file \fBtcl.h\fR defines the actual data structures
used to implement hash tables.
This is necessary so that clients can allocate Tcl_HashTable
structures and so that macros can be used to read and write
the values of entries.
However, users of the hashing routines should never refer directly
to any of the fields of any of the hash-related data structures;
use the procedures and macros defined here.
.SH "THE TCL_HASHKEYTYPE STRUCTURE"
.PP
Extension writers can define new hash key types by defining four
procedures, initializing a Tcl_HashKeyType structure to describe
the type, and calling \fBTcl_InitCustomHashTable\fR.
The \fBTcl_HashKeyType\fR structure is defined as follows:
.CS
typedef struct Tcl_HashKeyType {
int \fIversion\fR;
int \fIflags\fR;
Tcl_HashKeyProc *\fIhashKeyProc\fR;
Tcl_CompareHashKeysProc *\fIcompareKeysProc\fR;
Tcl_AllocHashEntryProc *\fIallocEntryProc\fR;
Tcl_FreeHashEntryProc *\fIfreeEntryProc\fR;
} Tcl_HashKeyType;
.CE
.PP
The \fIversion\fR member is the version of the table. If this
structure is extended in future then the version can be used
to distinguish between different structures. It should be set
to \fBTCL_HASH_KEY_TYPE_VERSION\fR.
.PP
The \fIflags\fR member is one or more of the following values OR'ed together:
.IP \fBTCL_HASH_KEY_RANDOMIZE_HASH\fR 25
There are some things, pointers for example which don't hash well
because they do not use the lower bits. If this flag is set then the
hash table will attempt to rectify this by randomising the bits and
then using the upper N bits as the index into the table.
.PP
The \fIhashKeyProc\fR member contains the address of a function
called to calculate a hash value for the key.
.CS
typedef unsigned int (Tcl_HashKeyProc) (
Tcl_HashTable *\fItablePtr\fR,
VOID *\fIkeyPtr\fR);
.CE
If this is NULL then \fIkeyPtr\fR is used and
\fBTCL_HASH_KEY_RANDOMIZE_HASH\fR is assumed.
.PP
The \fIcompareKeysProc\fR member contains the address of a function
called to compare two keys.
.CS
typedef int (Tcl_CompareHashKeysProc) (VOID *\fIkeyPtr\fR,
Tcl_HashEntry *\fIhPtr\fR);
.CE
If this is NULL then the \fIkeyPtr\fR pointers are compared.
If the keys don't match then the function returns 0, otherwise
it returns 1.
.PP
The \fIallocEntryProc\fR member contains the address of a function
called to allocate space for an entry and initialise the key.
.CS
typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) (
Tcl_HashTable *\fItablePtr\fR, VOID *\fIkeyPtr\fR);
.CE
If this is NULL then Tcl_Alloc is used to allocate enough space for a
Tcl_HashEntry and the key pointer is assigned to key.oneWordValue.
String keys and array keys use this function to allocate enough
space for the entry and the key in one block, rather than doing
it in two blocks. This saves space for a pointer to the key from
the entry and another memory allocation. Tcl_Obj * keys use this
function to allocate enough space for an entry and increment the
reference count on the object.
If
.PP
The \fIfreeEntryProc\fR member contains the address of a function
called to free space for an entry.
.CS
typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *\fIhPtr\fR);
.CE
If this is NULL then Tcl_Free is used to free the space for the
entry. Tcl_Obj * keys use this function to decrement the
reference count on the object.
.SH KEYWORDS
hash table, key, lookup, search, value
tcl8.4.20/doc/update.n 0000644 0036047 0045461 00000004405 11737050674 013130 0 ustar dgp 771div '\"
'\" Copyright (c) 1990-1992 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH update n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
update \- Process pending events and idle callbacks
.SH SYNOPSIS
\fBupdate\fR ?\fBidletasks\fR?
.BE
.SH DESCRIPTION
.PP
This command is used to bring the application ``up to date''
by entering the event loop repeatedly until all pending events
(including idle callbacks) have been processed.
.PP
If the \fBidletasks\fR keyword is specified as an argument to the
command, then no new events or errors are processed; only idle
callbacks are invoked.
This causes operations that are normally deferred, such as display
updates and window layout calculations, to be performed immediately.
.PP
The \fBupdate idletasks\fR command is useful in scripts where
changes have been made to the application's state and you want those
changes to appear on the display immediately, rather than waiting
for the script to complete. Most display updates are performed as
idle callbacks, so \fBupdate idletasks\fR will cause them to run.
However, there are some kinds of updates that only happen in
response to events, such as those triggered by window size changes;
these updates will not occur in \fBupdate idletasks\fR.
.PP
The \fBupdate\fR command with no options is useful in scripts where
you are performing a long-running computation but you still want
the application to respond to events such as user interactions; if
you occasionally call \fBupdate\fR then user input will be processed
during the next call to \fBupdate\fR.
.SH EXAMPLE
Run computations for about a second and then finish:
.CS
set x 1000
set done 0
after 1000 set done 1
while {!$done} {
# A very silly example!
set x [expr {log($x) ** 2.8}]
# Test to see if our time-limit has been hit. This would
# also give a chance for serving network sockets and, if
# the Tk package is loaded, updating a user interface.
\fBupdate\fR
}
.CE
.SH "SEE ALSO"
after(n), bgerror(n)
.SH KEYWORDS
event, flush, handler, idle, update
tcl8.4.20/doc/CrtFileHdlr.3 0000644 0036047 0045461 00000006723 11737050674 013722 0 ustar dgp 771div '\"
'\" Copyright (c) 1990-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.
'\"
.so man.macros
.TH Tcl_CreateFileHandler 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateFileHandler, Tcl_DeleteFileHandler \- associate procedure callbacks with files or devices (Unix only)
.SH SYNOPSIS
.nf
\fB#include \fR
.VS
.sp
\fBTcl_CreateFileHandler\fR(\fIfd, mask, proc, clientData\fR)
.sp
\fBTcl_DeleteFileHandler\fR(\fIfd\fR)
.VE
.SH ARGUMENTS
.AS Tcl_FileProc clientData
.VS
.AP int fd in
Unix file descriptor for an open file or device.
.VE
.AP int mask in
Conditions under which \fIproc\fR should be called:
OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR,
and \fBTCL_EXCEPTION\fR. May be set to 0 to temporarily disable
a handler.
.AP Tcl_FileProc *proc in
Procedure to invoke whenever the file or device indicated
by \fIfile\fR meets the conditions specified by \fImask\fR.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE
.SH DESCRIPTION
.PP
.VS
\fBTcl_CreateFileHandler\fR arranges for \fIproc\fR to be
invoked in the future whenever I/O becomes possible on a file
or an exceptional condition exists for the file. The file
is indicated by \fIfd\fR, and the conditions of interest
.VE
are indicated by \fImask\fR. For example, if \fImask\fR
is \fBTCL_READABLE\fR, \fIproc\fR will be called when
the file is readable.
The callback to \fIproc\fR is made by \fBTcl_DoOneEvent\fR, so
\fBTcl_CreateFileHandler\fR is only useful in programs that dispatch
events through \fBTcl_DoOneEvent\fR or through Tcl commands such
as \fBvwait\fR.
.PP
\fIProc\fR should have arguments and result that match the
type \fBTcl_FileProc\fR:
.CS
typedef void Tcl_FileProc(
ClientData \fIclientData\fR,
int \fImask\fR);
.CE
The \fIclientData\fR parameter to \fIproc\fR is a copy
of the \fIclientData\fR
argument given to \fBTcl_CreateFileHandler\fR when the callback
was created. Typically, \fIclientData\fR points to a data
structure containing application-specific information about
the file. \fIMask\fR is an integer mask indicating which
of the requested conditions actually exists for the file; it
will contain a subset of the bits in the \fImask\fR argument
to \fBTcl_CreateFileHandler\fR.
.PP
.PP
There may exist only one handler for a given file at a given time.
If \fBTcl_CreateFileHandler\fR is called when a handler already
exists for \fIfd\fR, then the new callback replaces the information
that was previously recorded.
.PP
\fBTcl_DeleteFileHandler\fR may be called to delete the
file handler for \fIfd\fR; if no handler exists for the
file given by \fIfd\fR then the procedure has no effect.
.PP
The purpose of file handlers is to enable an application to respond to
events while waiting for files to become ready for I/O. For this to work
correctly, the application may need to use non-blocking I/O operations on
the files for which handlers are declared. Otherwise the application may
block if it reads or writes too much data; while waiting for the I/O to
complete the application won't be able to service other events. Use
\fBTcl_SetChannelOption\fR with \fB\-blocking\fR to set the channel into
blocking or nonblocking mode as required.
.PP
.VS
Note that these interfaces are only supported by the Unix
implementation of the Tcl notifier.
.VE
.SH KEYWORDS
callback, file, handler
tcl8.4.20/doc/SubstObj.3 0000644 0036047 0045461 00000005271 11737050674 013310 0 ustar dgp 771div '\"
'\" Copyright (c) 2001 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.so man.macros
.TH Tcl_SubstObj 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SubstObj \- perform substitutions on Tcl objects
.SH SYNOPSIS
.nf
\fB#include \fR
.sp
Tcl_Obj *
\fBTcl_SubstObj\fR(\fIinterp, objPtr, flags\fR)
.SH ARGUMENTS
.AS Tcl_Interp **termPtr;
.AP Tcl_Interp *interp in
Interpreter in which to execute Tcl scripts and lookup variables. If
an error occurs, the interpreter's result is modified to hold an error
message.
.AP Tcl_Obj *objPtr in
A Tcl object containing the string to perform substitutions on.
.AP int flags in
ORed combination of flag bits that specify which substitutions to
perform. The flags \fBTCL_SUBST_COMMANDS\fR,
\fBTCL_SUBST_VARIABLES\fR and \fBTCL_SUBST_BACKSLASHES\fR are
currently supported, and \fBTCL_SUBST_ALL\fR is provided as a
convenience for the common case where all substitutions are desired.
.BE
.SH DESCRIPTION
.PP
The \fBTcl_SubstObj\fR function is used to perform substitutions on
strings in the fashion of the \fBsubst\fR command. It gets the value
of the string contained in \fIobjPtr\fR and scans it, copying
characters and performing the chosen substitutions as it goes to an
output object which is returned as the result of the function. In the
event of an error occurring during the execution of a command or
variable substitution, the function returns NULL and an error message
is left in \fIinterp\fR's result.
.PP
Three kinds of substitutions are supported. When the
\fBTCL_SUBST_BACKSLASHES\fR bit is set in \fIflags\fR, sequences that
look like backslash substitutions for Tcl commands are replaced by
their corresponding character.
.PP
When the \fBTCL_SUBST_VARIABLES\fR bit is set in \fIflags\fR,
sequences that look like variable substitutions for Tcl commands are
replaced by the contents of the named variable.
.PP
When th \fBTCL_SUBST_COMMANDS\fR bit is set in \fIflags\fR, sequences
that look like command substitutions for Tcl commands are replaced by
the result of evaluating that script. Where an uncaught continue
exception occurs during the evaluation of a command substitution, an
empty string is substituted for the command. Where an uncaught break
exception occurs during the evaluation of a command substitution, the
result of the whole substitution on \fIobjPtr\fR will be truncated at
the point immediately before the start of the command substitution,
and no characters will be added to the result or substitutions
performed after that point.
.SH "SEE ALSO"
subst(n)
.SH KEYWORDS
backslash substitution, command substitution, variable substitution
tcl8.4.20/license.terms 0000644 0036047 0045461 00000004321 11737050674 013415 0 ustar dgp 771div This software is copyrighted by the Regents of the University of
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
Corporation and other parties. The following terms apply to all files
associated with the software unless explicitly disclaimed in
individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that this
notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
and need not follow the licensing terms described here, provided that
the new terms are clearly indicated on the first page of each file where
they apply.
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.
tcl8.4.20/compat/ 0000755 0036047 0045461 00000000000 12153151142 012163 5 ustar dgp 771div tcl8.4.20/compat/strtoul.c 0000644 0036047 0045461 00000011637 11737050674 014072 0 ustar dgp 771div /*
* strtoul.c --
*
* Source code for the "strtoul" library procedure.
*
* Copyright (c) 1988 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.
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* The table below is used to convert from ASCII digits to a
* numerical equivalent. It maps from '0' through 'z' to integers
* (100 for non-digit characters).
*/
static char cvtIn[] = {
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, /* '0' - '9' */
100, 100, 100, 100, 100, 100, 100, /* punctuation */
10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'A' - 'Z' */
20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
30, 31, 32, 33, 34, 35,
100, 100, 100, 100, 100, 100, /* punctuation */
10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'a' - 'z' */
20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
30, 31, 32, 33, 34, 35};
/*
*----------------------------------------------------------------------
*
* strtoul --
*
* Convert an ASCII string into an integer.
*
* Results:
* The return value is the integer equivalent of string. If endPtr
* is non-NULL, then *endPtr is filled in with the character
* after the last one that was part of the integer. If string
* doesn't contain a valid integer value, then zero is returned
* and *endPtr is set to string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
unsigned long int
strtoul(string, endPtr, base)
CONST char *string; /* String of ASCII digits, possibly
* preceded by white space. For bases
* greater than 10, either lower- or
* upper-case digits may be used.
*/
char **endPtr; /* Where to store address of terminating
* character, or NULL. */
int base; /* Base for conversion. Must be less
* than 37. If 0, then the base is chosen
* from the leading characters of string:
* "0x" means hex, "0" means octal, anything
* else means decimal.
*/
{
register CONST char *p;
register unsigned long int result = 0;
register unsigned digit;
int anyDigits = 0;
int negative=0;
int overflow=0;
/*
* Skip any leading blanks.
*/
p = string;
while (isspace(UCHAR(*p))) {
p += 1;
}
if (*p == '-') {
negative = 1;
p += 1;
} else {
if (*p == '+') {
p += 1;
}
}
/*
* If no base was provided, pick one from the leading characters
* of the string.
*/
if (base == 0)
{
if (*p == '0') {
p += 1;
if ((*p == 'x') || (*p == 'X')) {
p += 1;
base = 16;
} else {
/*
* Must set anyDigits here, otherwise "0" produces a
* "no digits" error.
*/
anyDigits = 1;
base = 8;
}
}
else base = 10;
} else if (base == 16) {
/*
* Skip a leading "0x" from hex numbers.
*/
if ((p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) {
p += 2;
}
}
/*
* Sorry this code is so messy, but speed seems important. Do
* different things for base 8, 10, 16, and other.
*/
if (base == 8) {
unsigned long maxres = ULONG_MAX >> 3;
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > 7) {
break;
}
if (result > maxres) { overflow = 1; }
result = (result << 3);
if (digit > (ULONG_MAX - result)) { overflow = 1; }
result += digit;
anyDigits = 1;
}
} else if (base == 10) {
unsigned long maxres = ULONG_MAX / 10;
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > 9) {
break;
}
if (result > maxres) { overflow = 1; }
result *= 10;
if (digit > (ULONG_MAX - result)) { overflow = 1; }
result += digit;
anyDigits = 1;
}
} else if (base == 16) {
unsigned long maxres = ULONG_MAX >> 4;
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > ('z' - '0')) {
break;
}
digit = cvtIn[digit];
if (digit > 15) {
break;
}
if (result > maxres) { overflow = 1; }
result = (result << 4);
if (digit > (ULONG_MAX - result)) { overflow = 1; }
result += digit;
anyDigits = 1;
}
} else if ( base >= 2 && base <= 36 ) {
unsigned long maxres = ULONG_MAX / base;
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > ('z' - '0')) {
break;
}
digit = cvtIn[digit];
if (digit >= ( (unsigned) base )) {
break;
}
if (result > maxres) { overflow = 1; }
result *= base;
if (digit > (ULONG_MAX - result)) { overflow = 1; }
result += digit;
anyDigits = 1;
}
}
/*
* See if there were any digits at all.
*/
if (!anyDigits) {
p = string;
}
if (endPtr != 0) {
/* unsafe, but required by the strtoul prototype */
*endPtr = (char *) p;
}
if (overflow) {
errno = ERANGE;
return ULONG_MAX;
}
if (negative) {
return -result;
}
return result;
}
tcl8.4.20/compat/tmpnam.c 0000644 0036047 0045461 00000001725 11737050674 013647 0 ustar dgp 771div /*
* Copyright (c) 1988 Regents of the University of California.
* All rights reserved.
*
* Redistribution and use in source and binary forms are permitted
* provided that this notice is preserved and that due credit is given
* to the University of California at Berkeley. The name of the University
* may not be used to endorse or promote products derived from this
* software without specific written prior permission. This software
* is provided ``as is'' without express or implied warranty.
*/
#include
#include
#include
#include
/*
* Use /tmp instead of /usr/tmp, because L_tmpname is only 14 chars
* on some machines (like NeXT machines) and /usr/tmp will cause
* buffer overflows.
*/
#ifdef P_tmpdir
# undef P_tmpdir
#endif
#define P_tmpdir "/tmp"
char *
tmpnam(s)
char *s;
{
static char name[50];
char *mktemp();
if (!s)
s = name;
(void)sprintf(s, "%s/XXXXXX", P_tmpdir);
return(mktemp(s));
}
tcl8.4.20/compat/fixstrtod.c 0000644 0036047 0045461 00000001501 11737050674 014371 0 ustar dgp 771div /*
* fixstrtod.c --
*
* Source code for the "fixstrtod" procedure. This procedure is
* used in place of strtod under Solaris 2.4, in order to fix
* a bug where the "end" pointer gets set incorrectly.
*
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include
#undef strtod
/*
* Declare strtod explicitly rather than including stdlib.h, since in
* somes systems (e.g. SunOS 4.1.4) stdlib.h doesn't declare strtod.
*/
extern double strtod();
double
fixstrtod(string, endPtr)
char *string;
char **endPtr;
{
double d;
d = strtod(string, endPtr);
if ((endPtr != NULL) && (*endPtr != string) && ((*endPtr)[-1] == 0)) {
*endPtr -= 1;
}
return d;
}
tcl8.4.20/compat/tclErrno.h 0000644 0036047 0045461 00000010651 11737050674 014146 0 ustar dgp 771div /*
* tclErrno.h --
*
* This header file contains the various POSIX errno definitions that
* are used by Tcl. This file is derived from the spec POSIX 2.4 and
* previous implementations for Berkeley UNIX.
*
* Copyright (c) 1982, 1986, 1989 Regents of the University of California.
* 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.
*/
extern int errno; /* global error number */
#define EPERM 1 /* Operation not permitted */
#define ENOENT 2 /* No such file or directory */
#define ESRCH 3 /* No such process */
#define EINTR 4 /* Interrupted system call */
#define EIO 5 /* Input/output error */
#define ENXIO 6 /* Device not configured */
#define E2BIG 7 /* Argument list too long */
#define ENOEXEC 8 /* Exec format error */
#define EBADF 9 /* Bad file descriptor */
#define ECHILD 10 /* No child processes */
#define EDEADLK 11 /* Resource deadlock avoided */
/* 11 was EAGAIN */
#define ENOMEM 12 /* Cannot allocate memory */
#define EACCES 13 /* Permission denied */
#define EFAULT 14 /* Bad address */
#define ENOTBLK 15 /* Block device required */
#define EBUSY 16 /* Device busy */
#define EEXIST 17 /* File exists */
#define EXDEV 18 /* Cross-device link */
#define ENODEV 19 /* Operation not supported by device */
#define ENOTDIR 20 /* Not a directory */
#define EISDIR 21 /* Is a directory */
#define EINVAL 22 /* Invalid argument */
#define ENFILE 23 /* Too many open files in system */
#define EMFILE 24 /* Too many open files */
#define ENOTTY 25 /* Inappropriate ioctl for device */
#define ETXTBSY 26 /* Text file busy */
#define EFBIG 27 /* File too large */
#define ENOSPC 28 /* No space left on device */
#define ESPIPE 29 /* Illegal seek */
#define EROFS 30 /* Read-only file system */
#define EMLINK 31 /* Too many links */
#define EPIPE 32 /* Broken pipe */
#define EDOM 33 /* Numerical argument out of domain */
#define ERANGE 34 /* Result too large */
#define EAGAIN 35 /* Resource temporarily unavailable */
#define EWOULDBLOCK EAGAIN /* Operation would block */
#define EINPROGRESS 36 /* Operation now in progress */
#define EALREADY 37 /* Operation already in progress */
#define ENOTSOCK 38 /* Socket operation on non-socket */
#define EDESTADDRREQ 39 /* Destination address required */
#define EMSGSIZE 40 /* Message too long */
#define EPROTOTYPE 41 /* Protocol wrong type for socket */
#define ENOPROTOOPT 42 /* Protocol not available */
#define EPROTONOSUPPORT 43 /* Protocol not supported */
#define ESOCKTNOSUPPORT 44 /* Socket type not supported */
#define EOPNOTSUPP 45 /* Operation not supported on socket */
#define EPFNOSUPPORT 46 /* Protocol family not supported */
#define EAFNOSUPPORT 47 /* Address family not supported by protocol family */
#define EADDRINUSE 48 /* Address already in use */
#define EADDRNOTAVAIL 49 /* Can't assign requested address */
#define ENETDOWN 50 /* Network is down */
#define ENETUNREACH 51 /* Network is unreachable */
#define ENETRESET 52 /* Network dropped connection on reset */
#define ECONNABORTED 53 /* Software caused connection abort */
#define ECONNRESET 54 /* Connection reset by peer */
#define ENOBUFS 55 /* No buffer space available */
#define EISCONN 56 /* Socket is already connected */
#define ENOTCONN 57 /* Socket is not connected */
#define ESHUTDOWN 58 /* Can't send after socket shutdown */
#define ETOOMANYREFS 59 /* Too many references: can't splice */
#define ETIMEDOUT 60 /* Connection timed out */
#define ECONNREFUSED 61 /* Connection refused */
#define ELOOP 62 /* Too many levels of symbolic links */
#define ENAMETOOLONG 63 /* File name too long */
#define EHOSTDOWN 64 /* Host is down */
#define EHOSTUNREACH 65 /* No route to host */
#define ENOTEMPTY 66 /* Directory not empty */
#define EPROCLIM 67 /* Too many processes */
#define EUSERS 68 /* Too many users */
#define EDQUOT 69 /* Disc quota exceeded */
#define ESTALE 70 /* Stale NFS file handle */
#define EREMOTE 71 /* Too many levels of remote in path */
#define EBADRPC 72 /* RPC struct is bad */
#define ERPCMISMATCH 73 /* RPC version wrong */
#define EPROGUNAVAIL 74 /* RPC prog. not avail */
#define EPROGMISMATCH 75 /* Program version wrong */
#define EPROCUNAVAIL 76 /* Bad procedure for program */
#define ENOLCK 77 /* No locks available */
#define ENOSYS 78 /* Function not implemented */
#define EOVERFLOW 79 /* Value too large to be stored in data type */
tcl8.4.20/compat/strtod.c 0000644 0036047 0045461 00000013351 11737050674 013670 0 ustar dgp 771div /*
* strtod.c --
*
* Source code for the "strtod" library procedure.
*
* Copyright (c) 1988-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.
*/
#include "tclInt.h"
#include "tclPort.h"
#include
#ifndef TRUE
#define TRUE 1
#define FALSE 0
#endif
#ifndef NULL
#define NULL 0
#endif
static int maxExponent = 511; /* Largest possible base 10 exponent. Any
* exponent larger than this will already
* produce underflow or overflow, so there's
* no need to worry about additional digits.
*/
static double powersOf10[] = { /* Table giving binary powers of 10. Entry */
10., /* is 10^2^i. Used to convert decimal */
100., /* exponents into floating-point numbers. */
1.0e4,
1.0e8,
1.0e16,
1.0e32,
1.0e64,
1.0e128,
1.0e256
};
/*
*----------------------------------------------------------------------
*
* strtod --
*
* This procedure converts a floating-point number from an ASCII
* decimal representation to internal double-precision format.
*
* Results:
* The return value is the double-precision floating-point
* representation of the characters in string. If endPtr isn't
* NULL, then *endPtr is filled in with the address of the
* next character after the last one that was part of the
* floating-point number.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
double
strtod(string, endPtr)
CONST char *string; /* A decimal ASCII floating-point number,
* optionally preceded by white space.
* Must have form "-I.FE-X", where I is the
* integer part of the mantissa, F is the
* fractional part of the mantissa, and X
* is the exponent. Either of the signs
* may be "+", "-", or omitted. Either I
* or F may be omitted, or both. The decimal
* point isn't necessary unless F is present.
* The "E" may actually be an "e". E and X
* may both be omitted (but not just one).
*/
char **endPtr; /* If non-NULL, store terminating character's
* address here. */
{
int sign, expSign = FALSE;
double fraction, dblExp, *d;
register CONST char *p;
register int c;
int exp = 0; /* Exponent read from "EX" field. */
int fracExp = 0; /* Exponent that derives from the fractional
* part. Under normal circumstatnces, it is
* the negative of the number of digits in F.
* However, if I is very long, the last digits
* of I get dropped (otherwise a long I with a
* large negative exponent could cause an
* unnecessary overflow on I alone). In this
* case, fracExp is incremented one for each
* dropped digit. */
int mantSize; /* Number of digits in mantissa. */
int decPt; /* Number of mantissa digits BEFORE decimal
* point. */
CONST char *pExp; /* Temporarily holds location of exponent
* in string. */
/*
* Strip off leading blanks and check for a sign.
*/
p = string;
while (isspace(UCHAR(*p))) {
p += 1;
}
if (*p == '-') {
sign = TRUE;
p += 1;
} else {
if (*p == '+') {
p += 1;
}
sign = FALSE;
}
/*
* Count the number of digits in the mantissa (including the decimal
* point), and also locate the decimal point.
*/
decPt = -1;
for (mantSize = 0; ; mantSize += 1)
{
c = *p;
if (!isdigit(c)) {
if ((c != '.') || (decPt >= 0)) {
break;
}
decPt = mantSize;
}
p += 1;
}
/*
* Now suck up the digits in the mantissa. Use two integers to
* collect 9 digits each (this is faster than using floating-point).
* If the mantissa has more than 18 digits, ignore the extras, since
* they can't affect the value anyway.
*/
pExp = p;
p -= mantSize;
if (decPt < 0) {
decPt = mantSize;
} else {
mantSize -= 1; /* One of the digits was the point. */
}
if (mantSize > 18) {
fracExp = decPt - 18;
mantSize = 18;
} else {
fracExp = decPt - mantSize;
}
if (mantSize == 0) {
fraction = 0.0;
p = string;
goto done;
} else {
int frac1, frac2;
frac1 = 0;
for ( ; mantSize > 9; mantSize -= 1)
{
c = *p;
p += 1;
if (c == '.') {
c = *p;
p += 1;
}
frac1 = 10*frac1 + (c - '0');
}
frac2 = 0;
for (; mantSize > 0; mantSize -= 1)
{
c = *p;
p += 1;
if (c == '.') {
c = *p;
p += 1;
}
frac2 = 10*frac2 + (c - '0');
}
fraction = (1.0e9 * frac1) + frac2;
}
/*
* Skim off the exponent.
*/
p = pExp;
if ((*p == 'E') || (*p == 'e')) {
p += 1;
if (*p == '-') {
expSign = TRUE;
p += 1;
} else {
if (*p == '+') {
p += 1;
}
expSign = FALSE;
}
if (!isdigit(UCHAR(*p))) {
p = pExp;
goto done;
}
while (isdigit(UCHAR(*p))) {
exp = exp * 10 + (*p - '0');
p += 1;
}
}
if (expSign) {
exp = fracExp - exp;
} else {
exp = fracExp + exp;
}
/*
* Generate a floating-point number that represents the exponent.
* Do this by processing the exponent one bit at a time to combine
* many powers of 2 of 10. Then combine the exponent with the
* fraction.
*/
if (exp < 0) {
expSign = TRUE;
exp = -exp;
} else {
expSign = FALSE;
}
if (exp > maxExponent) {
exp = maxExponent;
errno = ERANGE;
}
dblExp = 1.0;
for (d = powersOf10; exp != 0; exp >>= 1, d += 1) {
if (exp & 01) {
dblExp *= *d;
}
}
if (expSign) {
fraction /= dblExp;
} else {
fraction *= dblExp;
}
done:
if (endPtr != NULL) {
*endPtr = (char *) p;
}
if (sign) {
return -fraction;
}
return fraction;
}
tcl8.4.20/compat/opendir.c 0000644 0036047 0045461 00000003674 11737050674 014020 0 ustar dgp 771div /*
* opendir.c --
*
* This file provides dirent-style directory-reading procedures
* for V7 Unix systems that don't have such procedures. The
* origin of this code is unclear, but it seems to have come
* originally from Larry Wall.
*/
#include "tclInt.h"
#include "tclPort.h"
#undef DIRSIZ
#define DIRSIZ(dp) \
((sizeof (struct dirent) - (MAXNAMLEN+1)) + (((dp)->d_namlen+1 + 3) &~ 3))
/*
* open a directory.
*/
DIR *
opendir(name)
char *name;
{
register DIR *dirp;
register int fd;
char *myname;
myname = ((*name == '\0') ? "." : name);
if ((fd = open(myname, 0, 0)) == -1)
return NULL;
if ((dirp = (DIR *)ckalloc(sizeof(DIR))) == NULL) {
close (fd);
return NULL;
}
dirp->dd_fd = fd;
dirp->dd_loc = 0;
return dirp;
}
/*
* read an old style directory entry and present it as a new one
*/
#ifndef pyr
#define ODIRSIZ 14
struct olddirect {
ino_t od_ino;
char od_name[ODIRSIZ];
};
#else /* a Pyramid in the ATT universe */
#define ODIRSIZ 248
struct olddirect {
long od_ino;
short od_fill1, od_fill2;
char od_name[ODIRSIZ];
};
#endif
/*
* get next entry in a directory.
*/
struct dirent *
readdir(dirp)
register DIR *dirp;
{
register struct olddirect *dp;
static struct dirent dir;
for (;;) {
if (dirp->dd_loc == 0) {
dirp->dd_size = read(dirp->dd_fd, dirp->dd_buf,
DIRBLKSIZ);
if (dirp->dd_size <= 0)
return NULL;
}
if (dirp->dd_loc >= dirp->dd_size) {
dirp->dd_loc = 0;
continue;
}
dp = (struct olddirect *)(dirp->dd_buf + dirp->dd_loc);
dirp->dd_loc += sizeof(struct olddirect);
if (dp->od_ino == 0)
continue;
dir.d_ino = dp->od_ino;
strncpy(dir.d_name, dp->od_name, ODIRSIZ);
dir.d_name[ODIRSIZ] = '\0'; /* insure null termination */
dir.d_namlen = strlen(dir.d_name);
dir.d_reclen = DIRSIZ(&dir);
return (&dir);
}
}
/*
* close a directory.
*/
void
closedir(dirp)
register DIR *dirp;
{
close(dirp->dd_fd);
dirp->dd_fd = -1;
dirp->dd_loc = 0;
ckfree((char *) dirp);
}
tcl8.4.20/compat/dlfcn.h 0000644 0036047 0045461 00000003264 11737050674 013446 0 ustar dgp 771div /*
* dlfcn.h --
*
* This file provides a replacement for the header file "dlfcn.h"
* on systems where dlfcn.h is missing. It's primary use is for
* AIX, where Tcl emulates the dl library.
*
* This file is subject to the following copyright notice, which is
* different from the notice used elsewhere in Tcl but rougly
* equivalent in meaning.
*
* Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH
* Not derived from licensed software.
*
* Permission is granted to freely use, copy, modify, and redistribute
* this software, provided that the author is not construed to be liable
* for any results of using the software, alterations are clearly marked
* as such, and this notice is not modified.
*/
/*
* @(#)dlfcn.h 1.4 revision of 95/04/25 09:36:52
* This is an unpublished work copyright (c) 1992 HELIOS Software GmbH
* 30159 Hannover, Germany
*/
#ifndef __dlfcn_h__
#define __dlfcn_h__
#ifndef _TCL
#include
#endif
#ifdef __cplusplus
extern "C" {
#endif
/*
* Mode flags for the dlopen routine.
*/
#define RTLD_LAZY 1 /* lazy function call binding */
#define RTLD_NOW 2 /* immediate function call binding */
#define RTLD_GLOBAL 0x100 /* allow symbols to be global */
/*
* To be able to intialize, a library may provide a dl_info structure
* that contains functions to be called to initialize and terminate.
*/
struct dl_info {
void (*init) _ANSI_ARGS_((void));
void (*fini) _ANSI_ARGS_((void));
};
VOID *dlopen _ANSI_ARGS_((const char *path, int mode));
VOID *dlsym _ANSI_ARGS_((void *handle, const char *symbol));
char *dlerror _ANSI_ARGS_((void));
int dlclose _ANSI_ARGS_((void *handle));
#ifdef __cplusplus
}
#endif
#endif /* __dlfcn_h__ */
tcl8.4.20/compat/memcmp.c 0000644 0036047 0045461 00000002647 11737050674 013635 0 ustar dgp 771div /*
* memcmp.c --
*
* Source code for the "memcmp" library routine.
*
* Copyright (c) 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.
*/
#include "tcl.h"
#include "tclPort.h"
/*
* Here is the prototype just in case it is not included
* in tclPort.h.
*/
int memcmp _ANSI_ARGS_((CONST VOID *s1,
CONST VOID *s2, size_t n));
/*
*----------------------------------------------------------------------
*
* memcmp --
*
* Compares two bytes sequences.
*
* Results:
* compares its arguments, looking at the first n
* bytes (each interpreted as an unsigned char), and returns
* an integer less than, equal to, or greater than 0, accord-
* ing as s1 is less than, equal to, or
* greater than s2 when taken to be unsigned 8 bit numbers.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
memcmp(s1, s2, n)
CONST VOID *s1; /* First string. */
CONST VOID *s2; /* Second string. */
size_t n; /* Length to compare. */
{
CONST unsigned char *ptr1 = (CONST unsigned char *) s1;
CONST unsigned char *ptr2 = (CONST unsigned char *) s2;
for ( ; n-- ; ptr1++, ptr2++) {
unsigned char u1 = *ptr1, u2 = *ptr2;
if ( u1 != u2) {
return (u1-u2);
}
}
return 0;
}
tcl8.4.20/compat/gettod.c 0000644 0036047 0045461 00000001102 11737050674 013626 0 ustar dgp 771div /*
* gettod.c --
*
* This file provides the gettimeofday function on systems
* that only have the System V ftime function.
*
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tcl.h"
#include "tclPort.h"
#include
#undef timezone
int
gettimeofday(tp, tz)
struct timeval *tp;
struct timezone *tz;
{
struct timeb t;
ftime(&t);
tp->tv_sec = t.time;
tp->tv_usec = t. millitm * 1000;
return 0;
}
tcl8.4.20/compat/dirent2.h 0000644 0036047 0045461 00000002506 11737050674 013725 0 ustar dgp 771div /*
* dirent.h --
*
* Declarations of a library of directory-reading procedures
* in the POSIX style ("struct dirent").
*
* Copyright (c) 1991 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.
*/
#ifndef _DIRENT
#define _DIRENT
#ifndef _TCL
#include
#endif
/*
* Dirent structure, which holds information about a single
* directory entry.
*/
#define MAXNAMLEN 255
#define DIRBLKSIZ 512
struct dirent {
long d_ino; /* Inode number of entry */
short d_reclen; /* Length of this record */
short d_namlen; /* Length of string in d_name */
char d_name[MAXNAMLEN + 1]; /* Name must be no longer than this */
};
/*
* State that keeps track of the reading of a directory (clients
* should never look inside this structure; the fields should
* only be accessed by the library procedures).
*/
typedef struct _dirdesc {
int dd_fd;
long dd_loc;
long dd_size;
char dd_buf[DIRBLKSIZ];
} DIR;
/*
* Procedures defined for reading directories:
*/
extern void closedir _ANSI_ARGS_((DIR *dirp));
extern DIR * opendir _ANSI_ARGS_((char *name));
extern struct dirent * readdir _ANSI_ARGS_((DIR *dirp));
#endif /* _DIRENT */
tcl8.4.20/compat/strtoll.c 0000644 0036047 0045461 00000005021 11737050674 014047 0 ustar dgp 771div /*
* strtoll.c --
*
* Source code for the "strtoll" library procedure.
*
* Copyright (c) 1988 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.
*/
#include "tcl.h"
#include "tclPort.h"
#include
#define TCL_WIDEINT_MAX (((Tcl_WideUInt)Tcl_LongAsWide(-1))>>1)
/*
*----------------------------------------------------------------------
*
* strtoll --
*
* Convert an ASCII string into an integer.
*
* Results:
* The return value is the integer equivalent of string. If endPtr
* is non-NULL, then *endPtr is filled in with the character
* after the last one that was part of the integer. If string
* doesn't contain a valid integer value, then zero is returned
* and *endPtr is set to string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#if TCL_WIDE_INT_IS_LONG
long long
#else
Tcl_WideInt
#endif
strtoll(string, endPtr, base)
CONST char *string; /* String of ASCII digits, possibly
* preceded by white space. For bases
* greater than 10, either lower- or
* upper-case digits may be used.
*/
char **endPtr; /* Where to store address of terminating
* character, or NULL. */
int base; /* Base for conversion. Must be less
* than 37. If 0, then the base is chosen
* from the leading characters of string:
* "0x" means hex, "0" means octal, anything
* else means decimal.
*/
{
register CONST char *p;
Tcl_WideInt result = Tcl_LongAsWide(0);
Tcl_WideUInt uwResult;
/*
* Skip any leading blanks.
*/
p = string;
while (isspace(UCHAR(*p))) {
p += 1;
}
/*
* Check for a sign.
*/
errno = 0;
if (*p == '-') {
p += 1;
uwResult = strtoull(p, endPtr, base);
if (errno != ERANGE) {
if (uwResult > TCL_WIDEINT_MAX+1) {
errno = ERANGE;
return Tcl_LongAsWide(-1);
} else if (uwResult > TCL_WIDEINT_MAX) {
return ~((Tcl_WideInt)TCL_WIDEINT_MAX);
} else {
result = -((Tcl_WideInt) uwResult);
}
}
} else {
if (*p == '+') {
p += 1;
}
uwResult = strtoull(p, endPtr, base);
if (errno != ERANGE) {
if (uwResult > TCL_WIDEINT_MAX) {
errno = ERANGE;
return Tcl_LongAsWide(-1);
} else {
result = uwResult;
}
}
}
if ((result == 0) && (endPtr != 0) && (*endPtr == p)) {
*endPtr = (char *) string;
}
return result;
}
tcl8.4.20/compat/license.terms 0000644 0036047 0045461 00000004321 11737050674 014700 0 ustar dgp 771div This software is copyrighted by the Regents of the University of
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
Corporation and other parties. The following terms apply to all files
associated with the software unless explicitly disclaimed in
individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that this
notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
and need not follow the licensing terms described here, provided that
the new terms are clearly indicated on the first page of each file where
they apply.
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.
tcl8.4.20/compat/stdlib.h 0000644 0036047 0045461 00000003202 11737050674 013631 0 ustar dgp 771div /*
* stdlib.h --
*
* Declares facilities exported by the "stdlib" portion of
* the C library. This file isn't complete in the ANSI-C
* sense; it only declares things that are needed by Tcl.
* This file is needed even on many systems with their own
* stdlib.h (e.g. SunOS) because not all stdlib.h files
* declare all the procedures needed here (such as strtod).
*
* Copyright (c) 1991 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.
*/
#ifndef _STDLIB
#define _STDLIB
#include
extern void abort _ANSI_ARGS_((void));
extern double atof _ANSI_ARGS_((CONST char *string));
extern int atoi _ANSI_ARGS_((CONST char *string));
extern long atol _ANSI_ARGS_((CONST char *string));
extern char * calloc _ANSI_ARGS_((unsigned int numElements,
unsigned int size));
extern void exit _ANSI_ARGS_((int status));
extern int free _ANSI_ARGS_((char *blockPtr));
extern char * getenv _ANSI_ARGS_((CONST char *name));
extern char * malloc _ANSI_ARGS_((unsigned int numBytes));
extern void qsort _ANSI_ARGS_((VOID *base, int n, int size,
int (*compar)(CONST VOID *element1, CONST VOID
*element2)));
extern char * realloc _ANSI_ARGS_((char *ptr, unsigned int numBytes));
extern double strtod _ANSI_ARGS_((CONST char *string, char **endPtr));
extern long strtol _ANSI_ARGS_((CONST char *string, char **endPtr,
int base));
extern unsigned long strtoul _ANSI_ARGS_((CONST char *string,
char **endPtr, int base));
#endif /* _STDLIB */
tcl8.4.20/compat/strstr.c 0000644 0036047 0045461 00000003102 11737050674 013703 0 ustar dgp 771div /*
* strstr.c --
*
* Source code for the "strstr" library routine.
*
* Copyright (c) 1988-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.
*/
#include
#ifndef NULL
#define NULL 0
#endif
/*
*----------------------------------------------------------------------
*
* strstr --
*
* Locate the first instance of a substring in a string.
*
* Results:
* If string contains substring, the return value is the
* location of the first matching instance of substring
* in string. If string doesn't contain substring, the
* return value is 0. Matching is done on an exact
* character-for-character basis with no wildcards or special
* characters.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
strstr(string, substring)
register char *string; /* String to search. */
char *substring; /* Substring to try to find in string. */
{
register char *a, *b;
/* First scan quickly through the two strings looking for a
* single-character match. When it's found, then compare the
* rest of the substring.
*/
b = substring;
if (*b == 0) {
return string;
}
for ( ; *string != 0; string += 1) {
if (*string != *b) {
continue;
}
a = string;
while (1) {
if (*b == 0) {
return string;
}
if (*a++ != *b++) {
break;
}
}
b = substring;
}
return NULL;
}
tcl8.4.20/compat/strtoull.c 0000644 0036047 0045461 00000012451 11737050674 014241 0 ustar dgp 771div /*
* strtoull.c --
*
* Source code for the "strtoull" library procedure.
*
* Copyright (c) 1988 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.
*/
#include "tcl.h"
#include "tclPort.h"
#include
/*
* The table below is used to convert from ASCII digits to a
* numerical equivalent. It maps from '0' through 'z' to integers
* (100 for non-digit characters).
*/
static char cvtIn[] = {
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, /* '0' - '9' */
100, 100, 100, 100, 100, 100, 100, /* punctuation */
10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'A' - 'Z' */
20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
30, 31, 32, 33, 34, 35,
100, 100, 100, 100, 100, 100, /* punctuation */
10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'a' - 'z' */
20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
30, 31, 32, 33, 34, 35};
/*
*----------------------------------------------------------------------
*
* strtoull --
*
* Convert an ASCII string into an integer.
*
* Results:
* The return value is the integer equivalent of string. If endPtr
* is non-NULL, then *endPtr is filled in with the character
* after the last one that was part of the integer. If string
* doesn't contain a valid integer value, then zero is returned
* and *endPtr is set to string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#if TCL_WIDE_INT_IS_LONG
unsigned long long
#else
Tcl_WideUInt
#endif
strtoull(string, endPtr, base)
CONST char *string; /* String of ASCII digits, possibly
* preceded by white space. For bases
* greater than 10, either lower- or
* upper-case digits may be used.
*/
char **endPtr; /* Where to store address of terminating
* character, or NULL. */
int base; /* Base for conversion. Must be less
* than 37. If 0, then the base is chosen
* from the leading characters of string:
* "0x" means hex, "0" means octal, anything
* else means decimal.
*/
{
register CONST char *p;
register Tcl_WideUInt result = 0;
register unsigned digit;
register Tcl_WideUInt shifted;
int anyDigits = 0, negative = 0;
/*
* Skip any leading blanks.
*/
p = string;
while (isspace(UCHAR(*p))) { /* INTL: locale-dependent */
p += 1;
}
/*
* Check for a sign.
*/
if (*p == '-') {
p += 1;
negative = 1;
} else {
if (*p == '+') {
p += 1;
}
}
/*
* If no base was provided, pick one from the leading characters
* of the string.
*/
if (base == 0) {
if (*p == '0') {
p += 1;
if (*p == 'x' || *p == 'X') {
p += 1;
base = 16;
} else {
/*
* Must set anyDigits here, otherwise "0" produces a
* "no digits" error.
*/
anyDigits = 1;
base = 8;
}
} else {
base = 10;
}
} else if (base == 16) {
/*
* Skip a leading "0x" from hex numbers.
*/
if ((p[0] == '0') && (p[1] == 'x' || *p == 'X')) {
p += 2;
}
}
/*
* Sorry this code is so messy, but speed seems important. Do
* different things for base 8, 10, 16, and other.
*/
if (base == 8) {
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > 7) {
break;
}
shifted = result << 3;
if ((shifted >> 3) != result) {
goto overflow;
}
result = shifted + digit;
if ( result < shifted ) {
goto overflow;
}
anyDigits = 1;
}
} else if (base == 10) {
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > 9) {
break;
}
shifted = 10 * result;
if ((shifted / 10) != result) {
goto overflow;
}
result = shifted + digit;
if ( result < shifted ) {
goto overflow;
}
anyDigits = 1;
}
} else if (base == 16) {
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > ('z' - '0')) {
break;
}
digit = cvtIn[digit];
if (digit > 15) {
break;
}
shifted = result << 4;
if ((shifted >> 4) != result) {
goto overflow;
}
result = shifted + digit;
if ( result < shifted ) {
goto overflow;
}
anyDigits = 1;
}
} else if ( base >= 2 && base <= 36 ) {
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > ('z' - '0')) {
break;
}
digit = cvtIn[digit];
if (digit >= (unsigned) base) {
break;
}
shifted = result * base;
if ((shifted/base) != result) {
goto overflow;
}
result = shifted + digit;
if ( result < shifted ) {
goto overflow;
}
anyDigits = 1;
}
}
/*
* Negate if we found a '-' earlier.
*/
if (negative) {
result = (Tcl_WideUInt)(-((Tcl_WideInt)result));
}
/*
* See if there were any digits at all.
*/
if (!anyDigits) {
p = string;
}
if (endPtr != 0) {
*endPtr = (char *) p;
}
return result;
/*
* On overflow generate the right output
*/
overflow:
errno = ERANGE;
if (endPtr != 0) {
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > ('z' - '0')) {
break;
}
digit = cvtIn[digit];
if (digit >= (unsigned) base) {
break;
}
}
*endPtr = (char *) p;
}
return (Tcl_WideUInt)Tcl_LongAsWide(-1);
}
tcl8.4.20/compat/unistd.h 0000644 0036047 0045461 00000006247 11737050674 013672 0 ustar dgp 771div /*
* unistd.h --
*
* Macros, CONSTants and prototypes for Posix conformance.
*
* Copyright 1989 Regents of the University of California
* Permission to use, copy, modify, and distribute this
* software and its documentation for any purpose and without
* fee is hereby granted, provided that the above copyright
* notice appear in all copies. The University of California
* makes no representations about the suitability of this
* software for any purpose. It is provided "as is" without
* express or implied warranty.
*/
#ifndef _UNISTD
#define _UNISTD
#include
#ifndef _TCL
# include "tcl.h"
#endif
#ifndef NULL
#define NULL 0
#endif
/*
* Strict POSIX stuff goes here. Extensions go down below, in the
* ifndef _POSIX_SOURCE section.
*/
extern void _exit _ANSI_ARGS_((int status));
extern int access _ANSI_ARGS_((CONST char *path, int mode));
extern int chdir _ANSI_ARGS_((CONST char *path));
extern int chown _ANSI_ARGS_((CONST char *path, uid_t owner, gid_t group));
extern int close _ANSI_ARGS_((int fd));
extern int dup _ANSI_ARGS_((int oldfd));
extern int dup2 _ANSI_ARGS_((int oldfd, int newfd));
extern int execl _ANSI_ARGS_((CONST char *path, ...));
extern int execle _ANSI_ARGS_((CONST char *path, ...));
extern int execlp _ANSI_ARGS_((CONST char *file, ...));
extern int execv _ANSI_ARGS_((CONST char *path, char **argv));
extern int execve _ANSI_ARGS_((CONST char *path, char **argv, char **envp));
extern int execvp _ANSI_ARGS_((CONST char *file, char **argv));
extern pid_t fork _ANSI_ARGS_((void));
extern char *getcwd _ANSI_ARGS_((char *buf, size_t size));
extern gid_t getegid _ANSI_ARGS_((void));
extern uid_t geteuid _ANSI_ARGS_((void));
extern gid_t getgid _ANSI_ARGS_((void));
extern int getgroups _ANSI_ARGS_((int bufSize, int *buffer));
extern pid_t getpid _ANSI_ARGS_((void));
extern uid_t getuid _ANSI_ARGS_((void));
extern int isatty _ANSI_ARGS_((int fd));
extern long lseek _ANSI_ARGS_((int fd, long offset, int whence));
extern int pipe _ANSI_ARGS_((int *fildes));
extern int read _ANSI_ARGS_((int fd, char *buf, size_t size));
extern int setgid _ANSI_ARGS_((gid_t group));
extern int setuid _ANSI_ARGS_((uid_t user));
extern unsigned sleep _ANSI_ARGS_ ((unsigned seconds));
extern char *ttyname _ANSI_ARGS_((int fd));
extern int unlink _ANSI_ARGS_((CONST char *path));
extern int write _ANSI_ARGS_((int fd, CONST char *buf, size_t size));
#ifndef _POSIX_SOURCE
extern char *crypt _ANSI_ARGS_((CONST char *, CONST char *));
extern int fchown _ANSI_ARGS_((int fd, uid_t owner, gid_t group));
extern int flock _ANSI_ARGS_((int fd, int operation));
extern int ftruncate _ANSI_ARGS_((int fd, unsigned long length));
extern int ioctl _ANSI_ARGS_((int fd, int request, ...));
extern int readlink _ANSI_ARGS_((CONST char *path, char *buf, int bufsize));
extern int setegid _ANSI_ARGS_((gid_t group));
extern int seteuid _ANSI_ARGS_((uid_t user));
extern int setreuid _ANSI_ARGS_((int ruid, int euid));
extern int symlink _ANSI_ARGS_((CONST char *, CONST char *));
extern int ttyslot _ANSI_ARGS_((void));
extern int truncate _ANSI_ARGS_((CONST char *path, unsigned long length));
extern int vfork _ANSI_ARGS_((void));
#endif /* _POSIX_SOURCE */
#endif /* _UNISTD */
tcl8.4.20/compat/limits.h 0000644 0036047 0045461 00000001260 11737050674 013653 0 ustar dgp 771div /*
* limits.h --
*
* This is a dummy header file to #include in Tcl when there
* is no limits.h in /usr/include. There are only a few
* definitions here; also see tclPort.h, which already
* #defines some of the things here if they're not arleady
* defined.
*
* Copyright (c) 1991 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.
*/
#define LONG_MIN 0x80000000
#define LONG_MAX 0x7fffffff
#define INT_MIN 0x80000000
#define INT_MAX 0x7fffffff
#define SHRT_MIN 0x8000
#define SHRT_MAX 0x7fff
tcl8.4.20/compat/waitpid.c 0000644 0036047 0045461 00000011072 11737050674 014010 0 ustar dgp 771div /*
* waitpid.c --
*
* This procedure emulates the POSIX waitpid kernel call on
* BSD systems that don't have waitpid but do have wait3.
* This code is based on a prototype version written by
* Mark Diekhans and Karl Lehenbauer.
*
* Copyright (c) 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.
*/
#include "tclInt.h"
#include "tclPort.h"
#ifndef pid_t
#define pid_t int
#endif
/*
* A linked list of the following structures is used to keep track
* of processes for which we received notification from the kernel,
* but the application hasn't waited for them yet (this can happen
* because wait may not return the process we really want). We
* save the information here until the application finally does
* wait for the process.
*/
typedef struct WaitInfo {
pid_t pid; /* Pid of process that exited. */
WAIT_STATUS_TYPE status; /* Status returned when child exited
* or suspended. */
struct WaitInfo *nextPtr; /* Next in list of exited processes. */
} WaitInfo;
static WaitInfo *deadList = NULL; /* First in list of all dead
* processes. */
/*
*----------------------------------------------------------------------
*
* waitpid --
*
* This procedure emulates the functionality of the POSIX
* waitpid kernel call, using the BSD wait3 kernel call.
* Note: it doesn't emulate absolutely all of the waitpid
* functionality, in that it doesn't support pid's of 0
* or < -1.
*
* Results:
* -1 is returned if there is an error in the wait kernel call.
* Otherwise the pid of an exited or suspended process is
* returned and *statusPtr is set to the status value of the
* process.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef waitpid
# undef waitpid
#endif
pid_t
waitpid(pid, statusPtr, options)
pid_t pid; /* The pid to wait on. Must be -1 or
* greater than zero. */
int *statusPtr; /* Where to store wait status for the
* process. */
int options; /* OR'ed combination of WNOHANG and
* WUNTRACED. */
{
register WaitInfo *waitPtr, *prevPtr;
pid_t result;
WAIT_STATUS_TYPE status;
if ((pid < -1) || (pid == 0)) {
errno = EINVAL;
return -1;
}
/*
* See if there's a suitable process that has already stopped or
* exited. If so, remove it from the list of exited processes and
* return its information.
*/
for (waitPtr = deadList, prevPtr = NULL; waitPtr != NULL;
prevPtr = waitPtr, waitPtr = waitPtr->nextPtr) {
if ((pid != waitPtr->pid) && (pid != -1)) {
continue;
}
if (!(options & WUNTRACED) && (WIFSTOPPED(waitPtr->status))) {
continue;
}
result = waitPtr->pid;
*statusPtr = *((int *) &waitPtr->status);
if (prevPtr == NULL) {
deadList = waitPtr->nextPtr;
} else {
prevPtr->nextPtr = waitPtr->nextPtr;
}
ckfree((char *) waitPtr);
return result;
}
/*
* Wait for any process to stop or exit. If it's an acceptable one
* then return it to the caller; otherwise store information about it
* in the list of exited processes and try again. On systems that
* have only wait but not wait3, there are several situations we can't
* handle, but we do the best we can (e.g. can still handle some
* combinations of options by invoking wait instead of wait3).
*/
while (1) {
#if NO_WAIT3
if (options & WNOHANG) {
return 0;
}
if (options != 0) {
errno = EINVAL;
return -1;
}
result = wait(&status);
#else
result = wait3(&status, options, 0);
#endif
if ((result == -1) && (errno == EINTR)) {
continue;
}
if (result <= 0) {
return result;
}
if ((pid != result) && (pid != -1)) {
goto saveInfo;
}
if (!(options & WUNTRACED) && (WIFSTOPPED(status))) {
goto saveInfo;
}
*statusPtr = *((int *) &status);
return result;
/*
* Can't return this info to caller. Save it in the list of
* stopped or exited processes. Tricky point: first check for
* an existing entry for the process and overwrite it if it
* exists (e.g. a previously stopped process might now be dead).
*/
saveInfo:
for (waitPtr = deadList; waitPtr != NULL; waitPtr = waitPtr->nextPtr) {
if (waitPtr->pid == result) {
waitPtr->status = status;
goto waitAgain;
}
}
waitPtr = (WaitInfo *) ckalloc(sizeof(WaitInfo));
waitPtr->pid = result;
waitPtr->status = status;
waitPtr->nextPtr = deadList;
deadList = waitPtr;
waitAgain: continue;
}
}
tcl8.4.20/compat/strncasecmp.c 0000644 0036047 0045461 00000010157 11737050674 014674 0 ustar dgp 771div /*
* strncasecmp.c --
*
* Source code for the "strncasecmp" library routine.
*
* Copyright (c) 1988-1993 The Regents of the University of California.
* Copyright (c) 1995-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.
*/
#include "tclPort.h"
/*
* This array is designed for mapping upper and lower case letter
* together for a case independent comparison. The mappings are
* based upon ASCII character sequences.
*/
static unsigned char charmap[] = {
0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07,
0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,
0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,
0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27,
0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f,
0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37,
0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f,
0x40, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67,
0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f,
0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77,
0x78, 0x79, 0x7a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f,
0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67,
0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f,
0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77,
0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f,
0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,
0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f,
0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97,
0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f,
0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7,
0xa8, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf,
0xb0, 0xb1, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6, 0xb7,
0xb8, 0xb9, 0xba, 0xbb, 0xbc, 0xbd, 0xbe, 0xbf,
0xc0, 0xe1, 0xe2, 0xe3, 0xe4, 0xc5, 0xe6, 0xe7,
0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef,
0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7,
0xf8, 0xf9, 0xfa, 0xdb, 0xdc, 0xdd, 0xde, 0xdf,
0xe0, 0xe1, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7,
0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef,
0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7,
0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff,
};
/*
* Here are the prototypes just in case they are not included
* in tclPort.h.
*/
int strncasecmp _ANSI_ARGS_((CONST char *s1,
CONST char *s2, size_t n));
int strcasecmp _ANSI_ARGS_((CONST char *s1,
CONST char *s2));
/*
*----------------------------------------------------------------------
*
* strcasecmp --
*
* Compares two strings, ignoring case differences.
*
* Results:
* Compares two null-terminated strings s1 and s2, returning -1, 0,
* or 1 if s1 is lexicographically less than, equal to, or greater
* than s2.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
strcasecmp(s1, s2)
CONST char *s1; /* First string. */
CONST char *s2; /* Second string. */
{
unsigned char u1, u2;
for ( ; ; s1++, s2++) {
u1 = (unsigned char) *s1;
u2 = (unsigned char) *s2;
if ((u1 == '\0') || (charmap[u1] != charmap[u2])) {
break;
}
}
return charmap[u1] - charmap[u2];
}
/*
*----------------------------------------------------------------------
*
* strncasecmp --
*
* Compares two strings, ignoring case differences.
*
* Results:
* Compares up to length chars of s1 and s2, returning -1, 0, or 1
* if s1 is lexicographically less than, equal to, or greater
* than s2 over those characters.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
strncasecmp(s1, s2, length)
CONST char *s1; /* First string. */
CONST char *s2; /* Second string. */
size_t length; /* Maximum number of characters to compare
* (stop earlier if the end of either string
* is reached). */
{
unsigned char u1, u2;
for (; length != 0; length--, s1++, s2++) {
u1 = (unsigned char) *s1;
u2 = (unsigned char) *s2;
if (charmap[u1] != charmap[u2]) {
return charmap[u1] - charmap[u2];
}
if (u1 == '\0') {
return 0;
}
}
return 0;
}
tcl8.4.20/compat/dirent.h 0000644 0036047 0045461 00000000766 11737050674 013651 0 ustar dgp 771div /*
* dirent.h --
*
* This file is a replacement for in systems that
* support the old BSD-style with a "struct direct".
*
* Copyright (c) 1991 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.
*/
#ifndef _DIRENT
#define _DIRENT
#include
#define dirent direct
#endif /* _DIRENT */
tcl8.4.20/compat/README 0000644 0036047 0045461 00000000576 11737050674 013072 0 ustar dgp 771div This directory contains various header and code files that are
used make Tcl compatible with various releases of UNIX and UNIX-like
systems. Typically, files from this directory are used to compile
Tcl when a system doesn't contain the corresponding files or when
they are known to be incorrect. When the whole world becomes POSIX-
compliant this directory should be unnecessary.
tcl8.4.20/compat/strtol.c 0000644 0036047 0045461 00000003663 11737050674 013705 0 ustar dgp 771div /*
* strtol.c --
*
* Source code for the "strtol" library procedure.
*
* Copyright (c) 1988 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.
*/
#include
#include "tclInt.h"
#include "tclPort.h"
/*
*----------------------------------------------------------------------
*
* strtol --
*
* Convert an ASCII string into an integer.
*
* Results:
* The return value is the integer equivalent of string. If endPtr
* is non-NULL, then *endPtr is filled in with the character
* after the last one that was part of the integer. If string
* doesn't contain a valid integer value, then zero is returned
* and *endPtr is set to string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
long int
strtol(string, endPtr, base)
CONST char *string; /* String of ASCII digits, possibly
* preceded by white space. For bases
* greater than 10, either lower- or
* upper-case digits may be used.
*/
char **endPtr; /* Where to store address of terminating
* character, or NULL. */
int base; /* Base for conversion. Must be less
* than 37. If 0, then the base is chosen
* from the leading characters of string:
* "0x" means hex, "0" means octal, anything
* else means decimal.
*/
{
register CONST char *p;
long result;
/*
* Skip any leading blanks.
*/
p = string;
while (isspace(UCHAR(*p))) {
p += 1;
}
/*
* Check for a sign.
*/
if (*p == '-') {
p += 1;
result = -(strtoul(p, endPtr, base));
} else {
if (*p == '+') {
p += 1;
}
result = strtoul(p, endPtr, base);
}
if ((result == 0) && (endPtr != 0) && (*endPtr == p)) {
*endPtr = (char *) string;
}
return result;
}
tcl8.4.20/compat/float.h 0000644 0036047 0045461 00000001006 11737050674 013455 0 ustar dgp 771div /*
* float.h --
*
* This is a dummy header file to #include in Tcl when there
* is no float.h in /usr/include. Right now this file is empty:
* Tcl contains #ifdefs to deal with the lack of definitions;
* all it needs is for the #include statement to work.
*
* Copyright (c) 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.
*/
tcl8.4.20/compat/strftime.c 0000644 0036047 0045461 00000030042 12151137515 014171 0 ustar dgp 771div /*
* strftime.c --
*
* This file contains a modified version of the BSD 4.4 strftime
* function.
*
* This file is a modified version of the strftime.c file from the BSD 4.4
* source. See the copyright notice below for details on redistribution
* restrictions. The "license.terms" file does not apply to this file.
*
* Changes 2002 Copyright (c) 2002 ActiveState Corporation.
*/
/*
* Copyright (c) 1989 The Regents of the University of California.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*/
#if defined(_WIN32) && !defined(_WIN64)
# define _USE_32BIT_TIME_T
#endif
#include
#include
#include
#include "tclInt.h"
#include "tclPort.h"
#define TM_YEAR_BASE 1900
#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0))
typedef struct {
const char *abday[7];
const char *day[7];
const char *abmon[12];
const char *mon[12];
const char *am_pm[2];
const char *d_t_fmt;
const char *d_fmt;
const char *t_fmt;
const char *t_fmt_ampm;
} _TimeLocale;
/*
* This is the C locale default. On Windows, if we wanted to make this
* localized, we would use GetLocaleInfo to get the correct values.
* It may be acceptable to do localization of month/day names, as the
* numerical values would be considered the locale-independent versions.
*/
static const _TimeLocale _DefaultTimeLocale =
{
{
"Sun","Mon","Tue","Wed","Thu","Fri","Sat",
},
{
"Sunday", "Monday", "Tuesday", "Wednesday", "Thursday",
"Friday", "Saturday"
},
{
"Jan", "Feb", "Mar", "Apr", "May", "Jun",
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec"
},
{
"January", "February", "March", "April", "May", "June", "July",
"August", "September", "October", "November", "December"
},
{
"AM", "PM"
},
"%a %b %d %H:%M:%S %Y",
"%m/%d/%y",
"%H:%M:%S",
"%I:%M:%S %p"
};
static const _TimeLocale *_CurrentTimeLocale = &_DefaultTimeLocale;
static int isGMT;
static size_t gsize;
static char *pt;
static int _add _ANSI_ARGS_((const char* str));
static int _conv _ANSI_ARGS_((int n, int digits, int pad));
static int _secs _ANSI_ARGS_((const struct tm *t));
static size_t _fmt _ANSI_ARGS_((const char *format,
const struct tm *t));
static int ISO8601Week _ANSI_ARGS_((CONST struct tm* t, int *year ));
size_t
TclpStrftime(s, maxsize, format, t, useGMT)
char *s;
size_t maxsize;
const char *format;
const struct tm *t;
int useGMT;
{
if (format[0] == '%' && format[1] == 'Q') {
/* Format as a stardate */
sprintf(s, "Stardate %2d%03d.%01d",
(((t->tm_year + TM_YEAR_BASE) + 377) - 2323),
(((t->tm_yday + 1) * 1000) /
(365 + IsLeapYear((t->tm_year + TM_YEAR_BASE)))),
(((t->tm_hour * 60) + t->tm_min)/144));
return(strlen(s));
}
isGMT = useGMT;
/*
* We may be able to skip this for useGMT, but it should be harmless.
* -- hobbs
*/
tzset();
pt = s;
if ((gsize = maxsize) < 1)
return(0);
if (_fmt(format, t)) {
*pt = '\0';
return(maxsize - gsize);
}
return(0);
}
#define SUN_WEEK(t) (((t)->tm_yday + 7 - \
((t)->tm_wday)) / 7)
#define MON_WEEK(t) (((t)->tm_yday + 7 - \
((t)->tm_wday ? (t)->tm_wday - 1 : 6)) / 7)
static size_t
_fmt(format, t)
const char *format;
const struct tm *t;
{
#ifdef WIN32
#define BUF_SIZ 256
TCHAR buf[BUF_SIZ];
SYSTEMTIME syst = {
t->tm_year + 1900,
t->tm_mon + 1,
t->tm_wday,
t->tm_mday,
t->tm_hour,
t->tm_min,
t->tm_sec,
0,
};
#endif
for (; *format; ++format) {
if (*format == '%') {
++format;
if (*format == 'E') {
/* Alternate Era */
++format;
} else if (*format == 'O') {
/* Alternate numeric symbols */
++format;
}
switch(*format) {
case '\0':
--format;
break;
case 'A':
if (t->tm_wday < 0 || t->tm_wday > 6)
return(0);
if (!_add(_CurrentTimeLocale->day[t->tm_wday]))
return(0);
continue;
case 'a':
if (t->tm_wday < 0 || t->tm_wday > 6)
return(0);
if (!_add(_CurrentTimeLocale->abday[t->tm_wday]))
return(0);
continue;
case 'B':
if (t->tm_mon < 0 || t->tm_mon > 11)
return(0);
if (!_add(_CurrentTimeLocale->mon[t->tm_mon]))
return(0);
continue;
case 'b':
case 'h':
if (t->tm_mon < 0 || t->tm_mon > 11)
return(0);
if (!_add(_CurrentTimeLocale->abmon[t->tm_mon]))
return(0);
continue;
case 'C':
if (!_conv((t->tm_year + TM_YEAR_BASE) / 100,
2, '0'))
return(0);
continue;
case 'D':
if (!_fmt("%m/%d/%y", t))
return(0);
continue;
case 'd':
if (!_conv(t->tm_mday, 2, '0'))
return(0);
continue;
case 'e':
if (!_conv(t->tm_mday, 2, ' '))
return(0);
continue;
case 'g':
{
int year;
ISO8601Week( t, &year );
if ( !_conv( year%100, 2, '0' ) ) {
return( 0 );
}
continue;
}
case 'G':
{
int year;
ISO8601Week( t, &year );
if ( !_conv( year, 4, '0' ) ) {
return( 0 );
}
continue;
}
case 'H':
if (!_conv(t->tm_hour, 2, '0'))
return(0);
continue;
case 'I':
if (!_conv(t->tm_hour % 12 ?
t->tm_hour % 12 : 12, 2, '0'))
return(0);
continue;
case 'j':
if (!_conv(t->tm_yday + 1, 3, '0'))
return(0);
continue;
case 'k':
if (!_conv(t->tm_hour, 2, ' '))
return(0);
continue;
case 'l':
if (!_conv(t->tm_hour % 12 ?
t->tm_hour % 12: 12, 2, ' '))
return(0);
continue;
case 'M':
if (!_conv(t->tm_min, 2, '0'))
return(0);
continue;
case 'm':
if (!_conv(t->tm_mon + 1, 2, '0'))
return(0);
continue;
case 'n':
if (!_add("\n"))
return(0);
continue;
case 'p':
if (!_add(_CurrentTimeLocale->am_pm[t->tm_hour >= 12]))
return(0);
continue;
case 'R':
if (!_fmt("%H:%M", t))
return(0);
continue;
case 'r':
if (!_fmt(_CurrentTimeLocale->t_fmt_ampm, t))
return(0);
continue;
case 'S':
if (!_conv(t->tm_sec, 2, '0'))
return(0);
continue;
case 's':
if (!_secs(t))
return(0);
continue;
case 'T':
if (!_fmt("%H:%M:%S", t))
return(0);
continue;
case 't':
if (!_add("\t"))
return(0);
continue;
case 'U':
if (!_conv(SUN_WEEK(t), 2, '0'))
return(0);
continue;
case 'u':
if (!_conv(t->tm_wday ? t->tm_wday : 7, 1, '0'))
return(0);
continue;
case 'V':
{
int week = ISO8601Week( t, NULL );
if (!_conv(week, 2, '0'))
return(0);
continue;
}
case 'W':
if (!_conv(MON_WEEK(t), 2, '0'))
return(0);
continue;
case 'w':
if (!_conv(t->tm_wday, 1, '0'))
return(0);
continue;
#ifdef WIN32
/*
* To properly handle the localized time routines on Windows,
* we must make use of the special localized calls.
*/
case 'c':
if (!GetDateFormat(LOCALE_USER_DEFAULT,
DATE_LONGDATE | LOCALE_USE_CP_ACP,
&syst, NULL, buf, BUF_SIZ)
|| !_add(buf)
|| !_add(" ")) {
return(0);
}
/*
* %c is created with LONGDATE + " " + TIME on Windows,
* so continue to %X case here.
*/
case 'X':
if (!GetTimeFormat(LOCALE_USER_DEFAULT,
LOCALE_USE_CP_ACP,
&syst, NULL, buf, BUF_SIZ)
|| !_add(buf)) {
return(0);
}
continue;
case 'x':
if (!GetDateFormat(LOCALE_USER_DEFAULT,
DATE_SHORTDATE | LOCALE_USE_CP_ACP,
&syst, NULL, buf, BUF_SIZ)
|| !_add(buf)) {
return(0);
}
continue;
#else
case 'c':
if (!_fmt(_CurrentTimeLocale->d_t_fmt, t))
return(0);
continue;
case 'x':
if (!_fmt(_CurrentTimeLocale->d_fmt, t))
return(0);
continue;
case 'X':
if (!_fmt(_CurrentTimeLocale->t_fmt, t))
return(0);
continue;
#endif
case 'y':
if (!_conv((t->tm_year + TM_YEAR_BASE) % 100,
2, '0'))
return(0);
continue;
case 'Y':
if (!_conv((t->tm_year + TM_YEAR_BASE), 4, '0'))
return(0);
continue;
case 'Z': {
char *name = (isGMT ? "GMT" : TclpGetTZName(t->tm_isdst));
int wrote;
Tcl_UtfToExternal(NULL, NULL, name, -1, 0, NULL,
pt, gsize, NULL, &wrote, NULL);
pt += wrote;
gsize -= wrote;
continue;
}
case '%':
/*
* X311J/88-090 (4.12.3.5): if conversion char is
* undefined, behavior is undefined. Print out the
* character itself as printf(3) does.
*/
default:
break;
}
}
if (!gsize--)
return(0);
*pt++ = *format;
}
return(gsize);
}
static int
_secs(t)
const struct tm *t;
{
static char buf[15];
register time_t s;
register char *p;
struct tm tmp;
/* Make a copy, mktime(3) modifies the tm struct. */
tmp = *t;
s = mktime(&tmp);
for (p = buf + sizeof(buf) - 2; s > 0 && p > buf; s /= 10)
*p-- = (char)(s % 10 + '0');
return(_add(++p));
}
static int
_conv(n, digits, pad)
int n, digits;
int pad;
{
static char buf[10];
register char *p;
p = buf + sizeof( buf ) - 1;
*p-- = '\0';
if ( n == 0 ) {
*p-- = '0'; --digits;
} else {
for (; n > 0 && p > buf; n /= 10, --digits)
*p-- = (char)(n % 10 + '0');
}
while (p > buf && digits-- > 0)
*p-- = (char) pad;
return(_add(++p));
}
static int
_add(str)
const char *str;
{
for (;; ++pt, --gsize) {
if (!gsize)
return(0);
if (!(*pt = *str++))
return(1);
}
}
static int
ISO8601Week( t, year )
CONST struct tm* t;
int* year;
{
/* Find the day-of-year of the Thursday in
* the week in question. */
int ydayThursday;
int week;
if ( t->tm_wday == 0 ) {
ydayThursday = t->tm_yday - 3;
} else {
ydayThursday = t->tm_yday - t->tm_wday + 4;
}
if ( ydayThursday < 0 ) {
/* This is the last week of the previous year. */
if ( IsLeapYear(( t->tm_year + TM_YEAR_BASE - 1 )) ) {
ydayThursday += 366;
} else {
ydayThursday += 365;
}
week = ydayThursday / 7 + 1;
if ( year != NULL ) {
*year = t->tm_year + 1899;
}
} else if ( ( IsLeapYear(( t -> tm_year + TM_YEAR_BASE ))
&& ydayThursday >= 366 )
|| ( !IsLeapYear(( t -> tm_year
+ TM_YEAR_BASE ))
&& ydayThursday >= 365 ) ) {
/* This is week 1 of the following year */
week = 1;
if ( year != NULL ) {
*year = t->tm_year + 1901;
}
} else {
week = ydayThursday / 7 + 1;
if ( year != NULL ) {
*year = t->tm_year + 1900;
}
}
return week;
}
tcl8.4.20/compat/string.h 0000644 0036047 0045461 00000004774 12052456743 013673 0 ustar dgp 771div /*
* string.h --
*
* Declarations of ANSI C library procedures for string handling.
*
* Copyright (c) 1991-1993 The Regents of the University of California.
* Copyright (c) 1994-1996 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _STRING
#define _STRING
#include
/*
* The following #include is needed to define size_t. (This used to
* include sys/stdtypes.h but that doesn't exist on older versions
* of SunOS, e.g. 4.0.2, so I'm trying sys/types.h now.... hopefully
* it exists everywhere)
*/
#include
#ifdef __APPLE__
extern VOID * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n));
#else
extern char * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n));
#endif
extern int memcmp _ANSI_ARGS_((CONST VOID *s1, CONST VOID *s2,
size_t n));
extern char * memcpy _ANSI_ARGS_((VOID *t, CONST VOID *f, size_t n));
#ifdef NO_MEMMOVE
#define memmove(d, s, n) bcopy ((s), (d), (n))
#else
extern char * memmove _ANSI_ARGS_((VOID *t, CONST VOID *f,
size_t n));
#endif
extern char * memset _ANSI_ARGS_((VOID *s, int c, size_t n));
extern int strcasecmp _ANSI_ARGS_((CONST char *s1,
CONST char *s2));
extern char * strcat _ANSI_ARGS_((char *dst, CONST char *src));
extern char * strchr _ANSI_ARGS_((CONST char *string, int c));
extern int strcmp _ANSI_ARGS_((CONST char *s1, CONST char *s2));
extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src));
extern size_t strcspn _ANSI_ARGS_((CONST char *string,
CONST char *chars));
extern char * strdup _ANSI_ARGS_((CONST char *string));
extern char * strerror _ANSI_ARGS_((int error));
extern size_t strlen _ANSI_ARGS_((CONST char *string));
extern int strncasecmp _ANSI_ARGS_((CONST char *s1,
CONST char *s2, size_t n));
extern char * strncat _ANSI_ARGS_((char *dst, CONST char *src,
size_t numChars));
extern int strncmp _ANSI_ARGS_((CONST char *s1, CONST char *s2,
size_t nChars));
extern char * strncpy _ANSI_ARGS_((char *dst, CONST char *src,
size_t numChars));
extern char * strpbrk _ANSI_ARGS_((CONST char *string,
CONST char *chars));
extern char * strrchr _ANSI_ARGS_((CONST char *string, int c));
extern size_t strspn _ANSI_ARGS_((CONST char *string,
CONST char *chars));
extern char * strstr _ANSI_ARGS_((CONST char *string,
CONST char *substring));
extern char * strtok _ANSI_ARGS_((char *s, CONST char *delim));
#endif /* _STRING */
tcl8.4.20/tests/ 0000755 0036047 0045461 00000000000 12153151142 012042 5 ustar dgp 771div tcl8.4.20/tests/info.test 0000644 0036047 0045461 00000135244 11737050674 013726 0 ustar dgp 771div # -*- tcl -*-
# Commands covered: info
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2006 ActiveState
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# DO NOT DELETE THIS LINE. Keep line numbers correct for testing 'info frame'.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
catch {namespace delete test_ns_info1 test_ns_info2}
namespace eval test_ns_info1 {
namespace export *
proc p {x} {return "x=$x"}
proc q {{y 27} {z {}}} {return "y=$y"}
}
testConstraint tip280 [info exists tcl_platform(tip,280)]
testConstraint !tip280 [expr {![info exists tcl_platform(tip,280)]}]
test info-1.1 {info args option} {
proc t1 {a bbb c} {return foo}
info args t1
} {a bbb c}
test info-1.2 {info args option} {
proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
info a t1
} {a bbb c args}
test info-1.3 {info args option} {
proc t1 "" {return foo}
info args t1
} {}
test info-1.4 {info args option} {
catch {rename t1 {}}
list [catch {info args t1} msg] $msg
} {1 {"t1" isn't a procedure}}
test info-1.5 {info args option} {
list [catch {info args set} msg] $msg
} {1 {"set" isn't a procedure}}
test info-1.6 {info args option} {
proc t1 {a b} {set c 123; set d $c}
t1 1 2
info args t1
} {a b}
test info-1.7 {info args option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info args p] [info args q]
}
} {x {y z}}
test info-2.1 {info body option} {
proc t1 {} {body of t1}
info body t1
} {body of t1}
test info-2.2 {info body option} {
list [catch {info body set} msg] $msg
} {1 {"set" isn't a procedure}}
test info-2.3 {info body option} {
list [catch {info args set 1} msg] $msg
} {1 {wrong # args: should be "info args procname"}}
test info-2.4 {info body option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info body p] [info body q]
}
} {{return "x=$x"} {return "y=$y"}}
# Prior to 8.3.0 this would cause a crash because [info body]
# would return the bytecompiled version of foo, which the catch
# would then try and eval out of the foo context, accessing
# compiled local indices
test info-2.5 {info body option, returning bytecompiled bodies} {
catch {unset args}
proc foo {args} {
foreach v $args {
upvar $v var
return "variable $v existence: [info exists var]"
}
}
foo a
list [catch [info body foo] msg] $msg
} {1 {can't read "args": no such variable}}
# Fix for problem tested for in info-2.5 caused problems when
# procedure body had no string rep (i.e. was not yet bytecode)
# causing an empty string to be returned [Bug #545644]
test info-2.6 {info body option, returning list bodies} {
proc foo args [list subst bar]
list [string bytelength [info body foo]] \
[foo; string bytelength [info body foo]]
} {9 9}
# "info cmdcount" is no longer accurate for compiled commands!
# The expected result for info-3.1 used to be "3" and is now "1"
# since the "set"s have been compiled away. info-3.2 was corrected
# in 8.3 because the eval'ed body won't be compiled.
proc testinfocmdcount {} {
set x [info cmdcount]
set y 12345
set z [info cm]
expr $z-$x
}
test info-3.1 {info cmdcount compiled} {
testinfocmdcount
} 1
test info-3.2 {info cmdcount evaled} {
set x [info cmdcount]
set y 12345
set z [info cm]
expr $z-$x
} 3
test info-3.3 {info cmdcount evaled} [info body testinfocmdcount] 3
test info-3.4 {info cmdcount option} {
list [catch {info cmdcount 1} msg] $msg
} {1 {wrong # args: should be "info cmdcount"}}
test info-4.1 {info commands option} {
proc t1 {} {}
proc t2 {} {}
set x " [info commands] "
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
[string match {* set *} $x] [string match {* list *} $x]
} {1 1 1 1}
test info-4.2 {info commands option} {
proc t1 {} {}
rename t1 {}
set x [info comm]
string match {* t1 *} $x
} 0
test info-4.3 {info commands option} {
proc _t1_ {} {}
proc _t2_ {} {}
info commands _t1_
} _t1_
test info-4.4 {info commands option} {
proc _t1_ {} {}
proc _t2_ {} {}
lsort [info commands _t*]
} {_t1_ _t2_}
catch {rename _t1_ {}}
catch {rename _t2_ {}}
test info-4.5 {info commands option} {
list [catch {info commands a b} msg] $msg
} {1 {wrong # args: should be "info commands ?pattern?"}}
test info-5.1 {info complete option} {
list [catch {info complete} msg] $msg
} {1 {wrong # args: should be "info complete command"}}
test info-5.2 {info complete option} {
info complete abc
} 1
test info-5.3 {info complete option} {
info complete "\{abcd "
} 0
test info-5.4 {info complete option} {
info complete {# Comment should be complete command}
} 1
test info-5.5 {info complete option} {
info complete {[a [b] }
} 0
test info-5.6 {info complete option} {
info complete {[a [b]}
} 0
test info-6.1 {info default option} {
proc t1 {a b {c d} {e "long default value"}} {}
info default t1 a value
} 0
test info-6.2 {info default option} {
proc t1 {a b {c d} {e "long default value"}} {}
set value 12345
info d t1 a value
set value
} {}
test info-6.3 {info default option} {
proc t1 {a b {c d} {e "long default value"}} {}
info default t1 c value
} 1
test info-6.4 {info default option} {
proc t1 {a b {c d} {e "long default value"}} {}
set value 12345
info default t1 c value
set value
} d
test info-6.5 {info default option} {
proc t1 {a b {c d} {e "long default value"}} {}
set value 12345
set x [info default t1 e value]
list $x $value
} {1 {long default value}}
test info-6.6 {info default option} {
list [catch {info default a b} msg] $msg
} {1 {wrong # args: should be "info default procname arg varname"}}
test info-6.7 {info default option} {
list [catch {info default _nonexistent_ a b} msg] $msg
} {1 {"_nonexistent_" isn't a procedure}}
test info-6.8 {info default option} {
proc t1 {a b} {}
list [catch {info default t1 x value} msg] $msg
} {1 {procedure "t1" doesn't have an argument "x"}}
test info-6.9 {info default option} {
catch {unset a}
set a(0) 88
proc t1 {a b} {}
list [catch {info default t1 a a} msg] $msg
} {1 {couldn't store default value in variable "a"}}
test info-6.10 {info default option} {
catch {unset a}
set a(0) 88
proc t1 {{a 18} b} {}
list [catch {info default t1 a a} msg] $msg
} {1 {couldn't store default value in variable "a"}}
test info-6.11 {info default option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info default p x foo] $foo [info default q y bar] $bar
}
} {0 {} 1 27}
catch {unset a}
test info-7.1 {info exists option} {
set value foo
info exists value
} 1
catch {unset _nonexistent_}
test info-7.2 {info exists option} {
info exists _nonexistent_
} 0
test info-7.3 {info exists option} {
proc t1 {x} {return [info exists x]}
t1 2
} 1
test info-7.4 {info exists option} {
proc t1 {x} {
global _nonexistent_
return [info exists _nonexistent_]
}
t1 2
} 0
test info-7.5 {info exists option} {
proc t1 {x} {
set y 47
return [info exists y]
}
t1 2
} 1
test info-7.6 {info exists option} {
proc t1 {x} {return [info exists value]}
t1 2
} 0
test info-7.7 {info exists option} {
catch {unset x}
set x(2) 44
list [info exists x] [info exists x(1)] [info exists x(2)]
} {1 0 1}
catch {unset x}
test info-7.8 {info exists option} {
list [catch {info exists} msg] $msg
} {1 {wrong # args: should be "info exists varName"}}
test info-7.9 {info exists option} {
list [catch {info exists 1 2} msg] $msg
} {1 {wrong # args: should be "info exists varName"}}
test info-8.1 {info globals option} {
set x 1
set y 2
set value 23
set a " [info globals] "
list [string match {* x *} $a] [string match {* y *} $a] \
[string match {* value *} $a] [string match {* _foobar_ *} $a]
} {1 1 1 0}
test info-8.2 {info globals option} {
set _xxx1 1
set _xxx2 2
lsort [info g _xxx*]
} {_xxx1 _xxx2}
test info-8.3 {info globals option} {
list [catch {info globals 1 2} msg] $msg
} {1 {wrong # args: should be "info globals ?pattern?"}}
test info-8.4 {info globals option: may have leading namespace qualifiers} {
set x 0
list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x]
} {x {} x x x}
test info-8.5 {info globals option: only return existing global variables} {
-setup {
catch {unset ::NO_SUCH_VAR}
proc evalInProc script {eval $script}
}
-body {
evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR}
}
-cleanup {
rename evalInProc {}
}
-result {}
}
test info-9.1 {info level option} {
info level
} 0
test info-9.2 {info level option} {
proc t1 {a b} {
set x [info le]
set y [info level 1]
list $x $y
}
t1 146 testString
} {1 {t1 146 testString}}
test info-9.3 {info level option} {
proc t1 {a b} {
t2 [expr $a*2] $b
}
proc t2 {x y} {
list [info level] [info level 1] [info level 2] [info level -1] \
[info level 0]
}
t1 146 {a {b c} {{{c}}}}
} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}}
test info-9.4 {info level option} {
proc t1 {} {
set x [info level]
set y [info level 1]
list $x $y
}
t1
} {1 t1}
test info-9.5 {info level option} {
list [catch {info level 1 2} msg] $msg
} {1 {wrong # args: should be "info level ?number?"}}
test info-9.6 {info level option} {
list [catch {info level 123a} msg] $msg
} {1 {expected integer but got "123a"}}
test info-9.7 {info level option} {
list [catch {info level 0} msg] $msg
} {1 {bad level "0"}}
test info-9.8 {info level option} {
proc t1 {} {info level -1}
list [catch {t1} msg] $msg
} {1 {bad level "-1"}}
test info-9.9 {info level option} {
proc t1 {x} {info level $x}
list [catch {t1 -3} msg] $msg
} {1 {bad level "-3"}}
test info-9.10 {info level option, namespaces} {
set msg [namespace eval t {info level 0}]
namespace delete t
set msg
} {namespace eval t {info level 0}}
set savedLibrary $tcl_library
test info-10.1 {info library option} {
list [catch {info library x} msg] $msg
} {1 {wrong # args: should be "info library"}}
test info-10.2 {info library option} {
set tcl_library 12345
info library
} {12345}
test info-10.3 {info library option} {
unset tcl_library
list [catch {info library} msg] $msg
} {1 {no library has been specified for Tcl}}
set tcl_library $savedLibrary
test info-11.1 {info loaded option} {
list [catch {info loaded a b} msg] $msg
} {1 {wrong # args: should be "info loaded ?interp?"}}
test info-11.2 {info loaded option} {
list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg
} {0 1 {could not find interpreter "gorp"}}
test info-12.1 {info locals option} {
set a 22
proc t1 {x y} {
set b 13
set c testing
global a
global aa
set aa 23
return [info locals]
}
lsort [t1 23 24]
} {b c x y}
test info-12.2 {info locals option} {
proc t1 {x y} {
set xx1 2
set xx2 3
set y 4
return [info loc x*]
}
lsort [t1 2 3]
} {x xx1 xx2}
test info-12.3 {info locals option} {
list [catch {info locals 1 2} msg] $msg
} {1 {wrong # args: should be "info locals ?pattern?"}}
test info-12.4 {info locals option} {
info locals
} {}
test info-12.5 {info locals option} {
proc t1 {} {return [info locals]}
t1
} {}
test info-12.6 {info locals vs unset compiled locals} {
proc t1 {lst} {
foreach $lst $lst {}
unset lst
return [info locals]
}
lsort [t1 {a b c c d e f}]
} {a b c d e f}
test info-12.7 {info locals with temporary variables} {
proc t1 {} {
foreach a {b c} {}
info locals
}
t1
} {a}
test info-13.1 {info nameofexecutable option} {
list [catch {info nameofexecutable foo} msg] $msg
} {1 {wrong # args: should be "info nameofexecutable"}}
test info-14.1 {info patchlevel option} {
set a [info patchlevel]
regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a
} 1
test info-14.2 {info patchlevel option} {
list [catch {info patchlevel a} msg] $msg
} {1 {wrong # args: should be "info patchlevel"}}
test info-14.3 {info patchlevel option} {
set t $tcl_patchLevel
unset tcl_patchLevel
set result [list [catch {info patchlevel} msg] $msg]
set tcl_patchLevel $t
set result
} {1 {can't read "tcl_patchLevel": no such variable}}
test info-15.1 {info procs option} {
proc t1 {} {}
proc t2 {} {}
set x " [info procs] "
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
[string match {* _undefined_ *} $x]
} {1 1 0}
test info-15.2 {info procs option} {
proc _tt1 {} {}
proc _tt2 {} {}
lsort [info pr _tt*]
} {_tt1 _tt2}
catch {rename _tt1 {}}
catch {rename _tt2 {}}
test info-15.3 {info procs option} {
list [catch {info procs 2 3} msg] $msg
} {1 {wrong # args: should be "info procs ?pattern?"}}
test info-15.4 {info procs option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
proc r {} {}
list [info procs] [info procs p*]
}
} {{p q r} p}
test info-15.5 {info procs option with a proc in a namespace} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
proc p1 { arg } {
puts cmd
}
proc p2 { arg } {
puts cmd
}
}
info procs ::test_ns_info2::p1
} {::test_ns_info2::p1}
test info-15.6 {info procs option with a pattern in a namespace} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
proc p1 { arg } {
puts cmd
}
proc p2 { arg } {
puts cmd
}
}
lsort [info procs ::test_ns_info2::p*]
} [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]]
test info-15.7 {info procs option with a global shadowing proc} {
catch {namespace delete test_ns_info2}
proc string_cmd { arg } {
puts cmd
}
namespace eval test_ns_info2 {
proc string_cmd { arg } {
puts cmd
}
}
info procs test_ns_info2::string*
} {::test_ns_info2::string_cmd}
# This regression test is currently commented out because it requires
# that the implementation of "info procs" looks into the global namespace,
# which it does not (in contrast to "info commands")
if {0} {
test info-15.8 {info procs option with a global shadowing proc} {
catch {namespace delete test_ns_info2}
proc string_cmd { arg } {
puts cmd
}
proc string_cmd2 { arg } {
puts cmd
}
namespace eval test_ns_info2 {
proc string_cmd { arg } {
puts cmd
}
}
namespace eval test_ns_info2 {
lsort [info procs string*]
}
} [lsort [list string_cmd string_cmd2]]
}
test info-16.1 {info script option} {
list [catch {info script x x} msg] $msg
} {1 {wrong # args: should be "info script ?filename?"}}
test info-16.2 {info script option} {
file tail [info sc]
} "info.test"
set gorpfile [makeFile "info script\n" gorp.info]
test info-16.3 {info script option} {
list [source $gorpfile] [file tail [info script]]
} [list $gorpfile info.test]
test info-16.4 {resetting "info script" after errors} {
catch {source ~_nobody_/foo}
file tail [info script]
} "info.test"
test info-16.5 {resetting "info script" after errors} {
catch {source _nonexistent_}
file tail [info script]
} "info.test"
test info-16.6 {info script option} {
set script [info script]
list [file tail [info script]] \
[info script newname.txt] \
[file tail [info script $script]]
} [list info.test newname.txt info.test]
test info-16.7 {info script option} {
set script [info script]
info script newname.txt
list [source $gorpfile] [file tail [info script]] \
[file tail [info script $script]]
} [list $gorpfile newname.txt info.test]
removeFile gorp.info
set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info]
test info-16.8 {info script option} {
list [source $gorpfile] [file tail [info script]]
} [list [list $gorpfile foo.bar] info.test]
removeFile gorp.info
test info-17.1 {info sharedlibextension option} {
list [catch {info sharedlibextension foo} msg] $msg
} {1 {wrong # args: should be "info sharedlibextension"}}
test info-18.1 {info tclversion option} {
set x [info tclversion]
scan $x "%d.%d%c" a b c
} 2
test info-18.2 {info tclversion option} {
list [catch {info t 2} msg] $msg
} {1 {wrong # args: should be "info tclversion"}}
test info-18.3 {info tclversion option} {
set t $tcl_version
unset tcl_version
set result [list [catch {info tclversion} msg] $msg]
set tcl_version $t
set result
} {1 {can't read "tcl_version": no such variable}}
test info-19.1 {info vars option} {
set a 1
set b 2
proc t1 {x y} {
global a b
set c 33
return [info vars]
}
lsort [t1 18 19]
} {a b c x y}
test info-19.2 {info vars option} {
set xxx1 1
set xxx2 2
proc t1 {xxa y} {
global xxx1 xxx2
set c 33
return [info vars x*]
}
lsort [t1 18 19]
} {xxa xxx1 xxx2}
test info-19.3 {info vars option} {
lsort [info vars]
} [lsort [info globals]]
test info-19.4 {info vars option} {
list [catch {info vars a b} msg] $msg
} {1 {wrong # args: should be "info vars ?pattern?"}}
test info-19.5 {info vars with temporary variables} {
proc t1 {} {
foreach a {b c} {}
info vars
}
t1
} {a}
test info-19.6 {info vars: Bug 1072654} -setup {
namespace eval :: unset -nocomplain foo
catch {namespace delete x}
} -body {
namespace eval x info vars foo
} -cleanup {
namespace delete x
} -result {}
# Check whether the extra testing functions are defined...
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
} else {
set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
}
test info-20.1 {info functions option} {info functions sin} sin
test info-20.2 {info functions option} {lsort [info functions]} $functions
test info-20.3 {info functions option} {
lsort [info functions a*]
} {abs acos asin atan atan2}
test info-20.4 {info functions option} {
lsort [info functions *tan*]
} {atan atan2 tan tanh}
test info-20.5 {info functions option} {
list [catch {info functions raise an error} msg] $msg
} {1 {wrong # args: should be "info functions ?pattern?"}}
test info-21.1 {miscellaneous error conditions} {
list [catch {info} msg] $msg
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
test info-21.2 {miscellaneous error conditions} !tip280 {
list [catch {info gorp} msg] $msg
} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.2-280 {miscellaneous error conditions} tip280 {
list [catch {info gorp} msg] $msg
} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.3 {miscellaneous error conditions} !tip280 {
list [catch {info c} msg] $msg
} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.3-280 {miscellaneous error conditions} tip280 {
list [catch {info c} msg] $msg
} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.4 {miscellaneous error conditions} !tip280 {
list [catch {info l} msg] $msg
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.4-280 {miscellaneous error conditions} tip280 {
list [catch {info l} msg] $msg
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.5 {miscellaneous error conditions} !tip280 {
list [catch {info s} msg] $msg
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.5-280 {miscellaneous error conditions} tip280 {
list [catch {info s} msg] $msg
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
##
# ### ### ### ######### ######### #########
## info frame
## Helper
# For the more complex results we cut the file name down to remove
# path dependencies, and we use only part of the first line of the
# reported command. The latter is required because otherwise the whole
# test case may appear in some results, but the result is part of the
# testcase. An infinite string would be required to describe that. The
# cutting-down breaks this.
proc reduce {frame} {
set pos [lsearch -exact $frame cmd]
incr pos
set cmd [lindex $frame $pos]
if {[regexp \n $cmd]} {
set first [lindex [split $cmd \n] 0] ; set first [expr {[string length $first] > 11 ? [string range $first 0 end-11] : [string range $first 0 end-4]}]
set frame [lreplace $frame $pos $pos $first]
}
set pos [lsearch -exact $frame file]
if {$pos >=0} {
incr pos
set tail [file tail [lindex $frame $pos]]
set frame [lreplace $frame $pos $pos $tail]
}
set frame
}
## Helper
# Generate a stacktrace from the current location to top. This code
# not only depends on the exact location of things, but also on the
# implementation of tcltest. Any changes and these tests will have to
# be updated.
proc etrace {} {
set res {}
set level [info frame]
while {$level} {
lappend res [list $level [reduce [info frame $level]]]
incr level -1
}
return $res
}
##
test info-22.0.0 {info frame, levels} {tip280 && !singleTestInterp} {
info frame
} 7
test info-22.0.1 {info frame, levels} {tip280 && singleTestInterp} {
info frame
} 10
test info-22.1.0 {info frame, bad level relative} {tip280 && !singleTestInterp} {
# catch is another level!, i.e. we have 8, not 7
catch {info frame -8} msg
set msg
} {bad level "-8"}
test info-22.1.1 {info frame, bad level relative} {tip280 && singleTestInterp} {
# catch is another level!, i.e. we have 11, not 10
catch {info frame -11} msg
set msg
} {bad level "-11"}
test info-22.2.0 {info frame, bad level absolute} {tip280 && !singleTestInterp} {
# catch is another level!, i.e. we have 8, not 7
catch {info frame 9} msg
set msg
} {bad level "9"}
test info-22.2.1 {info frame, bad level absolute} {tip280 && singleTestInterp} {
# catch is another level!, i.e. we have 12, not 10
catch {info frame 12} msg
set msg
} {bad level "12"}
test info-22.3 {info frame, current, relative} -constraints tip280 -match glob -body {
info frame 0
} -result {type source line 761 file * cmd {info frame 0} proc ::tcltest::RunTest}
test info-22.4 {info frame, current, relative, nested} -constraints tip280 -match glob -body {
set res [info frame 0]
} -result {type source line 765 file * cmd {info frame 0} proc ::tcltest::RunTest}
test info-22.5.0 {info frame, current, absolute} -constraints {tip280 && !singleTestInterp} -match glob -body {
reduce [info frame 7]
} -result {type source line 769 file * cmd {info frame 7} proc ::tcltest::RunTest}
test info-22.5.1 {info frame, current, absolute} -constraints {tip280 && singleTestInterp} -match glob -body {
reduce [info frame 10]
} -result {type source line 772 file * cmd {info frame 10} proc ::tcltest::RunTest}
test info-22.6.0 {info frame, global, relative} {tip280 && !singleTestInterp} {
reduce [info frame -6]
} {type source line 775 file info.test cmd test\ info-22.6.0\ \{info\ frame,\ global,\ relative\}\ \{tip280\ &&\ !singleTe}
test info-22.6.1 {info frame, global, relative} {tip280 && singleTestInterp} {
reduce [info frame -6]
} {type source line 778 file info.test cmd test\ info-22.6.1\ \{info\ frame,\ global,\ relative\}\ \{tip280\ &&\ singleTe proc ::tcltest::runAllTests}
test info-22.7.0 {info frame, global, absolute} {tip280 && !singleTestInterp} {
reduce [info frame 1]
} {type source line 782 file info.test cmd test\ info-22.7.0\ \{info\ frame,\ global,\ absolute\}\ \{tip280\ &&\ !singleTe}
test info-22.7.1 {info frame, global, absolute} {tip280 && singleTestInterp} {
reduce [info frame 4]
} {type source line 785 file info.test cmd test\ info-22.7.1\ \{info\ frame,\ global,\ absolute\}\ \{tip280\ &&\ singleTe proc ::tcltest::runAllTests}
test info-22.8 {info frame, basic trace} -constraints {tip280} -match glob -body {
join [lrange [etrace] 0 1] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 790 file info.test cmd etrace proc ::tcltest::RunTest}}
test info-23.0.0 {eval'd info frame} {tip280 && !singleTestInterp} {
eval {info frame}
} 8
test info-23.0.1 {eval'd info frame} {tip280 && singleTestInterp} {
eval {info frame}
} 11
test info-23.1.0 {eval'd info frame, semi-dynamic} {tip280 && !singleTestInterp} {
eval info frame
} 8
test info-23.1.1 {eval'd info frame, semi-dynamic} {tip280 && singleTestInterp} {
eval info frame
} 11
test info-23.2.0 {eval'd info frame, dynamic} {tip280 && !singleTestInterp} {
set script {info frame}
eval $script
} 8
test info-23.2.1 {eval'd info frame, dynamic} {tip280 && singleTestInterp} {
set script {info frame}
eval $script
} 11
test info-23.3 {eval'd info frame, literal} -constraints tip280 -match glob -body {
eval {
info frame 0
}
} -result {type source line 819 file *info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.4 {eval'd info frame, semi-dynamic} tip280 {
eval info frame 0
} {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.5 {eval'd info frame, dynamic} tip280 {
set script {info frame 0}
eval $script
} {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.6 {eval'd info frame, trace} -constraints {tip280} -match glob -body {
set script {etrace}
join [lrange [eval $script] 0 2] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 834 file info.test cmd {eval $script} proc ::tcltest::RunTest}}
# -------------------------------------------------------------------------
# Procedures defined in scripts which are arguments to control
# structures (like 'namespace eval', 'interp eval', 'if', 'while',
# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute
# location. The command implementations execute such scripts through
# Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This
# causes the connection to the context to be lost. Currently only
# procedure bodies are able to remember their context.
# -------------------------------------------------------------------------
namespace eval foo {
proc bar {} {info frame 0}
}
test info-24.0 {info frame, interaction, namespace eval} tip280 {
reduce [foo::bar]
} {type source line 852 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
set flag 1
if {$flag} {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
}
test info-24.1 {info frame, interaction, if} tip280 {
reduce [foo::bar]
} {type source line 866 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
set flag 1
while {$flag} {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
set flag 0
}
test info-24.2 {info frame, interaction, while} tip280 {
reduce [foo::bar]
} {type source line 880 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
catch {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
}
test info-24.3 {info frame, interaction, catch} tip280 {
reduce [foo::bar]
} {type source line 894 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
foreach var val {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
break
}
test info-24.4 {info frame, interaction, foreach} tip280 {
reduce [foo::bar]
} {type source line 907 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
for {} {1} {} {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
break
}
test info-24.5 {info frame, interaction, for} tip280 {
reduce [foo::bar]
} {type source line 921 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
eval {
proc bar {} {info frame 0}
}
test info-25.0 {info frame, proc in eval} tip280 {
reduce [bar]
} {type source line 934 file info.test cmd {info frame 0} proc ::bar level 0}
proc bar {} {info frame 0}
test info-25.1 {info frame, regular proc} tip280 {
reduce [bar]
} {type source line 941 file info.test cmd {info frame 0} proc ::bar level 0}
rename bar {}
# More info-30.x test cases at the end of the file.
test info-30.0 {bs+nl in literal words} {tip280} {
if {1} {
set res \
[reduce [info frame 0]];# line 952
}
set res
# This was reporting line 3 instead of the correct 4 because the
# bs+nl combination is subst by the parser before the 'if'
# command, and the bcc, see the word. Fixed by recording the
# offsets of all bs+nl sequences in literal words, then using the
# information in the bcc and other places to bump line numbers when
# parsing over the location. Also affected: testcases 22.8 and 23.6.
} {type source line 952 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
# -------------------------------------------------------------------------
# See 24.0 - 24.5 for similar situations, using literal scripts.
set body {set flag 0
set a c
set res [info frame 0]} ;# line 3!
test info-31.0 {ns eval, script in variable} tip280 {set res {}
namespace eval foo $body
set res
} {type eval line 3 cmd {info frame 0} level 0}
catch {namespace delete foo}
test info-31.1 {if, script in variable} tip280 {
if 1 $body
set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
test info-31.1a {if, script in variable} tip280 {
if 1 then $body
set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
test info-31.2 {while, script in variable} tip280 {
set flag 1
while {$flag} $body
set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
# .3 - proc - scoping prevent return of result ...
test info-31.4 {foreach, script in variable} tip280 {
foreach var val $body
set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
test info-31.5 {for, script in variable} tip280 {
set flag 1
for {} {$flag} {} $body
set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
test info-31.6 {eval, script in variable} tip280 {
eval $body
set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
# -------------------------------------------------------------------------
namespace eval foo {}
set x foo
switch -exact -- $x {
foo {
proc ::foo::bar {} {info frame 0}
}
}
test info-24.6.0 {info frame, interaction, switch, list body} tip280 {
reduce [foo::bar]
} {type source line 1021 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
unset x
# -------------------------------------------------------------------------
namespace eval foo {}
set x foo
switch -exact -- $x foo {
proc ::foo::bar {} {info frame 0}
}
test info-24.6.1 {info frame, interaction, switch, multi-body} tip280 {
reduce [foo::bar]
} {type source line 1037 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
unset x
# -------------------------------------------------------------------------
namespace eval foo {}
set x foo
switch -exact -- $x [list foo {
proc ::foo::bar {} {info frame 0}
}]
test info-24.6.2 {info frame, interaction, switch, list body, dynamic} tip280 {
reduce [foo::bar]
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
unset x
# -------------------------------------------------------------------------
set body {
foo {
proc ::foo::bar {} {info frame 0}
}
}
namespace eval foo {}
set x foo
switch -exact -- $x $body
test info-31.7 {info frame, interaction, switch, dynamic} tip280 {
reduce [foo::bar]
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
unset x
# -------------------------------------------------------------------------
set body {
proc ::foo::bar {} {info frame 0}
}
namespace eval foo {}
eval $body
test info-32.0 {info frame, dynamic procedure} tip280 {
reduce [foo::bar]
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
test info-34.0 {eval pure list, single line} -constraints {tip280} -match glob -body {
# Basically, counting the newline in the word seen through $foo
# doesn't really make sense. It makes a bit of sense if the word
# would have been a string literal in the command list.
#
# Problem: At the point where we see the list elements we cannot
# distinguish the two cases, thus we cannot switch between
# count/not-count, it is has to be one or the other for all
# cases. Of the two possibilities miguel convinced me that 'not
# counting' is the more proper.
set foo {b
c}
set cmd [list foreach $foo {x y} {
set res [join [lrange [etrace] 0 2] \n]
break
}]
eval $cmd
set res
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 2 cmd etrace proc ::tcltest::RunTest}
* {type eval line 1 cmd foreac proc ::tcltest::RunTest}}
# -------------------------------------------------------------------------
# 6 cases.
## DV. direct-var - unchanged
## DPV direct-proc-var - ditto
## PPV proc-proc-var - ditto
## DL. direct-literal - now tracking absolute location
## DPL direct-proc-literal - ditto
## PPL proc-proc-literal - ditto
## ### ### ### ######### ######### #########"
proc control {vv script} {
upvar 1 $vv var
return [uplevel 1 $script]
}
proc datal {} {
control y {
set y PPL
etrace
}
}
proc datav {} {
set script {
set y PPV
etrace
}
control y $script
}
test info-38.1 {location information for uplevel, dv, direct-var} -constraints tip280 -match glob -body {
set script {
set y DV.
etrace
}
join [lrange [uplevel \#0 $script] 0 2] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
* {type source line 1156 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}}
test info-38.2 {location information for uplevel, dl, direct-literal} -constraints tip280 -match glob -body {
join [lrange [uplevel \#0 {
set y DL.
etrace
}] 0 2] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1164 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line 1162 file info.test cmd up proc ::tcltest::RunTest}}
test info-38.3 {location information for uplevel, dpv, direct-proc-var} -constraints tip280 -match glob -body {
set script {
set y DPV
etrace
}
join [lrange [control y $script] 0 3] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1175 file info.test cmd {control y $script} proc ::tcltest::RunTest}}
test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -constraints tip280 -match glob -body {
join [lrange [control y {
set y DPL
etrace
}] 0 3] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1184 file info.test cmd etrace proc ::control}
* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1182 file info.test cmd control proc ::tcltest::RunTest}}
test info-38.5 {location information for uplevel, ppv, proc-proc-var} -constraints tip280 -match glob -body {
join [lrange [datav] 0 4] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1148 file info.test cmd {control y $script} proc ::datav level 1}
* {type source line 1192 file info.test cmd datav proc ::tcltest::RunTest}}
test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -constraints tip280 -match glob -body {
join [lrange [datal] 0 4] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1139 file info.test cmd etrace proc ::control}
* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1137 file info.test cmd control proc ::datal level 1}
* {type source line 1200 file info.test cmd datal proc ::tcltest::RunTest}}
# -------------------------------------------------------------------------
# literal sharing
test info-39.0 {location information not confused by literal sharing} -constraints tip280 -body {
namespace eval ::foo {}
proc ::foo::bar {} {
lappend res {}
lappend res [reduce [eval {info frame 0}]]
lappend res [reduce [eval {info frame 0}]]
return $res
}
set res [::foo::bar]
namespace delete ::foo
join $res \n
} -result {
type source line 1214 file info.test cmd {info frame 0} proc ::foo::bar level 0
type source line 1215 file info.test cmd {info frame 0} proc ::foo::bar level 0}
# -------------------------------------------------------------------------
# Additional tests for info-30.*, handling of continuation lines (bs+nl sequences).
test info-30.1 {bs+nl in literal words, procedure body, compiled} {tip280} {
proc abra {} {
if {1} \
{
return \
[reduce [info frame 0]];# line 1233
}
}
set res [abra]
rename abra {}
set res
} {type source line 1233 file info.test cmd {info frame 0} proc ::abra level 0}
test info-30.2 {bs+nl in literal words, namespace script} {tip280} {
namespace eval xxx {
set res \
[reduce [info frame 0]];# line 1244
}
set res
} {type source line 1244 file info.test cmd {info frame 0} level 0}
test info-30.3 {bs+nl in literal words, namespace multi-word script} {tip280} {
namespace eval xxx set res \
[list [reduce [info frame 0]]];# line 1251
set res
} {type source line 1251 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.4 {bs+nl in literal words, eval script} {tip280} {
eval {
set ::res \
[reduce [info frame 0]];# line 1258
}
set res
} {type source line 1258 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.5 {bs+nl in literal words, eval script, with nested words} {tip280} {
eval {
if {1} \
{
set ::res \
[reduce [info frame 0]];# line 1268
}
}
set res
} {type source line 1268 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.6 {bs+nl in computed word} {tip280} {
set res "\
[reduce [info frame 0]]";# line 1276
} { type source line 1276 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.7 {bs+nl in computed word, in proc} {tip280} {
proc abra {} {
return "\
[reduce [info frame 0]]";# line 1282
}
set res [abra]
rename abra {}
set res
} { type source line 1282 file info.test cmd {info frame 0} proc ::abra level 0}
test info-30.8 {bs+nl in computed word, nested eval} {tip280} {
eval {
set \
res "\
[reduce [info frame 0]]";# line 1293
}
} { type source line 1293 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.9 {bs+nl in computed word, nested eval} {tip280} {
eval {
set \
res "\
[reduce \
[info frame 0]]";# line 1302
}
} { type source line 1302 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.10 {bs+nl in computed word, key to array} {tip280} {
set tmp([set \
res "\
[reduce \
[info frame 0]]"]) x ; #1310
unset tmp
set res
} { type source line 1310 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.11 {bs+nl in subst arguments, no true counting} {tip280} {
subst {[set \
res "\
[reduce \
[info frame 0]]"]}
} { type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.12 {bs+nl in computed word, nested eval} {tip280} {
eval {
set \
res "\
[set x {}] \
[reduce \
[info frame 0]]";# line 1328
}
} { type source line 1328 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.13 {bs+nl in literal words, uplevel script, with nested words} {tip280} {
uplevel #0 {
if {1} \
{
set ::res \
[reduce [info frame 0]];# line 1337
}
}
set res
} {type source line 1337 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.14 {bs+nl, literal word, uplevel through proc} {tip280} {
proc abra {script} {
uplevel 1 $script
}
set res [abra {
return "\
[reduce [info frame 0]]";# line 1349
}]
rename abra {}
set res
} { type source line 1349 file info.test cmd {info frame 0} proc ::abra}
test info-30.15 {bs+nl in literal words, nested proc body, compiled} {tip280} {
proc a {} {
proc b {} {
if {1} \
{
return \
[reduce [info frame 0]];# line 1361
}
}
}
a ; set res [b]
rename a {}
rename b {}
set res
} {type source line 1361 file info.test cmd {info frame 0} proc ::b level 0}
test info-30.16 {bs+nl in multi-body switch, compiled} {tip280} {
proc a {value} {
switch -regexp -- $value \
^key { info frame 0; # 1374 } \
\t { info frame 0; # 1375 } \
{[0-9]*} { info frame 0; # 1376 }
}
set res {}
lappend res [reduce [a {key }]]
lappend res [reduce [a {1alpha}]]
set res "\n[join $res \n]"
} {
type source line 1374 file info.test cmd {info frame 0} proc ::a level 0
type source line 1376 file info.test cmd {info frame 0} proc ::a level 0}
test info-30.17 {bs+nl in multi-body switch, direct} {tip280} {
switch -regexp -- {key } \
^key { reduce [info frame 0] ;# 1388 } \
\t### { } \
{[0-9]*} { }
} {type source line 1388 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} {tip280} {
proc abra {script} {
append script "\n# end of script"
uplevel 1 $script
}
set res [abra {
return "\
[reduce [info frame 0]]";# line 1400, still line of 3 appended script
}]
rename abra {}
set res
} { type eval line 3 cmd {info frame 0} proc ::abra}
# { type source line 1400 file info.test cmd {info frame 0} proc ::abra}
test info-30.19 {bs+nl in single-body switch, compiled} {tip280} {
proc a {value} {
switch -regexp -- $value {
^key { reduce \
[info frame 0] }
\t { reduce \
[info frame 0] }
{[0-9]*} { reduce \
[info frame 0] }
}
}
set res {}
lappend res [a {key }]
lappend res [a {1alpha}]
set res "\n[join $res \n]"
} {
type source line 1411 file info.test cmd {info frame 0} proc ::a level 0
type source line 1415 file info.test cmd {info frame 0} proc ::a level 0}
test info-30.20 {bs+nl in single-body switch, direct} {tip280} {
switch -regexp -- {key } { \
^key { reduce \
[info frame 0] }
\t { }
{[0-9]*} { }
}
} {type source line 1430 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.21 {bs+nl in if, full compiled} {tip280} {
proc a {value} {
if {$value} \
{info frame 0} \
{info frame 0}
}
set res {}
lappend res [reduce [a 1]]
lappend res [reduce [a 0]]
set res "\n[join $res \n]"
} {
type source line 1439 file info.test cmd {info frame 0} proc ::a level 0
type source line 1440 file info.test cmd {info frame 0} proc ::a level 0}
test info-30.22 {bs+nl in computed word, key to array, compiled} {tip280} {
proc a {} {
set tmp([set \
res "\
[reduce \
[info frame 0]]"]) x ; #1454
unset tmp
set res
}
set res [a]
rename a {}
set res
} { type source line 1455 file info.test cmd {info frame 0} proc ::a level 0}
# -------------------------------------------------------------------------
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
tcl8.4.20/tests/incr.test 0000644 0036047 0045461 00000042043 11737050674 013720 0 ustar dgp 771div # Commands covered: incr
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Basic "incr" operation.
catch {unset x}
catch {unset i}
test incr-1.1 {TclCompileIncrCmd: missing variable name} {
list [catch {incr} msg] $msg
} {1 {wrong # args: should be "incr varName ?increment?"}}
test incr-1.2 {TclCompileIncrCmd: simple variable name} {
set i 10
list [incr i] $i
} {11 11}
test incr-1.3 {TclCompileIncrCmd: error compiling variable name} {
set i 10
catch {incr "i"xxx} msg
set msg
} {extra characters after close-quote}
test incr-1.4 {TclCompileIncrCmd: simple variable name in quotes} {
set i 17
list [incr "i"] $i
} {18 18}
test incr-1.5 {TclCompileIncrCmd: simple variable name in braces} {
catch {unset {a simple var}}
set {a simple var} 27
list [incr {a simple var}] ${a simple var}
} {28 28}
test incr-1.6 {TclCompileIncrCmd: simple array variable name} {
catch {unset a}
set a(foo) 37
list [incr a(foo)] $a(foo)
} {38 38}
test incr-1.7 {TclCompileIncrCmd: non-simple (computed) variable name} {
set x "i"
set i 77
list [incr $x 2] $i
} {79 79}
test incr-1.8 {TclCompileIncrCmd: non-simple (computed) variable name} {
set x "i"
set i 77
list [incr [set x] +2] $i
} {79 79}
test incr-1.9 {TclCompileIncrCmd: increment given} {
set i 10
list [incr i +07] $i
} {17 17}
test incr-1.10 {TclCompileIncrCmd: no increment given} {
set i 10
list [incr i] $i
} {11 11}
test incr-1.11 {TclCompileIncrCmd: simple global name} {
proc p {} {
global i
set i 54
incr i
}
p
} {55}
test incr-1.12 {TclCompileIncrCmd: simple local name} {
proc p {} {
set foo 100
incr foo
}
p
} {101}
test incr-1.13 {TclCompileIncrCmd: simple but new (unknown) local name} {
proc p {} {
incr bar
}
catch {p} msg
set msg
} {can't read "bar": no such variable}
test incr-1.14 {TclCompileIncrCmd: simple local name, >255 locals} {
proc 260locals {} {
# create 260 locals
set a0 0; set a1 0; set a2 0; set a3 0; set a4 0
set a5 0; set a6 0; set a7 0; set a8 0; set a9 0
set b0 0; set b1 0; set b2 0; set b3 0; set b4 0
set b5 0; set b6 0; set b7 0; set b8 0; set b9 0
set c0 0; set c1 0; set c2 0; set c3 0; set c4 0
set c5 0; set c6 0; set c7 0; set c8 0; set c9 0
set d0 0; set d1 0; set d2 0; set d3 0; set d4 0
set d5 0; set d6 0; set d7 0; set d8 0; set d9 0
set e0 0; set e1 0; set e2 0; set e3 0; set e4 0
set e5 0; set e6 0; set e7 0; set e8 0; set e9 0
set f0 0; set f1 0; set f2 0; set f3 0; set f4 0
set f5 0; set f6 0; set f7 0; set f8 0; set f9 0
set g0 0; set g1 0; set g2 0; set g3 0; set g4 0
set g5 0; set g6 0; set g7 0; set g8 0; set g9 0
set h0 0; set h1 0; set h2 0; set h3 0; set h4 0
set h5 0; set h6 0; set h7 0; set h8 0; set h9 0
set i0 0; set i1 0; set i2 0; set i3 0; set i4 0
set i5 0; set i6 0; set i7 0; set i8 0; set i9 0
set j0 0; set j1 0; set j2 0; set j3 0; set j4 0
set j5 0; set j6 0; set j7 0; set j8 0; set j9 0
set k0 0; set k1 0; set k2 0; set k3 0; set k4 0
set k5 0; set k6 0; set k7 0; set k8 0; set k9 0
set l0 0; set l1 0; set l2 0; set l3 0; set l4 0
set l5 0; set l6 0; set l7 0; set l8 0; set l9 0
set m0 0; set m1 0; set m2 0; set m3 0; set m4 0
set m5 0; set m6 0; set m7 0; set m8 0; set m9 0
set n0 0; set n1 0; set n2 0; set n3 0; set n4 0
set n5 0; set n6 0; set n7 0; set n8 0; set n9 0
set o0 0; set o1 0; set o2 0; set o3 0; set o4 0
set o5 0; set o6 0; set o7 0; set o8 0; set o9 0
set p0 0; set p1 0; set p2 0; set p3 0; set p4 0
set p5 0; set p6 0; set p7 0; set p8 0; set p9 0
set q0 0; set q1 0; set q2 0; set q3 0; set q4 0
set q5 0; set q6 0; set q7 0; set q8 0; set q9 0
set r0 0; set r1 0; set r2 0; set r3 0; set r4 0
set r5 0; set r6 0; set r7 0; set r8 0; set r9 0
set s0 0; set s1 0; set s2 0; set s3 0; set s4 0
set s5 0; set s6 0; set s7 0; set s8 0; set s9 0
set t0 0; set t1 0; set t2 0; set t3 0; set t4 0
set t5 0; set t6 0; set t7 0; set t8 0; set t9 0
set u0 0; set u1 0; set u2 0; set u3 0; set u4 0
set u5 0; set u6 0; set u7 0; set u8 0; set u9 0
set v0 0; set v1 0; set v2 0; set v3 0; set v4 0
set v5 0; set v6 0; set v7 0; set v8 0; set v9 0
set w0 0; set w1 0; set w2 0; set w3 0; set w4 0
set w5 0; set w6 0; set w7 0; set w8 0; set w9 0
set x0 0; set x1 0; set x2 0; set x3 0; set x4 0
set x5 0; set x6 0; set x7 0; set x8 0; set x9 0
set y0 0; set y1 0; set y2 0; set y3 0; set y4 0
set y5 0; set y6 0; set y7 0; set y8 0; set y9 0
set z0 0; set z1 0; set z2 0; set z3 0; set z4 0
set z5 0; set z6 0; set z7 0; set z8 0; set z9 0
# now increment the last one (local var index > 255)
incr z9
}
260locals
} {1}
test incr-1.15 {TclCompileIncrCmd: variable is array} {
catch {unset a}
set a(foo) 27
set x [incr a(foo) 11]
catch {unset a}
set x
} 38
test incr-1.16 {TclCompileIncrCmd: variable is array, elem substitutions} {
catch {unset a}
set i 5
set a(foo5) 27
set x [incr a(foo$i) 11]
catch {unset a}
set x
} 38
test incr-1.17 {TclCompileIncrCmd: increment given, simple int} {
set i 5
incr i 123
} 128
test incr-1.18 {TclCompileIncrCmd: increment given, simple int} {
set i 5
incr i -100
} -95
test incr-1.19 {TclCompileIncrCmd: increment given, but erroneous} {
set i 5
catch {incr i [set]} msg
set errorInfo
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
while compiling
"incr i [set]"}
test incr-1.20 {TclCompileIncrCmd: increment given, in quotes} {
set i 25
incr i "-100"
} -75
test incr-1.21 {TclCompileIncrCmd: increment given, in braces} {
set i 24
incr i {126}
} 150
test incr-1.22 {TclCompileIncrCmd: increment given, large int} {
set i 5
incr i 200000
} 200005
test incr-1.23 {TclCompileIncrCmd: increment given, formatted int != int} {
set i 25
incr i 000012345 ;# an octal literal
} 5374
test incr-1.24 {TclCompileIncrCmd: increment given, formatted int != int} {
set i 25
catch {incr i 1a} msg
set msg
} {expected integer but got "1a"}
test incr-1.25 {TclCompileIncrCmd: too many arguments} {
set i 10
catch {incr i 10 20} msg
set msg
} {wrong # args: should be "incr varName ?increment?"}
test incr-1.26 {TclCompileIncrCmd: runtime error, bad variable name} {
list [catch {incr {"foo}} msg] $msg $errorInfo
} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable
(reading value of variable to increment)
invoked from within
"incr {"foo}"}}
test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} {
list [catch {incr [set]} msg] $msg $errorInfo
} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
while compiling
"incr [set]"}}
test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} {
proc readonly args {error "variable is read-only"}
set x 123
trace var x w readonly
list [catch {incr x 1} msg] $msg $errorInfo
} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only
while executing
"incr x 1"}}
catch {unset x}
test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} {
set x " - "
list [catch {incr x 1} msg] $msg
} {1 {expected integer but got " - "}}
test incr-1.30 {TclCompileIncrCmd: array var, braced (no subs)} {
catch {unset array}
set array(\$foo) 4
incr {array($foo)}
} 5
# Check "incr" and computed command names.
test incr-2.0 {incr and computed command names} {
set i 5
set z incr
$z i -1
set i
} 4
catch {unset x}
catch {unset i}
test incr-2.1 {incr command (not compiled): missing variable name} {
set z incr
list [catch {$z} msg] $msg
} {1 {wrong # args: should be "incr varName ?increment?"}}
test incr-2.2 {incr command (not compiled): simple variable name} {
set z incr
set i 10
list [$z i] $i
} {11 11}
test incr-2.3 {incr command (not compiled): error compiling variable name} {
set z incr
set i 10
catch {$z "i"xxx} msg
set msg
} {extra characters after close-quote}
test incr-2.4 {incr command (not compiled): simple variable name in quotes} {
set z incr
set i 17
list [$z "i"] $i
} {18 18}
test incr-2.5 {incr command (not compiled): simple variable name in braces} {
set z incr
catch {unset {a simple var}}
set {a simple var} 27
list [$z {a simple var}] ${a simple var}
} {28 28}
test incr-2.6 {incr command (not compiled): simple array variable name} {
set z incr
catch {unset a}
set a(foo) 37
list [$z a(foo)] $a(foo)
} {38 38}
test incr-2.7 {incr command (not compiled): non-simple (computed) variable name} {
set z incr
set x "i"
set i 77
list [$z $x 2] $i
} {79 79}
test incr-2.8 {incr command (not compiled): non-simple (computed) variable name} {
set z incr
set x "i"
set i 77
list [$z [set x] +2] $i
} {79 79}
test incr-2.9 {incr command (not compiled): increment given} {
set z incr
set i 10
list [$z i +07] $i
} {17 17}
test incr-2.10 {incr command (not compiled): no increment given} {
set z incr
set i 10
list [$z i] $i
} {11 11}
test incr-2.11 {incr command (not compiled): simple global name} {
proc p {} {
set z incr
global i
set i 54
$z i
}
p
} {55}
test incr-2.12 {incr command (not compiled): simple local name} {
proc p {} {
set z incr
set foo 100
$z foo
}
p
} {101}
test incr-2.13 {incr command (not compiled): simple but new (unknown) local name} {
proc p {} {
set z incr
$z bar
}
catch {p} msg
set msg
} {can't read "bar": no such variable}
test incr-2.14 {incr command (not compiled): simple local name, >255 locals} {
proc 260locals {} {
set z incr
# create 260 locals
set a0 0; set a1 0; set a2 0; set a3 0; set a4 0
set a5 0; set a6 0; set a7 0; set a8 0; set a9 0
set b0 0; set b1 0; set b2 0; set b3 0; set b4 0
set b5 0; set b6 0; set b7 0; set b8 0; set b9 0
set c0 0; set c1 0; set c2 0; set c3 0; set c4 0
set c5 0; set c6 0; set c7 0; set c8 0; set c9 0
set d0 0; set d1 0; set d2 0; set d3 0; set d4 0
set d5 0; set d6 0; set d7 0; set d8 0; set d9 0
set e0 0; set e1 0; set e2 0; set e3 0; set e4 0
set e5 0; set e6 0; set e7 0; set e8 0; set e9 0
set f0 0; set f1 0; set f2 0; set f3 0; set f4 0
set f5 0; set f6 0; set f7 0; set f8 0; set f9 0
set g0 0; set g1 0; set g2 0; set g3 0; set g4 0
set g5 0; set g6 0; set g7 0; set g8 0; set g9 0
set h0 0; set h1 0; set h2 0; set h3 0; set h4 0
set h5 0; set h6 0; set h7 0; set h8 0; set h9 0
set i0 0; set i1 0; set i2 0; set i3 0; set i4 0
set i5 0; set i6 0; set i7 0; set i8 0; set i9 0
set j0 0; set j1 0; set j2 0; set j3 0; set j4 0
set j5 0; set j6 0; set j7 0; set j8 0; set j9 0
set k0 0; set k1 0; set k2 0; set k3 0; set k4 0
set k5 0; set k6 0; set k7 0; set k8 0; set k9 0
set l0 0; set l1 0; set l2 0; set l3 0; set l4 0
set l5 0; set l6 0; set l7 0; set l8 0; set l9 0
set m0 0; set m1 0; set m2 0; set m3 0; set m4 0
set m5 0; set m6 0; set m7 0; set m8 0; set m9 0
set n0 0; set n1 0; set n2 0; set n3 0; set n4 0
set n5 0; set n6 0; set n7 0; set n8 0; set n9 0
set o0 0; set o1 0; set o2 0; set o3 0; set o4 0
set o5 0; set o6 0; set o7 0; set o8 0; set o9 0
set p0 0; set p1 0; set p2 0; set p3 0; set p4 0
set p5 0; set p6 0; set p7 0; set p8 0; set p9 0
set q0 0; set q1 0; set q2 0; set q3 0; set q4 0
set q5 0; set q6 0; set q7 0; set q8 0; set q9 0
set r0 0; set r1 0; set r2 0; set r3 0; set r4 0
set r5 0; set r6 0; set r7 0; set r8 0; set r9 0
set s0 0; set s1 0; set s2 0; set s3 0; set s4 0
set s5 0; set s6 0; set s7 0; set s8 0; set s9 0
set t0 0; set t1 0; set t2 0; set t3 0; set t4 0
set t5 0; set t6 0; set t7 0; set t8 0; set t9 0
set u0 0; set u1 0; set u2 0; set u3 0; set u4 0
set u5 0; set u6 0; set u7 0; set u8 0; set u9 0
set v0 0; set v1 0; set v2 0; set v3 0; set v4 0
set v5 0; set v6 0; set v7 0; set v8 0; set v9 0
set w0 0; set w1 0; set w2 0; set w3 0; set w4 0
set w5 0; set w6 0; set w7 0; set w8 0; set w9 0
set x0 0; set x1 0; set x2 0; set x3 0; set x4 0
set x5 0; set x6 0; set x7 0; set x8 0; set x9 0
set y0 0; set y1 0; set y2 0; set y3 0; set y4 0
set y5 0; set y6 0; set y7 0; set y8 0; set y9 0
set z0 0; set z1 0; set z2 0; set z3 0; set z4 0
set z5 0; set z6 0; set z7 0; set z8 0; set z9 0
# now increment the last one (local var index > 255)
$z z9
}
260locals
} {1}
test incr-2.15 {incr command (not compiled): variable is array} {
set z incr
catch {unset a}
set a(foo) 27
set x [$z a(foo) 11]
catch {unset a}
set x
} 38
test incr-2.16 {incr command (not compiled): variable is array, elem substitutions} {
set z incr
catch {unset a}
set i 5
set a(foo5) 27
set x [$z a(foo$i) 11]
catch {unset a}
set x
} 38
test incr-2.17 {incr command (not compiled): increment given, simple int} {
set z incr
set i 5
$z i 123
} 128
test incr-2.18 {incr command (not compiled): increment given, simple int} {
set z incr
set i 5
$z i -100
} -95
test incr-2.19 {incr command (not compiled): increment given, but erroneous} {
set z incr
set i 5
catch {$z i [set]} msg
set errorInfo
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
while compiling
"$z i [set]"}
test incr-2.20 {incr command (not compiled): increment given, in quotes} {
set z incr
set i 25
$z i "-100"
} -75
test incr-2.21 {incr command (not compiled): increment given, in braces} {
set z incr
set i 24
$z i {126}
} 150
test incr-2.22 {incr command (not compiled): increment given, large int} {
set z incr
set i 5
$z i 200000
} 200005
test incr-2.23 {incr command (not compiled): increment given, formatted int != int} {
set z incr
set i 25
$z i 000012345 ;# an octal literal
} 5374
test incr-2.24 {incr command (not compiled): increment given, formatted int != int} {
set z incr
set i 25
catch {$z i 1a} msg
set msg
} {expected integer but got "1a"}
test incr-2.25 {incr command (not compiled): too many arguments} {
set z incr
set i 10
catch {$z i 10 20} msg
set msg
} {wrong # args: should be "incr varName ?increment?"}
test incr-2.26 {incr command (not compiled): runtime error, bad variable name} {
set z incr
list [catch {$z {"foo}} msg] $msg $errorInfo
} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable
(reading value of variable to increment)
invoked from within
"$z {"foo}"}}
test incr-2.27 {incr command (not compiled): runtime error, bad variable name} {
set z incr
list [catch {$z [set]} msg] $msg $errorInfo
} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
while compiling
"$z [set]"}}
test incr-2.28 {incr command (not compiled): runtime error, readonly variable} {
set z incr
proc readonly args {error "variable is read-only"}
set x 123
trace var x w readonly
list [catch {$z x 1} msg] $msg $errorInfo
} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only
while executing
"$z x 1"}}
catch {unset x}
test incr-2.29 {incr command (not compiled): runtime error, bad variable value} {
set z incr
set x " - "
list [catch {$z x 1} msg] $msg
} {1 {expected integer but got " - "}}
test incr-2.30 {incr command (not compiled): bad increment} {
set z incr
set x 0
list [catch {$z x 1a} msg] $msg $errorInfo
} {1 {expected integer but got "1a"} {expected integer but got "1a"
(reading increment)
invoked from within
"$z x 1a"}}
test incr-2.31 {incr command (compiled): bad increment} {
list [catch {incr x 1a} msg] $msg $errorInfo
} {1 {expected integer but got "1a"} {expected integer but got "1a"
(reading increment)
invoked from within
"incr x 1a"}}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/thread.test 0000644 0036047 0045461 00000016540 11737050674 014237 0 ustar dgp 771div # Commands covered: (test)thread
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Some tests require the testthread command
set ::tcltest::testConstraints(testthread) \
[expr {[info commands testthread] != {}}]
if {$::tcltest::testConstraints(testthread)} {
testthread errorproc ThreadError
proc ThreadError {id info} {
global threadError
set threadError $info
}
proc ThreadNullError {id info} {
# ignore
}
}
test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} {
list [catch {testthread} msg] $msg
} {1 {wrong # args: should be "testthread option ?args?"}}
test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} {
list [catch {testthread foo} msg] $msg
} {1 {bad option "foo": must be create, exit, id, join, names, send, wait, or errorproc}}
test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {testthread} {
list [threadReap] [llength [testthread names]]
} {1 1}
test thread-1.4 {Tcl_ThreadObjCmd: thread create } {testthread} {
threadReap
set serverthread [testthread create]
update
set numthreads [llength [testthread names]]
threadReap
set numthreads
} {2}
test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {testthread} {
threadReap
testthread create {set x 5}
foreach try {0 1 2 4 5 6} {
# Try various ways to yield
update
after 10
set l [llength [testthread names]]
if {$l == 1} {
break
}
}
threadReap
set l
} {1}
test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} {
threadReap
testthread create {testthread exit}
update
after 10
set result [llength [testthread names]]
threadReap
set result
} {1}
test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} {
set x [catch {testthread id x} msg]
list $x $msg
} {1 {wrong # args: should be "testthread id"}}
test thread-1.8 {Tcl_ThreadObjCmd: thread id} {testthread} {
string compare [testthread id] $::tcltest::mainThread
} {0}
test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {testthread} {
set x [catch {testthread names x} msg]
list $x $msg
} {1 {wrong # args: should be "testthread names"}}
test thread-1.10 {Tcl_ThreadObjCmd: thread id} {testthread} {
string compare [testthread names] $::tcltest::mainThread
} {0}
test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} {
set x [catch {testthread send} msg]
list $x $msg
} {1 {wrong # args: should be "testthread send ?-async? id script"}}
test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {testthread} {
set x [catch {testthread send abc command} msg]
list $x $msg
} {1 {expected integer but got "abc"}}
test thread-1.13 {Tcl_ThreadObjCmd: send args} {testthread} {
threadReap
set serverthread [testthread create]
set five [testthread send $serverthread {set x 5}]
threadReap
set five
} 5
test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
set tid [expr $::tcltest::mainThread + 10]
set x [catch {testthread send $tid {set x 5}} msg]
list $x $msg
} {1 {invalid thread id}}
test thread-1.15 {Tcl_ThreadObjCmd: wait} {testthread} {
threadReap
set serverthread [testthread create {set z 5 ; testthread wait}]
set five [testthread send $serverthread {set z}]
threadReap
set five
} 5
test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {testthread} {
set x [catch {testthread errorproc foo bar} msg]
list $x $msg
} {1 {wrong # args: should be "testthread errorproc proc"}}
test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {testthread} {
testthread errorproc foo
testthread errorproc ThreadError
} {}
# The tests above also cover:
# TclCreateThread, except when pthread_create fails
# NewThread, safe and regular
# ThreadErrorProc, except for printing to standard error
test thread-2.1 {ListUpdateInner and ListRemove} {testthread} {
threadReap
catch {unset tid}
foreach t {0 1 2} {
upvar #0 t$t tid
set tid [testthread create]
}
threadReap
} 1
test thread-3.1 {TclThreadList} {testthread} {
threadReap
catch {unset tid}
set len [llength [testthread names]]
set l1 {}
foreach t {0 1 2} {
lappend l1 [testthread create]
}
set l2 [testthread names]
list $l1 $l2
set c [string compare \
[lsort -integer [concat $::tcltest::mainThread $l1]] \
[lsort -integer $l2]]
threadReap
list $len $c
} {1 0}
test thread-4.1 {TclThreadSend to self} {testthread} {
catch {unset x}
testthread send [testthread id] {
set x 4
}
set x
} {4}
test thread-4.2 {TclThreadSend -async} {testthread} {
threadReap
set len [llength [testthread names]]
set serverthread [testthread create]
testthread send -async $serverthread {
after 1000
testthread exit
}
set two [llength [testthread names]]
after 1500 {set done 1}
vwait done
threadReap
list $len [llength [testthread names]] $two
} {1 1 2}
test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
threadReap
set len [llength [testthread names]]
set serverthread [testthread create]
set x [catch {testthread send $serverthread {set undef}} msg]
set savedErrorInfo $errorInfo
threadReap
list $len $x $msg $savedErrorInfo
} {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable
while executing
"set undef"
invoked from within
"testthread send $serverthread {set undef}"}}
test thread-4.4 {TclThreadSend preserve code} {testthread} {
threadReap
set len [llength [testthread names]]
set serverthread [testthread create]
set x [catch {testthread send $serverthread {break}} msg]
set savedErrorInfo $errorInfo
threadReap
list $len $x $msg $savedErrorInfo
} {1 3 {} {}}
test thread-4.5 {TclThreadSend preserve errorCode} {testthread} {
threadReap
set ::tcltest::mainThread [testthread names]
set serverthread [testthread create]
set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
set savedErrorCode $errorCode
threadReap
list $x $msg $savedErrorCode
} {1 ERR CODE}
test thread-5.0 {Joining threads} {testthread} {
threadReap
set serverthread [testthread create -joinable]
testthread send -async $serverthread {after 1000 ; testthread exit}
set res [testthread join $serverthread]
threadReap
set res
} {0}
test thread-5.1 {Joining threads after the fact} {testthread} {
threadReap
set serverthread [testthread create -joinable]
testthread send -async $serverthread {testthread exit}
after 2000
set res [testthread join $serverthread]
threadReap
set res
} {0}
test thread-5.2 {Try to join a detached thread} {testthread} {
threadReap
set serverthread [testthread create]
testthread send -async $serverthread {after 1000 ; testthread exit}
catch {set res [testthread join $serverthread]} msg
threadReap
lrange $msg 0 2
} {cannot join thread}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/package.test 0000644 0036047 0045461 00000007324 11737050674 014363 0 ustar dgp 771div # This file contains tests for the ::package::* commands.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test package-1.1 {pkg::create gives error on insufficient args} {
catch {::pkg::create}
} 1
test package-1.2 {pkg::create gives error on bad args} {
catch {::pkg::create -foo bar -bar baz -baz boo}
} 1
test package-1.3 {pkg::create gives error on no value given} {
catch {::pkg::create -name foo -version 1.0 -source test.tcl -load}
} 1
test package-1.4 {pkg::create gives error on no name given} {
catch {::pkg::create -version 1.0 -source test.tcl -load foo.so}
} 1
test package-1.5 {pkg::create gives error on no version given} {
catch {::pkg::create -name foo -source test.tcl -load foo.so}
} 1
test package-1.6 {pkg::create gives error on no source or load options} {
catch {::pkg::create -name foo -version 1.0 -version 2.0}
} 1
test package-1.7 {pkg::create gives correct output for 1 direct source} {
::pkg::create -name foo -version 1.0 -source test.tcl
} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]}
test package-1.8 {pkg::create gives correct output for 2 direct sources} {
::pkg::create -name foo -version 1.0 -source test.tcl -source test2.tcl
} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]\n[list source [file join $dir test2.tcl]]}
test package-1.9 {pkg::create gives correct output for 1 direct load} {
::pkg::create -name foo -version 1.0 -load test.so
} {package ifneeded foo 1.0 [list load [file join $dir test.so]]}
test package-1.10 {pkg::create gives correct output for 2 direct loads} {
::pkg::create -name foo -version 1.0 -load test.so -load test2.so
} {package ifneeded foo 1.0 [list load [file join $dir test.so]]\n[list load [file join $dir test2.so]]}
test package-1.11 {pkg::create gives correct output for 1 lazy source} {
::pkg::create -name foo -version 1.0 -source {test.tcl {foo bar}}
} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.tcl source {foo bar}}}]}
test package-1.12 {pkg::create gives correct output for 2 lazy sources} {
::pkg::create -name foo -version 1.0 -source {test.tcl {foo bar}} \
-source {test2.tcl {baz boo}}
} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.tcl source {foo bar}} {test2.tcl source {baz boo}}}]}
test package-1.13 {pkg::create gives correct output for 1 lazy load} {
::pkg::create -name foo -version 1.0 -load {test.so {foo bar}}
} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.so load {foo bar}}}]}
test package-1.14 {pkg::create gives correct output for 2 lazy loads} {
::pkg::create -name foo -version 1.0 -load {test.so {foo bar}} \
-load {test2.so {baz boo}}
} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.so load {foo bar}} {test2.so load {baz boo}}}]}
test package-1.15 {pkg::create gives correct output for 1 each, direct} {
::pkg::create -name foo -version 1.0 -source test.tcl -load test2.so
} {package ifneeded foo 1.0 [list load [file join $dir test2.so]]\n[list source [file join $dir test.tcl]]}
test package-1.16 {pkg::create gives correct output for 1 direct, 1 lazy} {
::pkg::create -name foo -version 1.0 -source test.tcl \
-source {test2.tcl {foo bar}}
} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]\n[list tclPkgSetup $dir foo 1.0 {{test2.tcl source {foo bar}}}]}
::tcltest::cleanupTests
return
tcl8.4.20/tests/lsearch.test 0000644 0036047 0045461 00000027551 11737050674 014415 0 ustar dgp 771div # Commands covered: lsearch
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
set x {abcd bbcd 123 234 345}
test lsearch-1.1 {lsearch command} {
lsearch $x 123
} 2
test lsearch-1.2 {lsearch command} {
lsearch $x 3456
} -1
test lsearch-1.3 {lsearch command} {
lsearch $x *5
} 4
test lsearch-1.4 {lsearch command} {
lsearch $x *bc*
} 0
test lsearch-2.1 {search modes} {
lsearch -exact {xyz bbcc *bc*} *bc*
} 2
test lsearch-2.2 {search modes} {
lsearch -exact {b.x ^bc xy bcx} ^bc
} 1
test lsearch-2.3 {search modes} {
lsearch -exact {foo bar cat} ba
} -1
test lsearch-2.4 {search modes} {
lsearch -exact {foo bar cat} bart
} -1
test lsearch-2.5 {search modes} {
lsearch -exact {foo bar cat} bar
} 1
test lsearch-2.6 {search modes} {
list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg] $msg
} {1 {couldn't compile regular expression pattern: quantifier operand invalid}}
test lsearch-2.7 {search modes} {
lsearch -regexp {b.x ^bc xy bcx} ^bc
} 3
test lsearch-2.8 {search modes} {
lsearch -glob {xyz bbcc *bc*} *bc*
} 1
test lsearch-2.9 {search modes} {
lsearch -glob {b.x ^bc xy bcx} ^bc
} 1
test lsearch-2.10 {search modes} {
list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg
} {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -inline, -integer, -not, -real, -regexp, -sorted, or -start}}
test lsearch-3.1 {lsearch errors} {
list [catch lsearch msg] $msg
} {1 {wrong # args: should be "lsearch ?options? list pattern"}}
test lsearch-3.2 {lsearch errors} {
list [catch {lsearch a} msg] $msg
} {1 {wrong # args: should be "lsearch ?options? list pattern"}}
test lsearch-3.3 {lsearch errors} {
list [catch {lsearch a b c} msg] $msg
} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -inline, -integer, -not, -real, -regexp, -sorted, or -start}}
test lsearch-3.4 {lsearch errors} {
list [catch {lsearch a b c d} msg] $msg
} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -inline, -integer, -not, -real, -regexp, -sorted, or -start}}
test lsearch-3.5 {lsearch errors} {
list [catch {lsearch "\{" b} msg] $msg
} {1 {unmatched open brace in list}}
test lsearch-4.1 {binary data} {
lsearch -exact [list foo one\000two bar] bar
} 2
test lsearch-4.2 {binary data} {
set x one
append x \x00
append x two
lsearch -exact [list foo one\000two bar] $x
} 1
# Make a sorted list
set l {}
set l2 {}
for {set i 0} {$i < 100} {incr i} {
lappend l $i
lappend l2 [expr {double($i)/2}]
}
set increasingIntegers [lsort -integer $l]
set decreasingIntegers [lsort -decreasing -integer $l]
set increasingDoubles [lsort -real $l2]
set decreasingDoubles [lsort -decreasing -real $l2]
set increasingStrings [lsort {48 6a 18b 22a 21aa 35 36}]
set decreasingStrings [lsort -decreasing {48 6a 18b 22a 21aa 35 36}]
set increasingDictionary [lsort -dictionary {48 6a 18b 22a 21aa 35 36}]
set decreasingDictionary [lsort -dictionary -decreasing $increasingDictionary]
set l {}
for {set i 0} {$i < 10} {incr i} {
lappend l $i $i $i $i $i
}
set repeatingIncreasingIntegers [lsort -integer $l]
set repeatingDecreasingIntegers [lsort -integer -decreasing $l]
test lsearch-5.1 {binary search} {
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -integer -sorted $increasingIntegers $i]
}
set res
} $increasingIntegers
test lsearch-5.2 {binary search} {
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -integer -decreasing -sorted \
$decreasingIntegers $i]
}
set res
} $decreasingIntegers
test lsearch-5.3 {binary search finds leftmost occurances} {
set res {}
for {set i 0} {$i < 10} {incr i} {
lappend res [lsearch -integer -sorted $repeatingIncreasingIntegers $i]
}
set res
} [list 0 5 10 15 20 25 30 35 40 45]
test lsearch-5.4 {binary search -decreasing finds leftmost occurances} {
set res {}
for {set i 9} {$i >= 0} {incr i -1} {
lappend res [lsearch -sorted -integer -decreasing \
$repeatingDecreasingIntegers $i]
}
set res
} [list 0 5 10 15 20 25 30 35 40 45]
test lsearch-6.1 {integer search} {
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -exact -integer $increasingIntegers $i]
}
set res
} [lrange $increasingIntegers 0 99]
test lsearch-6.2 {decreasing integer search} {
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -exact -integer -decreasing \
$decreasingIntegers $i]
}
set res
} [lrange $decreasingIntegers 0 99]
test lsearch-6.3 {sorted integer search} {
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -sorted -integer $increasingIntegers $i]
}
set res
} [lrange $increasingIntegers 0 99]
test lsearch-6.4 {sorted decreasing integer search} {
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -integer -sorted -decreasing \
$decreasingIntegers $i]
}
set res
} [lrange $decreasingIntegers 0 99]
test lsearch-7.1 {double search} {
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -exact -real $increasingDoubles \
[expr {double($i)/2}]]
}
set res
} [lrange $increasingIntegers 0 99]
test lsearch-7.2 {decreasing double search} {
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -exact -real -decreasing \
$decreasingDoubles [expr {double($i)/2}]]
}
set res
} [lrange $decreasingIntegers 0 99]
test lsearch-7.3 {sorted double search} {
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -sorted -real \
$increasingDoubles [expr {double($i)/2}]]
}
set res
} [lrange $increasingIntegers 0 99]
test lsearch-7.4 {sorted decreasing double search} {
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -sorted -real -decreasing \
$decreasingDoubles [expr {double($i)/2}]]
}
set res
} [lrange $decreasingIntegers 0 99]
test lsearch-8.1 {dictionary search} {
set res {}
foreach val {6a 18b 21aa 22a 35 36 48} {
lappend res [lsearch -exact -dictionary $increasingDictionary $val]
}
set res
} [list 0 1 2 3 4 5 6]
test lsearch-8.2 {decreasing dictionary search} {
set res {}
foreach val {6a 18b 21aa 22a 35 36 48} {
lappend res [lsearch -exact -dictionary $decreasingDictionary $val]
}
set res
} [list 6 5 4 3 2 1 0]
test lsearch-8.3 {sorted dictionary search} {
set res {}
foreach val {6a 18b 21aa 22a 35 36 48} {
lappend res [lsearch -sorted -dictionary $increasingDictionary $val]
}
set res
} [list 0 1 2 3 4 5 6]
test lsearch-8.4 {decreasing sorted dictionary search} {
set res {}
foreach val {6a 18b 21aa 22a 35 36 48} {
lappend res [lsearch -decreasing -sorted -dictionary \
$decreasingDictionary $val]
}
set res
} [list 6 5 4 3 2 1 0]
test lsearch-9.1 {ascii search} {
set res {}
foreach val {18b 21aa 22a 35 36 48 6a} {
lappend res [lsearch -exact -ascii $increasingStrings $val]
}
set res
} [list 0 1 2 3 4 5 6]
test lsearch-9.2 {decreasing ascii search} {
set res {}
foreach val {18b 21aa 22a 35 36 48 6a} {
lappend res [lsearch -exact -ascii $decreasingStrings $val]
}
set res
} [list 6 5 4 3 2 1 0]
test lsearch-9.3 {sorted ascii search} {
set res {}
foreach val {18b 21aa 22a 35 36 48 6a} {
lappend res [lsearch -sorted -ascii $increasingStrings $val]
}
set res
} [list 0 1 2 3 4 5 6]
test lsearch-9.4 {decreasing sorted ascii search} {
set res {}
foreach val {18b 21aa 22a 35 36 48 6a} {
lappend res [lsearch -decreasing -sorted -ascii \
$decreasingStrings $val]
}
set res
} [list 6 5 4 3 2 1 0]
test lsearch-10.1 {offset searching} {
lsearch -start 2 {a b c a b c} a
} 3
test lsearch-10.2 {offset searching} {
lsearch -start 2 {a b c d e f} a
} -1
test lsearch-10.3 {offset searching} {
lsearch -start end-4 {a b c a b c} a
} 3
test lsearch-10.4 {offset searching} {
list [catch {lsearch -start foobar {a b c a b c} a} msg] $msg
} {1 {bad index "foobar": must be integer or end?-integer?}}
test lsearch-10.5 {offset searching} {
list [catch {lsearch -start 1 2} msg] $msg
} {1 {missing starting index}}
test lsearch-10.6 {binary search with offset} {
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -integer -start 2 -sorted $increasingIntegers $i]
}
set res
} [concat -1 -1 [lrange $increasingIntegers 2 end]]
test lsearch-10.7 {offset searching with an empty list} {
# Stop bug #694232 from reocurring
lsearch -start 0 {} x
} -1
test lsearch-10.8 {offset searching past the end of the list} {
# Stop [Bug 1374778] from reoccurring
lsearch -start 10 {a b c} c
} -1
test lsearch-10.9 {offset searching past the end of the list} {
# Stop [Bug 1374778] from reoccurring
lsearch -start 10 -all {a b c} c
} {}
test lsearch-10.10 {offset searching past the end of the list} {
# Stop [Bug 1374778] from reoccurring
lsearch -start 10 -inline {a b c} c
} {}
test lsearch-11.1 {negated searches} {
lsearch -not {a a a b a a a} a
} 3
test lsearch-11.2 {negated searches} {
lsearch -not {a a a a a a a} a
} -1
test lsearch-12.1 {return values instead of indices} {
lsearch -glob -inline {a1 b2 c3 d4} c*
} c3
test lsearch-12.2 {return values instead of indices} {
lsearch -glob -inline {a1 b2 c3 d4} e*
} {}
test lsearch-13.1 {search for all matches} {
lsearch -all {a b a c a d} 1
} {}
test lsearch-13.2 {search for all matches} {
lsearch -all {a b a c a d} a
} {0 2 4}
test lsearch-14.1 {combinations: -all and -inline} {
lsearch -all -inline -glob {a1 b2 a3 c4 a5 d6} a*
} {a1 a3 a5}
test lsearch-14.2 {combinations: -all, -inline and -not} {
lsearch -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {b2 c4 d6}
test lsearch-14.3 {combinations: -all and -not} {
lsearch -all -not -glob {a1 b2 a3 c4 a5 d6} a*
} {1 3 5}
test lsearch-14.4 {combinations: -inline and -not} {
lsearch -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {b2}
test lsearch-14.5 {combinations: -start, -all and -inline} {
lsearch -start 2 -all -inline -glob {a1 b2 a3 c4 a5 d6} a*
} {a3 a5}
test lsearch-14.6 {combinations: -start, -all, -inline and -not} {
lsearch -start 2 -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {c4 d6}
test lsearch-14.7 {combinations: -start, -all and -not} {
lsearch -start 2 -all -not -glob {a1 b2 a3 c4 a5 d6} a*
} {3 5}
test lsearch-14.8 {combinations: -start, -inline and -not} {
lsearch -start 2 -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {c4}
test lsearch-15.1 {make sure no shimmering occurs} {
set x [expr int(sin(0))]
lsearch -start $x $x $x
} 0
test lsearch-16.1 {lsearch -regexp shared object} {
set str a
lsearch -regexp $str $str
} 0
# Bug 1366683
test lsearch-16.2 {lsearch -regexp allows internal backrefs} {
lsearch -regexp {a aa b} {(.)\1}
} 1
test lsearch-21.1 {lsearch shimmering crash} {
set x 0
lsearch -exact -integer $x $x
} 0
test lsearch-21.2 {lsearch shimmering crash} {
set x 0.5
lsearch -exact -real $x $x
} 0
# cleanup
catch {unset res}
catch {unset increasingIntegers}
catch {unset decreasingIntegers}
catch {unset increasingDoubles}
catch {unset decreasingDoubles}
catch {unset increasingStrings}
catch {unset decreasingStrings}
catch {unset increasingDictionary}
catch {unset decreasingDictionary}
::tcltest::cleanupTests
return
tcl8.4.20/tests/foreach.test 0000644 0036047 0045461 00000015050 11737050674 014372 0 ustar dgp 771div # Commands covered: foreach, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-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.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset a}
catch {unset x}
# Basic "foreach" operation.
test foreach-1.1 {basic foreach tests} {
set a {}
foreach i {a b c d} {
set a [concat $a $i]
}
set a
} {a b c d}
test foreach-1.2 {basic foreach tests} {
set a {}
foreach i {a b {{c d} e} {123 {{x}}}} {
set a [concat $a $i]
}
set a
} {a b {c d} e 123 {{x}}}
test foreach-1.3 {basic foreach tests} {catch {foreach} msg} 1
test foreach-1.4 {basic foreach tests} {
catch {foreach} msg
set msg
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
test foreach-1.5 {basic foreach tests} {catch {foreach i} msg} 1
test foreach-1.6 {basic foreach tests} {
catch {foreach i} msg
set msg
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
test foreach-1.7 {basic foreach tests} {catch {foreach i j} msg} 1
test foreach-1.8 {basic foreach tests} {
catch {foreach i j} msg
set msg
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
test foreach-1.9 {basic foreach tests} {catch {foreach i j k l} msg} 1
test foreach-1.10 {basic foreach tests} {
catch {foreach i j k l} msg
set msg
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
test foreach-1.11 {basic foreach tests} {
set a {}
foreach i {} {
set a [concat $a $i]
}
set a
} {}
test foreach-1.12 {foreach errors} {
list [catch {foreach {{a}{b}} {1 2 3} {}} msg] $msg
} {1 {list element in braces followed by "{b}" instead of space}}
test foreach-1.13 {foreach errors} {
list [catch {foreach a {{1 2}3} {}} msg] $msg
} {1 {list element in braces followed by "3" instead of space}}
catch {unset a}
test foreach-1.14 {foreach errors} {
catch {unset a}
set a(0) 44
list [catch {foreach a {1 2 3} {}} msg] $msg
} {1 {couldn't set loop variable: "a"}}
test foreach-1.15 {foreach errors} {
list [catch {foreach {} {} {}} msg] $msg
} {1 {foreach varlist is empty}}
catch {unset a}
test foreach-2.1 {parallel foreach tests} {
set x {}
foreach {a b} {1 2 3 4} {
append x $b $a
}
set x
} {2143}
test foreach-2.2 {parallel foreach tests} {
set x {}
foreach {a b} {1 2 3 4 5} {
append x $b $a
}
set x
} {21435}
test foreach-2.3 {parallel foreach tests} {
set x {}
foreach a {1 2 3} b {4 5 6} {
append x $b $a
}
set x
} {415263}
test foreach-2.4 {parallel foreach tests} {
set x {}
foreach a {1 2 3} b {4 5 6 7 8} {
append x $b $a
}
set x
} {41526378}
test foreach-2.5 {parallel foreach tests} {
set x {}
foreach {a b} {a b A B aa bb} c {c C cc CC} {
append x $a $b $c
}
set x
} {abcABCaabbccCC}
test foreach-2.6 {parallel foreach tests} {
set x {}
foreach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} {
append x $a $b $c $d $e
}
set x
} {111112222233333}
test foreach-2.7 {parallel foreach tests} {
set x {}
foreach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
append x $a $b $c $d $e
}
set x
} {1111 2222334}
test foreach-2.8 {foreach only sets vars if repeating loop} {
proc foo {} {
set rgb {65535 0 0}
foreach {r g b} [set rgb] {}
return "r=$r, g=$g, b=$b"
}
foo
} {r=65535, g=0, b=0}
test foreach-2.9 {foreach only supports local scalar variables} {
proc foo {} {
set x {}
foreach {a(3)} {1 2 3 4} {lappend x [set {a(3)}]}
set x
}
foo
} {1 2 3 4}
test foreach-3.1 {compiled foreach backward jump works correctly} {
catch {unset x}
proc foo {arrayName} {
upvar 1 $arrayName a
set l {}
foreach member [array names a] {
lappend l [list $member [set a($member)]]
}
return $l
}
array set x {0 zero 1 one 2 two 3 three}
lsort [foo x]
} [lsort {{0 zero} {1 one} {2 two} {3 three}}]
test foreach-4.1 {noncompiled foreach and shared variable or value list objects that are converted to another type} {
catch {unset x}
foreach {12.0} {a b c} {
set x 12.0
set x [expr $x + 1]
}
set x
} 13.0
# Check "continue".
test foreach-5.1 {continue tests} {catch continue} 4
test foreach-5.2 {continue tests} {
set a {}
foreach i {a b c d} {
if {[string compare $i "b"] == 0} continue
set a [concat $a $i]
}
set a
} {a c d}
test foreach-5.3 {continue tests} {
set a {}
foreach i {a b c d} {
if {[string compare $i "b"] != 0} continue
set a [concat $a $i]
}
set a
} {b}
test foreach-5.4 {continue tests} {catch {continue foo} msg} 1
test foreach-5.5 {continue tests} {
catch {continue foo} msg
set msg
} {wrong # args: should be "continue"}
# Check "break".
test foreach-6.1 {break tests} {catch break} 3
test foreach-6.2 {break tests} {
set a {}
foreach i {a b c d} {
if {[string compare $i "c"] == 0} break
set a [concat $a $i]
}
set a
} {a b}
test foreach-6.3 {break tests} {catch {break foo} msg} 1
test foreach-6.4 {break tests} {
catch {break foo} msg
set msg
} {wrong # args: should be "break"}
# Check for bug #406709
test foreach-6.5 {break tests} {
proc a {} {
set a 1
foreach b b {list [concat a; break]; incr a}
incr a
}
a
} {2}
# Test for incorrect "double evaluation" semantics
test foreach-7.1 {delayed substitution of body} {
proc foo {} {
set a 0
foreach a [list 1 2 3] "
set x $a
"
set x
}
foo
} {0}
# [Bug 1671138]; infinite loop with empty var list in bytecompiled version
test foreach-9.1 {compiled empty var list} {
proc foo {} {
foreach {} x {
error "reached body"
}
}
list [catch { foo } msg] $msg
} {1 {foreach varlist is empty}}
test foreach-10.1 {foreach: [Bug 1671087]} -setup {
proc demo {} {
set vals {1 2 3 4}
trace add variable x write {string length $vals ;# }
foreach {x y} $vals {format $y}
}
} -body {
demo
} -cleanup {
rename demo {}
} -result {}
# cleanup
catch {unset a}
catch {unset x}
::tcltest::cleanupTests
return
tcl8.4.20/tests/expr-old.test 0000644 0036047 0045461 00000121617 11737050674 014524 0 ustar dgp 771div # Commands covered: expr
#
# This file contains the original set of tests for Tcl's expr command.
# Since the expr command is now compiled, a new set of tests covering
# the new implementation are in the files "parseExpr.test" and
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
set gotT1 0
puts "This application hasn't been compiled with the \"T1\" and"
puts "\"T2\" math functions, so I'll skip some of the expr tests."
} else {
set gotT1 1
}
# First, test all of the integer operators individually.
test expr-old-1.1 {integer operators} {expr -4} -4
test expr-old-1.2 {integer operators} {expr -(1+4)} -5
test expr-old-1.3 {integer operators} {expr ~3} -4
test expr-old-1.4 {integer operators} {expr !2} 0
test expr-old-1.5 {integer operators} {expr !0} 1
test expr-old-1.6 {integer operators} {expr 4*6} 24
test expr-old-1.7 {integer operators} {expr 36/12} 3
test expr-old-1.8 {integer operators} {expr 27/4} 6
test expr-old-1.9 {integer operators} {expr 27%4} 3
test expr-old-1.10 {integer operators} {expr 2+2} 4
test expr-old-1.11 {integer operators} {expr 2-6} -4
test expr-old-1.12 {integer operators} {expr 1<<3} 8
test expr-old-1.13 {integer operators} {expr 0xff>>2} 63
test expr-old-1.14 {integer operators} {expr -1>>2} -1
test expr-old-1.15 {integer operators} {expr 3>2} 1
test expr-old-1.16 {integer operators} {expr 2>2} 0
test expr-old-1.17 {integer operators} {expr 1>2} 0
test expr-old-1.18 {integer operators} {expr 3<2} 0
test expr-old-1.19 {integer operators} {expr 2<2} 0
test expr-old-1.20 {integer operators} {expr 1<2} 1
test expr-old-1.21 {integer operators} {expr 3>=2} 1
test expr-old-1.22 {integer operators} {expr 2>=2} 1
test expr-old-1.23 {integer operators} {expr 1>=2} 0
test expr-old-1.24 {integer operators} {expr 3<=2} 0
test expr-old-1.25 {integer operators} {expr 2<=2} 1
test expr-old-1.26 {integer operators} {expr 1<=2} 1
test expr-old-1.27 {integer operators} {expr 3==2} 0
test expr-old-1.28 {integer operators} {expr 2==2} 1
test expr-old-1.29 {integer operators} {expr 3!=2} 1
test expr-old-1.30 {integer operators} {expr 2!=2} 0
test expr-old-1.31 {integer operators} {expr 7&0x13} 3
test expr-old-1.32 {integer operators} {expr 7^0x13} 20
test expr-old-1.33 {integer operators} {expr 7|0x13} 23
test expr-old-1.34 {integer operators} {expr 0&&1} 0
test expr-old-1.35 {integer operators} {expr 0&&0} 0
test expr-old-1.36 {integer operators} {expr 1&&3} 1
test expr-old-1.37 {integer operators} {expr 0||1} 1
test expr-old-1.38 {integer operators} {expr 3||0} 1
test expr-old-1.39 {integer operators} {expr 0||0} 0
test expr-old-1.40 {integer operators} {expr 3>2?44:66} 44
test expr-old-1.41 {integer operators} {expr 2>3?44:66} 66
test expr-old-1.42 {integer operators} {expr 36/5} 7
test expr-old-1.43 {integer operators} {expr 36%5} 1
test expr-old-1.44 {integer operators} {expr -36/5} -8
test expr-old-1.45 {integer operators} {expr -36%5} 4
test expr-old-1.46 {integer operators} {expr 36/-5} -8
test expr-old-1.47 {integer operators} {expr 36%-5} -4
test expr-old-1.48 {integer operators} {expr -36/-5} 7
test expr-old-1.49 {integer operators} {expr -36%-5} -1
test expr-old-1.50 {integer operators} {expr +36} 36
test expr-old-1.51 {integer operators} {expr +--++36} 36
test expr-old-1.52 {integer operators} {expr +36%+5} 1
test expr-old-1.53 {integer operators} {
catch {unset x}
set x yes
list [expr {1 && $x}] [expr {$x && 1}] \
[expr {0 || $x}] [expr {$x || 0}]
} {1 1 1 1}
# Check the floating-point operators individually, along with
# automatic conversion to integers where needed.
test expr-old-2.1 {floating-point operators} {expr -4.2} -4.2
test expr-old-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3
test expr-old-2.3 {floating-point operators} {expr +5.7} 5.7
test expr-old-2.4 {floating-point operators} {expr +--+-62.0} -62.0
test expr-old-2.5 {floating-point operators} {expr !2.1} 0
test expr-old-2.6 {floating-point operators} {expr !0.0} 1
test expr-old-2.7 {floating-point operators} {expr 4.2*6.3} 26.46
test expr-old-2.8 {floating-point operators} {expr 36.0/12.0} 3.0
test expr-old-2.9 {floating-point operators} {expr 27/4.0} 6.75
test expr-old-2.10 {floating-point operators} {expr 2.3+2.1} 4.4
test expr-old-2.11 {floating-point operators} {expr 2.3-6.5} -4.2
test expr-old-2.12 {floating-point operators} {expr 3.1>2.1} 1
test expr-old-2.13 {floating-point operators} {expr {2.1 > 2.1}} 0
test expr-old-2.14 {floating-point operators} {expr 1.23>2.34e+1} 0
test expr-old-2.15 {floating-point operators} {expr 3.45<2.34} 0
test expr-old-2.16 {floating-point operators} {expr 0.002e3<--200e-2} 0
test expr-old-2.17 {floating-point operators} {expr 1.1<2.1} 1
test expr-old-2.18 {floating-point operators} {expr 3.1>=2.2} 1
test expr-old-2.19 {floating-point operators} {expr 2.345>=2.345} 1
test expr-old-2.20 {floating-point operators} {expr 1.1>=2.2} 0
test expr-old-2.21 {floating-point operators} {expr 3.0<=2.0} 0
test expr-old-2.22 {floating-point operators} {expr 2.2<=2.2} 1
test expr-old-2.23 {floating-point operators} {expr 2.2<=2.2001} 1
test expr-old-2.24 {floating-point operators} {expr 3.2==2.2} 0
test expr-old-2.25 {floating-point operators} {expr 2.2==2.2} 1
test expr-old-2.26 {floating-point operators} {expr 3.2!=2.2} 1
test expr-old-2.27 {floating-point operators} {expr 2.2!=2.2} 0
test expr-old-2.28 {floating-point operators} {expr 0.0&&0.0} 0
test expr-old-2.29 {floating-point operators} {expr 0.0&&1.3} 0
test expr-old-2.30 {floating-point operators} {expr 1.3&&0.0} 0
test expr-old-2.31 {floating-point operators} {expr 1.3&&3.3} 1
test expr-old-2.32 {floating-point operators} {expr 0.0||0.0} 0
test expr-old-2.33 {floating-point operators} {expr 0.0||1.3} 1
test expr-old-2.34 {floating-point operators} {expr 1.3||0.0} 1
test expr-old-2.35 {floating-point operators} {expr 3.3||0.0} 1
test expr-old-2.36 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3
test expr-old-2.37 {floating-point operators} {expr 2.3>3.3?44.3:66.3} 66.3
test expr-old-2.38 {floating-point operators} {
list [catch {expr 028.1 + 09.2} msg] $msg
} {0 37.3}
# Operators that aren't legal on floating-point numbers
test expr-old-3.1 {illegal floating-point operations} {
list [catch {expr ~4.0} msg] $msg
} {1 {can't use floating-point value as operand of "~"}}
test expr-old-3.2 {illegal floating-point operations} {
list [catch {expr 27%4.0} msg] $msg
} {1 {can't use floating-point value as operand of "%"}}
test expr-old-3.3 {illegal floating-point operations} {
list [catch {expr 27.0%4} msg] $msg
} {1 {can't use floating-point value as operand of "%"}}
test expr-old-3.4 {illegal floating-point operations} {
list [catch {expr 1.0<<3} msg] $msg
} {1 {can't use floating-point value as operand of "<<"}}
test expr-old-3.5 {illegal floating-point operations} {
list [catch {expr 3<<1.0} msg] $msg
} {1 {can't use floating-point value as operand of "<<"}}
test expr-old-3.6 {illegal floating-point operations} {
list [catch {expr 24.0>>3} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test expr-old-3.7 {illegal floating-point operations} {
list [catch {expr 24>>3.0} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test expr-old-3.8 {illegal floating-point operations} {
list [catch {expr 24&3.0} msg] $msg
} {1 {can't use floating-point value as operand of "&"}}
test expr-old-3.9 {illegal floating-point operations} {
list [catch {expr 24.0|3} msg] $msg
} {1 {can't use floating-point value as operand of "|"}}
test expr-old-3.10 {illegal floating-point operations} {
list [catch {expr 24.0^3} msg] $msg
} {1 {can't use floating-point value as operand of "^"}}
# Check the string operators individually.
test expr-old-4.1 {string operators} {expr {"abc" > "def"}} 0
test expr-old-4.2 {string operators} {expr {"def" > "def"}} 0
test expr-old-4.3 {string operators} {expr {"g" > "def"}} 1
test expr-old-4.4 {string operators} {expr {"abc" < "abd"}} 1
test expr-old-4.5 {string operators} {expr {"abd" < "abd"}} 0
test expr-old-4.6 {string operators} {expr {"abe" < "abd"}} 0
test expr-old-4.7 {string operators} {expr {"abc" >= "def"}} 0
test expr-old-4.8 {string operators} {expr {"def" >= "def"}} 1
test expr-old-4.9 {string operators} {expr {"g" >= "def"}} 1
test expr-old-4.10 {string operators} {expr {"abc" <= "abd"}} 1
test expr-old-4.11 {string operators} {expr {"abd" <= "abd"}} 1
test expr-old-4.12 {string operators} {expr {"abe" <= "abd"}} 0
test expr-old-4.13 {string operators} {expr {"abc" == "abd"}} 0
test expr-old-4.14 {string operators} {expr {"abd" == "abd"}} 1
test expr-old-4.15 {string operators} {expr {"abc" != "abd"}} 1
test expr-old-4.16 {string operators} {expr {"abd" != "abd"}} 0
test expr-old-4.17 {string operators} {expr {"0y" < "0x12"}} 0
test expr-old-4.18 {string operators} {expr {"." < " "}} 0
test expr-old-4.19 {string operators} {expr {"abc" eq "abd"}} 0
test expr-old-4.20 {string operators} {expr {"abd" eq "abd"}} 1
test expr-old-4.21 {string operators} {expr {"abc" ne "abd"}} 1
test expr-old-4.22 {string operators} {expr {"abd" ne "abd"}} 0
test expr-old-4.23 {string operators} {expr {"" eq "abd"}} 0
test expr-old-4.24 {string operators} {expr {"" eq ""}} 1
test expr-old-4.25 {string operators} {expr {"abd" ne ""}} 1
test expr-old-4.26 {string operators} {expr {"" ne ""}} 0
test expr-old-4.27 {string operators} {expr {"longerstring" eq "shorter"}} 0
test expr-old-4.28 {string operators} {expr {"longerstring" ne "shorter"}} 1
# The following tests are non-portable because on some systems "+"
# and "-" can be parsed as numbers.
test expr-old-4.29 {string operators} {nonPortable} {expr {"0" == "+"}} 0
test expr-old-4.30 {string operators} {nonPortable} {expr {"0" == "-"}} 0
test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo
test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar
# Operators that aren't legal on string operands.
test expr-old-5.1 {illegal string operations} {
list [catch {expr {-"a"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test expr-old-5.2 {illegal string operations} {
list [catch {expr {+"a"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-5.3 {illegal string operations} {
list [catch {expr {~"a"}} msg] $msg
} {1 {can't use non-numeric string as operand of "~"}}
test expr-old-5.4 {illegal string operations} {
list [catch {expr {!"a"}} msg] $msg
} {1 {can't use non-numeric string as operand of "!"}}
test expr-old-5.5 {illegal string operations} {
list [catch {expr {"a"*"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
test expr-old-5.6 {illegal string operations} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
test expr-old-5.7 {illegal string operations} {
list [catch {expr {"a"%"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "%"}}
test expr-old-5.8 {illegal string operations} {
list [catch {expr {"a"+"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-5.9 {illegal string operations} {
list [catch {expr {"a"-"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test expr-old-5.10 {illegal string operations} {
list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "<<"}}
test expr-old-5.11 {illegal string operations} {
list [catch {expr {"a">>"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of ">>"}}
test expr-old-5.12 {illegal string operations} {
list [catch {expr {"a"&"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "&"}}
test expr-old-5.13 {illegal string operations} {
list [catch {expr {"a"^"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "^"}}
test expr-old-5.14 {illegal string operations} {
list [catch {expr {"a"|"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "|"}}
test expr-old-5.15 {illegal string operations} {
list [catch {expr {"a"&&"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-old-5.16 {illegal string operations} {
list [catch {expr {"a"||"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-old-5.17 {illegal string operations} {
list [catch {expr {"a"?4:2}} msg] $msg
} {1 {expected boolean value but got "a"}}
# Check precedence pairwise.
test expr-old-6.1 {precedence checks} {expr -~3} 4
test expr-old-6.2 {precedence checks} {expr -!3} 0
test expr-old-6.3 {precedence checks} {expr -~0} 1
test expr-old-7.1 {precedence checks} {expr 2*4/6} 1
test expr-old-7.2 {precedence checks} {expr 24/6*3} 12
test expr-old-7.3 {precedence checks} {expr 24/6/2} 2
test expr-old-8.1 {precedence checks} {expr -2+4} 2
test expr-old-8.2 {precedence checks} {expr -2-4} -6
test expr-old-8.3 {precedence checks} {expr +2-4} -2
test expr-old-9.1 {precedence checks} {expr 2*3+4} 10
test expr-old-9.2 {precedence checks} {expr 8/2+4} 8
test expr-old-9.3 {precedence checks} {expr 8%3+4} 6
test expr-old-9.4 {precedence checks} {expr 2*3-1} 5
test expr-old-9.5 {precedence checks} {expr 8/2-1} 3
test expr-old-9.6 {precedence checks} {expr 8%3-1} 1
test expr-old-10.1 {precedence checks} {expr 6-3-2} 1
test expr-old-11.1 {precedence checks} {expr 7+1>>2} 2
test expr-old-11.2 {precedence checks} {expr 7+1<<2} 32
test expr-old-11.3 {precedence checks} {expr 7>>3-2} 3
test expr-old-11.4 {precedence checks} {expr 7<<3-2} 14
test expr-old-12.1 {precedence checks} {expr 6>>1>4} 0
test expr-old-12.2 {precedence checks} {expr 6>>1<2} 0
test expr-old-12.3 {precedence checks} {expr 6>>1>=3} 1
test expr-old-12.4 {precedence checks} {expr 6>>1<=2} 0
test expr-old-12.5 {precedence checks} {expr 6<<1>5} 1
test expr-old-12.6 {precedence checks} {expr 6<<1<5} 0
test expr-old-12.7 {precedence checks} {expr 5<=6<<1} 1
test expr-old-12.8 {precedence checks} {expr 5>=6<<1} 0
test expr-old-13.1 {precedence checks} {expr 2<3<4} 1
test expr-old-13.2 {precedence checks} {expr 0<4>2} 0
test expr-old-13.3 {precedence checks} {expr 4>2<1} 0
test expr-old-13.4 {precedence checks} {expr 4>3>2} 0
test expr-old-13.5 {precedence checks} {expr 4>3>=2} 0
test expr-old-13.6 {precedence checks} {expr 4>=3>2} 0
test expr-old-13.7 {precedence checks} {expr 4>=3>=2} 0
test expr-old-13.8 {precedence checks} {expr 0<=4>=2} 0
test expr-old-13.9 {precedence checks} {expr 4>=2<=0} 0
test expr-old-13.10 {precedence checks} {expr 2<=3<=4} 1
test expr-old-14.1 {precedence checks} {expr 1==4>3} 1
test expr-old-14.2 {precedence checks} {expr 0!=4>3} 1
test expr-old-14.3 {precedence checks} {expr 1==3<4} 1
test expr-old-14.4 {precedence checks} {expr 0!=3<4} 1
test expr-old-14.5 {precedence checks} {expr 1==4>=3} 1
test expr-old-14.6 {precedence checks} {expr 0!=4>=3} 1
test expr-old-14.7 {precedence checks} {expr 1==3<=4} 1
test expr-old-14.8 {precedence checks} {expr 0!=3<=4} 1
test expr-old-14.9 {precedence checks} {expr 1eq4>3} 1
test expr-old-14.10 {precedence checks} {expr 0ne4>3} 1
test expr-old-14.11 {precedence checks} {expr 1eq3<4} 1
test expr-old-14.12 {precedence checks} {expr 0ne3<4} 1
test expr-old-14.13 {precedence checks} {expr 1eq4>=3} 1
test expr-old-14.14 {precedence checks} {expr 0ne4>=3} 1
test expr-old-14.15 {precedence checks} {expr 1eq3<=4} 1
test expr-old-14.16 {precedence checks} {expr 0ne3<=4} 1
test expr-old-15.1 {precedence checks} {expr 1==3==3} 0
test expr-old-15.2 {precedence checks} {expr 3==3!=2} 1
test expr-old-15.3 {precedence checks} {expr 2!=3==3} 0
test expr-old-15.4 {precedence checks} {expr 2!=1!=1} 0
test expr-old-15.5 {precedence checks} {expr 1eq3eq3} 0
test expr-old-15.6 {precedence checks} {expr 3eq3ne2} 1
test expr-old-15.7 {precedence checks} {expr 2ne3eq3} 0
test expr-old-15.8 {precedence checks} {expr 2ne1ne1} 0
test expr-old-16.1 {precedence checks} {expr 2&3eq2} 0
test expr-old-16.2 {precedence checks} {expr 1&3ne3} 0
test expr-old-16.3 {precedence checks} {expr 2&3eq2} 0
test expr-old-16.4 {precedence checks} {expr 1&3ne3} 0
test expr-old-17.1 {precedence checks} {expr 7&3^0x10} 19
test expr-old-17.2 {precedence checks} {expr 7^0x10&3} 7
test expr-old-18.1 {precedence checks} {expr 7^0x10|3} 23
test expr-old-18.2 {precedence checks} {expr 7|0x10^3} 23
test expr-old-19.1 {precedence checks} {expr 7|3&&1} 1
test expr-old-19.2 {precedence checks} {expr 1&&3|7} 1
test expr-old-19.3 {precedence checks} {expr 0&&1||1} 1
test expr-old-19.4 {precedence checks} {expr 1||1&&0} 1
test expr-old-20.1 {precedence checks} {expr 1||0?3:4} 3
test expr-old-20.2 {precedence checks} {expr 1?0:4||1} 0
test expr-old-20.3 {precedence checks} {expr 1?2:0?3:4} 2
test expr-old-20.4 {precedence checks} {expr 0?2:0?3:4} 4
test expr-old-20.5 {precedence checks} {expr 1?2?3:4:0} 3
test expr-old-20.6 {precedence checks} {expr 0?2?3:4:0} 0
# Parentheses.
test expr-old-21.1 {parenthesization} {expr (2+4)*6} 36
test expr-old-21.2 {parenthesization} {expr (1?0:4)||1} 1
test expr-old-21.3 {parenthesization} {expr +(3-4)} -1
# Embedded commands and variable names.
set a 16
test expr-old-22.1 {embedded variables} {expr {2*$a}} 32
test expr-old-22.2 {embedded variables} {
set x -5
set y 10
expr {$x + $y}
} {5}
test expr-old-22.3 {embedded variables} {
set x " -5"
set y " +10"
expr {$x + $y}
} {5}
test expr-old-22.4 {embedded commands and variables} {expr {[set a] - 14}} 2
test expr-old-22.5 {embedded commands and variables} {
list [catch {expr {12 - [bad_command_name]}} msg] $msg
} {1 {invalid command name "bad_command_name"}}
# Double-quotes and things inside them.
test expr-old-23.1 {double quotes} {expr {"abc"}} abc
test expr-old-23.2 {double quotes} {
set a 189
expr {"$a.bc"}
} 189.bc
test expr-old-23.3 {double quotes} {
set b2 xyx
expr {"$b2$b2$b2.[set b2].[set b2]"}
} xyxxyxxyx.xyx.xyx
test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22
test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc}
test expr-old-23.6 {double quotes} {
catch {unset bogus__}
list [catch {expr {"$bogus__"}} msg] $msg
} {1 {can't read "bogus__": no such variable}}
test expr-old-23.7 {double quotes} {
list [catch {expr {"a[error Testing]bc"}} msg] $msg
} {1 Testing}
test expr-old-23.8 {double quotes} {
list [catch {expr {"12398712938788234-1298379" != ""}} msg] $msg
} {0 1}
# Numbers in various bases.
test expr-old-24.1 {numbers in different bases} {expr 0x20} 32
test expr-old-24.2 {numbers in different bases} {expr 015} 13
# Conversions between various data types.
test expr-old-25.1 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.2 {type conversions} {expr 2.5+2} 4.5
test expr-old-25.3 {type conversions} {expr 2-2.5} -0.5
test expr-old-25.4 {type conversions} {expr 2/2.5} 0.8
test expr-old-25.5 {type conversions} {expr 2>2.5} 0
test expr-old-25.6 {type conversions} {expr 2.5>2} 1
test expr-old-25.7 {type conversions} {expr 2<2.5} 1
test expr-old-25.8 {type conversions} {expr 2>=2.5} 0
test expr-old-25.9 {type conversions} {expr 2<=2.5} 1
test expr-old-25.10 {type conversions} {expr 2==2.5} 0
test expr-old-25.11 {type conversions} {expr 2!=2.5} 1
test expr-old-25.12 {type conversions} {expr 2>"ab"} 0
test expr-old-25.13 {type conversions} {expr {2>" "}} 1
test expr-old-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1
test expr-old-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0
test expr-old-25.16 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.17 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.18 {type conversions} {expr 2.0e2} 200.0
test expr-old-25.19 {type conversions} {eformat} {expr 2.0e15} 2e+15
test expr-old-25.20 {type conversions} {expr 10.0} 10.0
# Various error conditions.
test expr-old-26.1 {error conditions} {
list [catch {expr 2+"a"} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-26.2 {error conditions} {
list [catch {expr 2+4*} msg] $msg
} {1 {syntax error in expression "2+4*": premature end of expression}}
test expr-old-26.3 {error conditions} {
list [catch {expr 2+4*(} msg] $msg
} {1 {syntax error in expression "2+4*(": premature end of expression}}
catch {unset _non_existent_}
test expr-old-26.4 {error conditions} {
list [catch {expr 2+$_non_existent_} msg] $msg
} {1 {can't read "_non_existent_": no such variable}}
set a xx
test expr-old-26.5 {error conditions} {
list [catch {expr {2+$a}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-26.6 {error conditions} {
list [catch {expr {2+[set a]}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-26.7 {error conditions} {
list [catch {expr {2+(4}} msg] $msg
} {1 {syntax error in expression "2+(4": looking for close parenthesis}}
test expr-old-26.8 {error conditions} {
list [catch {expr 2/0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.9 {error conditions} {
list [catch {expr 2%0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.10 {error conditions} {
list [catch {expr 2.0/0.0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.11 {error conditions} {
list [catch {expr 2#} msg] $msg
} {1 {syntax error in expression "2#": extra tokens at end of expression}}
test expr-old-26.12 {error conditions} {
list [catch {expr a.b} msg] $msg
} {1 {syntax error in expression "a.b": variable references require preceding $}}
test expr-old-26.13 {error conditions} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
test expr-old-26.14 {error conditions} {
list [catch {expr 2:3} msg] $msg
} {1 {syntax error in expression "2:3": extra tokens at end of expression}}
test expr-old-26.15 {error conditions} {
list [catch {expr a@b} msg] $msg
} {1 {syntax error in expression "a@b": variable references require preceding $}}
test expr-old-26.16 {error conditions} {
list [catch {expr a[b} msg] $msg
} {1 {missing close-bracket}}
test expr-old-26.17 {error conditions} {
list [catch {expr a`b} msg] $msg
} {1 {syntax error in expression "a`b": variable references require preceding $}}
test expr-old-26.18 {error conditions} {
list [catch {expr \"a\"\{b} msg] $msg
} {1 syntax\ error\ in\ expression\ \"\"a\"\{b\":\ extra\ tokens\ at\ end\ of\ expression}
test expr-old-26.19 {error conditions} {
list [catch {expr a} msg] $msg
} {1 {syntax error in expression "a": variable references require preceding $}}
test expr-old-26.20 {error conditions} {
list [catch expr msg] $msg
} {1 {wrong # args: should be "expr arg ?arg ...?"}}
# Cancelled evaluation.
test expr-old-27.1 {cancelled evaluation} {
set a 1
expr {0&&[set a 2]}
set a
} 1
test expr-old-27.2 {cancelled evaluation} {
set a 1
expr {1||[set a 2]}
set a
} 1
test expr-old-27.3 {cancelled evaluation} {
set a 1
expr {0?[set a 2]:1}
set a
} 1
test expr-old-27.4 {cancelled evaluation} {
set a 1
expr {1?2:[set a 2]}
set a
} 1
catch {unset x}
test expr-old-27.5 {cancelled evaluation} {
list [catch {expr {[info exists x] && $x}} msg] $msg
} {0 0}
test expr-old-27.6 {cancelled evaluation} {
list [catch {expr {0 && [concat $x]}} msg] $msg
} {0 0}
test expr-old-27.7 {cancelled evaluation} {
set one 1
list [catch {expr {1 || 1/$one}} msg] $msg
} {0 1}
test expr-old-27.8 {cancelled evaluation} {
list [catch {expr {1 || -"string"}} msg] $msg
} {0 1}
test expr-old-27.9 {cancelled evaluation} {
list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg
} {0 1}
test expr-old-27.10 {cancelled evaluation} {
set x -1.0
list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg
} {0 0}
test expr-old-27.11 {cancelled evaluation} {
list [catch {expr {0 && foo}} msg] $msg
} {1 {syntax error in expression "0 && foo": variable references require preceding $}}
test expr-old-27.12 {cancelled evaluation} {
list [catch {expr {0 ? 1 : foo}} msg] $msg
} {1 {syntax error in expression "0 ? 1 : foo": variable references require preceding $}}
# Tcl_ExprBool as used in "if" statements
test expr-old-28.1 {Tcl_ExprBoolean usage} {
set a 1
if {2} {set a 2}
set a
} 2
test expr-old-28.2 {Tcl_ExprBoolean usage} {
set a 1
if {0} {set a 2}
set a
} 1
test expr-old-28.3 {Tcl_ExprBoolean usage} {
set a 1
if {1.2} {set a 2}
set a
} 2
test expr-old-28.4 {Tcl_ExprBoolean usage} {
set a 1
if {-1.1} {set a 2}
set a
} 2
test expr-old-28.5 {Tcl_ExprBoolean usage} {
set a 1
if {0.0} {set a 2}
set a
} 1
test expr-old-28.6 {Tcl_ExprBoolean usage} {
set a 1
if {"YES"} {set a 2}
set a
} 2
test expr-old-28.7 {Tcl_ExprBoolean usage} {
set a 1
if {"no"} {set a 2}
set a
} 1
test expr-old-28.8 {Tcl_ExprBoolean usage} {
set a 1
if {"true"} {set a 2}
set a
} 2
test expr-old-28.9 {Tcl_ExprBoolean usage} {
set a 1
if {"fAlse"} {set a 2}
set a
} 1
test expr-old-28.10 {Tcl_ExprBoolean usage} {
set a 1
if {"on"} {set a 2}
set a
} 2
test expr-old-28.11 {Tcl_ExprBoolean usage} {
set a 1
if {"Off"} {set a 2}
set a
} 1
test expr-old-28.12 {Tcl_ExprBool usage} {
list [catch {if {"abc"} {}} msg] $msg
} {1 {expected boolean value but got "abc"}}
test expr-old-28.13 {Tcl_ExprBool usage} {
list [catch {if {"ogle"} {}} msg] $msg
} {1 {expected boolean value but got "ogle"}}
test expr-old-28.14 {Tcl_ExprBool usage} {
list [catch {if {"o"} {}} msg] $msg
} {1 {expected boolean value but got "o"}}
# Operands enclosed in braces
test expr-old-29.1 {braces} {expr {{abc}}} abc
test expr-old-29.2 {braces} {expr {{00010}}} 8
test expr-old-29.3 {braces} {expr {{3.1200000}}} 3.12
test expr-old-29.4 {braces} {expr {{a{b}{1 {2 3}}c}}} "a{b}{1 {2 3}}c"
test expr-old-29.5 {braces} {
list [catch {expr "\{abc"} msg] $msg
} {1 {missing close-brace}}
# Very long values
test expr-old-30.1 {long values} {
set a "0000 1111 2222 3333 4444"
set a "$a | $a | $a | $a | $a"
set a "$a || $a || $a || $a || $a"
expr {$a}
} {0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444}
test expr-old-30.2 {long values} {
set a "000000000000000000000000000000"
set a "$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a${a}5"
expr $a
} 5
# Expressions spanning multiple arguments
test expr-old-31.1 {multiple arguments to expr command} {
expr 4 + ( 6 *12) -3
} 73
test expr-old-31.2 {multiple arguments to expr command} {
list [catch {expr 2 + (3 + 4} msg] $msg
} {1 {syntax error in expression "2 + (3 + 4": looking for close parenthesis}}
test expr-old-31.3 {multiple arguments to expr command} {
list [catch {expr 2 + 3 +} msg] $msg
} {1 {syntax error in expression "2 + 3 +": premature end of expression}}
test expr-old-31.4 {multiple arguments to expr command} {
list [catch {expr 2 + 3 )} msg] $msg
} {1 {syntax error in expression "2 + 3 )": extra tokens at end of expression}}
# Math functions
test expr-old-32.1 {math functions in expressions} {
format %.6g [expr acos(0.5)]
} {1.0472}
test expr-old-32.2 {math functions in expressions} {
format %.6g [expr asin(0.5)]
} {0.523599}
test expr-old-32.3 {math functions in expressions} {
format %.6g [expr atan(1.0)]
} {0.785398}
test expr-old-32.4 {math functions in expressions} {
format %.6g [expr atan2(2.0, 2.0)]
} {0.785398}
test expr-old-32.5 {math functions in expressions} {
format %.6g [expr ceil(1.999)]
} {2}
test expr-old-32.6 {math functions in expressions} {
format %.6g [expr cos(.1)]
} {0.995004}
test expr-old-32.7 {math functions in expressions} {
format %.6g [expr cosh(.1)]
} {1.005}
test expr-old-32.8 {math functions in expressions} {
format %.6g [expr exp(1.0)]
} {2.71828}
test expr-old-32.9 {math functions in expressions} {
format %.6g [expr floor(2.000)]
} {2}
test expr-old-32.10 {math functions in expressions} {
format %.6g [expr floor(2.001)]
} {2}
test expr-old-32.11 {math functions in expressions} {
format %.6g [expr fmod(7.3, 3.2)]
} {0.9}
test expr-old-32.12 {math functions in expressions} {
format %.6g [expr hypot(3.0, 4.0)]
} {5}
test expr-old-32.13 {math functions in expressions} {
format %.6g [expr log(2.8)]
} {1.02962}
test expr-old-32.14 {math functions in expressions} {
format %.6g [expr log10(2.8)]
} {0.447158}
test expr-old-32.15 {math functions in expressions} {
format %.6g [expr pow(2.1, 3.1)]
} {9.97424}
test expr-old-32.16 {math functions in expressions} {
format %.6g [expr sin(.1)]
} {0.0998334}
test expr-old-32.17 {math functions in expressions} {
format %.6g [expr sinh(.1)]
} {0.100167}
test expr-old-32.18 {math functions in expressions} {
format %.6g [expr sqrt(2.0)]
} {1.41421}
test expr-old-32.19 {math functions in expressions} {
format %.6g [expr tan(0.8)]
} {1.02964}
test expr-old-32.20 {math functions in expressions} {
format %.6g [expr tanh(0.8)]
} {0.664037}
test expr-old-32.21 {math functions in expressions} {
format %.6g [expr abs(-1.8)]
} {1.8}
test expr-old-32.22 {math functions in expressions} {
expr abs(10.0)
} {10.0}
test expr-old-32.23 {math functions in expressions} {
format %.6g [expr abs(-4)]
} {4}
test expr-old-32.24 {math functions in expressions} {
format %.6g [expr abs(66)]
} {66}
# The following test is different for 32-bit versus 64-bit architectures.
if {0x80000000 > 0} {
test expr-old-32.25 {math functions in expressions} {nonPortable} {
list [catch {expr abs(0x8000000000000000)} msg] $msg
} {1 {integer value too large to represent}}
} else {
test expr-old-32.25 {math functions in expressions} {nonPortable} {
list [catch {expr abs(0x80000000)} msg] $msg
} {1 {integer value too large to represent}}
}
test expr-old-32.26 {math functions in expressions} {
expr double(1)
} {1.0}
test expr-old-32.27 {math functions in expressions} {
expr double(1.1)
} {1.1}
test expr-old-32.28 {math functions in expressions} {
expr int(1)
} {1}
test expr-old-32.29 {math functions in expressions} {
expr int(1.4)
} {1}
test expr-old-32.30 {math functions in expressions} {
expr int(1.6)
} {1}
test expr-old-32.31 {math functions in expressions} {
expr int(-1.4)
} {-1}
test expr-old-32.32 {math functions in expressions} {
expr int(-1.6)
} {-1}
test expr-old-32.33 {math functions in expressions} {
list [catch {expr int(1e60)} msg] $msg
} {1 {integer value too large to represent}}
test expr-old-32.34 {math functions in expressions} {
list [catch {expr int(-1e60)} msg] $msg
} {1 {integer value too large to represent}}
test expr-old-32.35 {math functions in expressions} {
expr round(1.49)
} {1}
test expr-old-32.36 {math functions in expressions} {
expr round(1.51)
} {2}
test expr-old-32.37 {math functions in expressions} {
expr round(-1.49)
} {-1}
test expr-old-32.38 {math functions in expressions} {
expr round(-1.51)
} {-2}
test expr-old-32.39 {math functions in expressions} {
list [catch {expr round(1e60)} msg] $msg
} {1 {integer value too large to represent}}
test expr-old-32.40 {math functions in expressions} {
list [catch {expr round(-1e60)} msg] $msg
} {1 {integer value too large to represent}}
test expr-old-32.41 {math functions in expressions} {
list [catch {expr pow(1.0 + 3.0 - 2, .8 * 5)} msg] $msg
} {0 16.0}
test expr-old-32.42 {math functions in expressions} {
list [catch {expr hypot(5*.8,3)} msg] $msg
} {0 5.0}
if $gotT1 {
test expr-old-32.43 {math functions in expressions} {
expr 2*T1()
} 246
test expr-old-32.44 {math functions in expressions} {
expr T2()*3
} 1035
}
test expr-old-32.45 {math functions in expressions} {
expr (0 <= rand()) && (rand() < 1)
} {1}
test expr-old-32.46 {math functions in expressions} {
list [catch {expr rand(24)} msg] $msg
} {1 {too many arguments for math function}}
test expr-old-32.47 {math functions in expressions} {
list [catch {expr srand()} msg] $msg
} {1 {too few arguments for math function}}
test expr-old-32.48 {math functions in expressions} {
list [catch {expr srand(3.79)} msg] $msg
} {1 {expected integer but got "3.79"}}
test expr-old-32.49 {math functions in expressions} {
list [catch {expr srand("")} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-32.50 {math functions in expressions} {
set result [expr round(srand(12345) * 1000)]
for {set i 0} {$i < 10} {incr i} {
lappend result [expr round(rand() * 1000)]
}
set result
} {97 834 948 36 12 51 766 585 914 784 333}
test expr-old-32.51 {math functions in expressions} {
list [catch {expr {srand([lindex "6ty" 0])}} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-32.52 {math functions in expressions} {
expr {srand(int(1<<37)) < 1}
} {1}
test expr-old-32.53 {math functions in expressions} {
expr {srand((1<<31) - 1) > 0}
} {1}
test expr-old-33.1 {conversions and fancy args to math functions} {
expr hypot ( 3 , 4 )
} 5.0
test expr-old-33.2 {conversions and fancy args to math functions} {
expr hypot ( (2.0+1.0) , 4 )
} 5.0
test expr-old-33.3 {conversions and fancy args to math functions} {
expr hypot ( 3 , (3.0 + 1.0) )
} 5.0
test expr-old-33.4 {conversions and fancy args to math functions} {
format %.6g [expr cos(acos(0.1))]
} 0.1
test expr-old-34.1 {errors in math functions} {
list [catch {expr func_2(1.0)} msg] $msg
} {1 {unknown math function "func_2"}}
test expr-old-34.2 {errors in math functions} {
list [catch {expr func|(1.0)} msg] $msg
} {1 {syntax error in expression "func|(1.0)": variable references require preceding $}}
test expr-old-34.3 {errors in math functions} {
list [catch {expr {hypot("a b", 2.0)}} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-34.4 {errors in math functions} {
list [catch {expr hypot(1.0 2.0)} msg] $msg
} {1 {syntax error in expression "hypot(1.0 2.0)": missing close parenthesis at end of function call}}
test expr-old-34.5 {errors in math functions} {
list [catch {expr hypot(1.0, 2.0} msg] $msg
} {1 {syntax error in expression "hypot(1.0, 2.0": missing close parenthesis at end of function call}}
test expr-old-34.6 {errors in math functions} {
list [catch {expr hypot(1.0 ,} msg] $msg
} {1 {syntax error in expression "hypot(1.0 ,": premature end of expression}}
test expr-old-34.7 {errors in math functions} {
list [catch {expr hypot(1.0)} msg] $msg
} {1 {too few arguments for math function}}
test expr-old-34.8 {errors in math functions} {
list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg
} {1 {too many arguments for math function}}
test expr-old-34.9 {errors in math functions} {
list [catch {expr acos(-2.0)} msg] $msg $errorCode
} {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}}
test expr-old-34.10 {errors in math functions} {nonPortable} {
list [catch {expr pow(-3, 1000001)} msg] $msg $errorCode
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
test expr-old-34.11 {errors in math functions} {
list [catch {expr pow(3, 1000001)} msg] $msg $errorCode
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
test expr-old-34.12 {errors in math functions} {
list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
test expr-old-34.13 {errors in math functions} {
list [catch {expr int(1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.14 {errors in math functions} {
list [catch {expr int(-1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.15 {errors in math functions} {
list [catch {expr round(1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.16 {errors in math functions} {
list [catch {expr round(-1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
if $gotT1 {
test expr-old-34.17 {errors in math functions} {
list [catch {expr T1(4)} msg] $msg
} {1 {too many arguments for math function}}
}
test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
expr 0289
} -returnCodes error -match glob -result {*invalid octal number*}
test expr-old-36.2 {ExprLooksLikeInt procedure} {
set x 0289
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.3 {ExprLooksLikeInt procedure} {
list [catch {expr 0289.1} msg] $msg
} {0 289.1}
test expr-old-36.4 {ExprLooksLikeInt procedure} {
set x 0289.1
list [catch {expr {$x+1}} msg] $msg
} {0 290.1}
test expr-old-36.5 {ExprLooksLikeInt procedure} {
set x { +22}
list [catch {expr {$x+1}} msg] $msg
} {0 23}
test expr-old-36.6 {ExprLooksLikeInt procedure} {
set x { -22}
list [catch {expr {$x+1}} msg] $msg
} {0 -21}
test expr-old-36.7 {ExprLooksLikeInt procedure} {nonPortable unixOnly} {
list [catch {expr nan} msg] $msg
} {1 {domain error: argument not in valid range}}
test expr-old-36.8 {ExprLooksLikeInt procedure} {
list [catch {expr 78e1} msg] $msg
} {0 780.0}
test expr-old-36.9 {ExprLooksLikeInt procedure} {
list [catch {expr 24E1} msg] $msg
} {0 240.0}
test expr-old-36.10 {ExprLooksLikeInt procedure} {nonPortable unixOnly} {
list [catch {expr 78e} msg] $msg
} {1 {syntax error in expression "78e"}}
# test for [Bug #542588]
test expr-old-36.11 {ExprLooksLikeInt procedure} {
# define a "too large integer"; this one works also for 64bit arith
set x 665802003400000000000000
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}
# tests for [Bug #587140]
test expr-old-36.12 {ExprLooksLikeInt procedure} {
set x "10;"
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-36.13 {ExprLooksLikeInt procedure} {
set x " +"
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-36.14 {ExprLooksLikeInt procedure} {
set x "123456789012345678901234567890 "
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}
test expr-old-36.15 {ExprLooksLikeInt procedure} {
set x "099 "
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.16 {ExprLooksLikeInt procedure} {
set x " 0xffffffffffffffffffffffffffffffffffffff "
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}
if {[info commands testexprlong] == {}} {
puts "This application hasn't been compiled with the \"testexprlong\""
puts "command, so I can't test Tcl_ExprLong etc."
} else {
test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} {
testexprlong
} {This is a result: 5}
}
if {[info commands testexprstring] == {}} {
puts "This application hasn't been compiled with the \"testexprstring\""
puts "command, so I can't test Tcl_ExprString etc."
} else {
test expr-old-38.1 {Verify Tcl_ExprString's basic operation} {
list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \
[catch {testexprstring "1+"} msg] $msg
} {5 10.2 1 {syntax error in expression "1+": premature end of expression}}
}
#
# Test for bug #908375: rounding numbers that do not fit in a
# long but do fit in a wide
#
test expr-old-39.1 {Rounding with wide result} {
set x 1.0e10
set y [expr $x + 0.1]
catch {
set x [list [expr {$x == round($y)}] [expr $x == -round(-$y)]]
}
set x
} {1 1}
unset -nocomplain x y
# Special test for Pentium arithmetic bug of 1994:
if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} {
puts "Warning: this machine contains a defective Pentium processor"
puts "that performs arithmetic incorrectly. I recommend that you"
puts "call Intel customer service immediately at 1-800-628-8686"
puts "to request a replacement processor."
}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/appendComp.test 0000644 0036047 0045461 00000025007 11737050674 015054 0 ustar dgp 771div # Commands covered: append lappend
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset x}
test appendComp-1.1 {append command} {
catch {unset x}
proc foo {} {append ::x 1 2 abc "long string"}
list [foo] $x
} {{12abclong string} {12abclong string}}
test appendComp-1.2 {append command} {
proc foo {} {
set x ""
list [append x first] [append x second] [append x third] $x
}
foo
} {first firstsecond firstsecondthird firstsecondthird}
test appendComp-1.3 {append command} {
proc foo {} {
set x "abcd"
append x
}
foo
} abcd
test appendComp-2.1 {long appends} {
proc foo {} {
set x ""
for {set i 0} {$i < 1000} {set i [expr $i+1]} {
append x "foobar "
}
set y "foobar"
set y "$y $y $y $y $y $y $y $y $y $y"
set y "$y $y $y $y $y $y $y $y $y $y"
set y "$y $y $y $y $y $y $y $y $y $y "
expr {$x == $y}
}
foo
} 1
test appendComp-3.1 {append errors} {
proc foo {} {append}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "append varName ?value value ...?"}}
test appendComp-3.2 {append errors} {
proc foo {} {
set x ""
append x(0) 44
}
list [catch {foo} msg] $msg
} {1 {can't set "x(0)": variable isn't array}}
test appendComp-3.3 {append errors} {
proc foo {} {
catch {unset x}
append x
}
list [catch {foo} msg] $msg
} {1 {can't read "x": no such variable}}
test appendComp-4.1 {lappend command} {
proc foo {} {
global x
catch {unset x}
lappend x 1 2 abc "long string"
}
list [foo] $x
} {{1 2 abc {long string}} {1 2 abc {long string}}}
test appendComp-4.2 {lappend command} {
proc foo {} {
set x ""
list [lappend x first] [lappend x second] [lappend x third] $x
}
foo
} {first {first second} {first second third} {first second third}}
test appendComp-4.3 {lappend command} {
proc foo {} {
global x
set x old
unset x
lappend x new
}
set result [foo]
rename foo {}
set result
} {new}
test appendComp-4.4 {lappend command} {
proc foo {} {
set x {}
lappend x \{\ abc
}
foo
} {\{\ abc}
test appendComp-4.5 {lappend command} {
proc foo {} {
set x {}
lappend x \{ abc
}
foo
} {\{ abc}
test appendComp-4.6 {lappend command} {
proc foo {} {
set x {1 2 3}
lappend x
}
foo
} {1 2 3}
test appendComp-4.7 {lappend command} {
proc foo {} {
set x "a\{"
lappend x abc
}
foo
} "a\\\{ abc"
test appendComp-4.8 {lappend command} {
proc foo {} {
set x "\\\{"
lappend x abc
}
foo
} "\\{ abc"
test appendComp-4.9 {lappend command} {
proc foo {} {
set x " \{"
list [catch {lappend x abc} msg] $msg
}
foo
} {1 {unmatched open brace in list}}
test appendComp-4.10 {lappend command} {
proc foo {} {
set x " \{"
list [catch {lappend x abc} msg] $msg
}
foo
} {1 {unmatched open brace in list}}
test appendComp-4.11 {lappend command} {
proc foo {} {
set x "\{\{\{"
list [catch {lappend x abc} msg] $msg
}
foo
} {1 {unmatched open brace in list}}
test appendComp-4.12 {lappend command} {
proc foo {} {
set x "x \{\{\{"
list [catch {lappend x abc} msg] $msg
}
foo
} {1 {unmatched open brace in list}}
test appendComp-4.13 {lappend command} {
proc foo {} {
set x "x\{\{\{"
lappend x abc
}
foo
} "x\\\{\\\{\\\{ abc"
test appendComp-4.14 {lappend command} {
proc foo {} {
set x " "
lappend x abc
}
foo
} "abc"
test appendComp-4.15 {lappend command} {
proc foo {} {
set x "\\ "
lappend x abc
}
foo
} "{ } abc"
test appendComp-4.16 {lappend command} {
proc foo {} {
set x "x "
lappend x abc
}
foo
} "x abc"
test appendComp-4.17 {lappend command} {
proc foo {} { lappend x }
foo
} {}
test appendComp-4.18 {lappend command} {
proc foo {} { lappend x {} }
foo
} {{}}
test appendComp-4.19 {lappend command} {
proc foo {} { lappend x(0) }
foo
} {}
test appendComp-4.20 {lappend command} {
proc foo {} { lappend x(0) abc }
foo
} {abc}
proc check {var size} {
set l [llength $var]
if {$l != $size} {
return "length mismatch: should have been $size, was $l"
}
for {set i 0} {$i < $size} {set i [expr $i+1]} {
set j [lindex $var $i]
if {$j != "item $i"} {
return "element $i should have been \"item $i\", was \"$j\""
}
}
return ok
}
test appendComp-5.1 {long lappends} {
catch {unset x}
set x ""
for {set i 0} {$i < 300} {set i [expr $i+1]} {
lappend x "item $i"
}
check $x 300
} ok
test appendComp-6.1 {lappend errors} {
proc foo {} {lappend}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "lappend varName ?value value ...?"}}
test appendComp-6.2 {lappend errors} {
proc foo {} {
set x ""
lappend x(0) 44
}
list [catch {foo} msg] $msg
} {1 {can't set "x(0)": variable isn't array}}
test appendComp-7.1 {lappendComp-created var and error in trace on that var} {
proc bar {} {
global x
catch {rename foo ""}
catch {unset x}
trace variable x w foo
proc foo {} {global x; unset x}
catch {lappend x 1}
proc foo {args} {global x; unset x}
info exists x
set x
lappend x 1
list [info exists x] [catch {set x} msg] $msg
}
bar
} {0 1 {can't read "x": no such variable}}
test appendComp-7.2 {lappend var triggers read trace, index var} {bug-3057639} {
proc bar {} {
catch {unset myvar}
catch {unset ::result}
trace variable myvar r foo
proc foo {args} {append ::result $args}
lappend myvar a
list [catch {set ::result} msg] $msg
}
bar
} {0 {myvar {} r}}
test appendComp-7.3 {lappend var triggers read trace, stack var} {bug-3057639} {
proc bar {} {
catch {unset ::myvar}
catch {unset ::result}
trace variable ::myvar r foo
proc foo {args} {append ::result $args}
lappend ::myvar a
list [catch {set ::result} msg] $msg
}
bar
} {0 {::myvar {} r}}
test appendComp-7.4 {lappend var triggers read trace, array var} {bug-3057639} {
# The behavior of read triggers on lappend changed in 8.0 to
# not trigger them. Maybe not correct, but been there a while.
proc bar {} {
catch {unset myvar}
catch {unset ::result}
trace variable myvar r foo
proc foo {args} {append ::result $args}
lappend myvar(b) a
list [catch {set ::result} msg] $msg
}
bar
} {0 {myvar b r}}
test appendComp-7.5 {lappend var triggers read trace, array var} {
# The behavior of read triggers on lappend changed in 8.0 to
# not trigger them. Maybe not correct, but been there a while.
proc bar {} {
catch {unset myvar}
catch {unset ::result}
trace variable myvar r foo
proc foo {args} {append ::result $args}
lappend myvar(b) a b
list [catch {set ::result} msg] $msg
}
bar
} {0 {myvar b r}}
test appendComp-7.6 {lappend var triggers read trace, array var exists} {bug-3057639} {
proc bar {} {
catch {unset myvar}
catch {unset ::result}
set myvar(0) 1
trace variable myvar r foo
proc foo {args} {append ::result $args}
lappend myvar(b) a
list [catch {set ::result} msg] $msg
}
bar
} {0 {myvar b r}}
test appendComp-7.7 {lappend var triggers read trace, array stack var} {bug-3057639} {
proc bar {} {
catch {unset ::myvar}
catch {unset ::result}
trace variable ::myvar r foo
proc foo {args} {append ::result $args}
lappend ::myvar(b) a
list [catch {set ::result} msg] $msg
}
bar
} {0 {::myvar b r}}
test appendComp-7.8 {lappend var triggers read trace, array stack var} {
proc bar {} {
catch {unset ::myvar}
catch {unset ::result}
trace variable ::myvar r foo
proc foo {args} {append ::result $args}
lappend ::myvar(b) a b
list [catch {set ::result} msg] $msg
}
bar
} {0 {::myvar b r}}
test appendComp-7.9 {append var does not trigger read trace} {
proc bar {} {
catch {unset myvar}
catch {unset ::result}
trace variable myvar r foo
proc foo {args} {append ::result $args}
append myvar a
info exists ::result
}
bar
} {0}
# New tests for bug 3057639 to show off the more consistent behaviour
# of lappend in both direct-eval and bytecompiled code paths (see
# append.test for the direct-eval variants). lappend now behaves like
# append. 9.0/1 lappend - 9.2/3 append.
# Note also the tests above now constrained by bug-3057639, these
# changed behaviour with the triggering of read traces in bc mode
# gone.
# Going back to the tests below. The direct-eval tests are ok before
# and after patch (no read traces run for lappend, append). The
# compiled tests are failing for lappend (9.0/1) before the patch,
# showing how it invokes read traces in the compiled path. The append
# tests are good (9.2/3). After the patch the failues are gone.
test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing array variable element} {
catch {unset myvar}
array set myvar {}
proc nonull {var key val} {
upvar 1 $var lvar
if {![info exists lvar($key)]} {
return -code error "BOOM. no such variable"
}
}
trace add variable myvar read nonull
proc foo {} {
lappend ::myvar(key) "new value"
}
list [catch { foo } msg] $msg
} {0 {{new value}}}
test appendComp-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} {
catch {unset ::env(__DUMMY__)}
proc foo {} {
lappend ::env(__DUMMY__) "new value"
}
list [catch { foo } msg] $msg
} {0 {{new value}}}
test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing array variable element} {
catch {unset myvar}
array set myvar {}
proc nonull {var key val} {
upvar 1 $var lvar
if {![info exists lvar($key)]} {
return -code error "BOOM. no such variable"
}
}
trace add variable myvar read nonull
proc foo {} {
append ::myvar(key) "new value"
}
list [catch { foo } msg] $msg
} {0 {new value}}
test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} {
catch {unset ::env(__DUMMY__)}
proc foo {} {
append ::env(__DUMMY__) "new value"
}
list [catch { foo } msg] $msg
} {0 {new value}}
catch {unset i x result y}
catch {rename foo ""}
catch {rename bar ""}
catch {rename check ""}
catch {rename bar {}}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/winDde.test 0000644 0036047 0045461 00000012201 12144442333 014156 0 ustar dgp 771div # This file tests the tclWinDde.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {$tcl_platform(platform) == "windows"} {
if [catch {
set lib [lindex [glob -directory [file join [pwd] [file dirname \
[info nameofexecutable]]] tcldde*.dll] 0]
load $lib dde
}] {
puts "WARNING: Unable to find the dde package. Skipping dde tests."
::tcltest::cleanupTests
return
}
}
set scriptName script1.tcl
proc createChildProcess { ddeServerName } {
file delete -force $::scriptName
set f [open $::scriptName w+]
puts $f {
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if [catch {
set lib [lindex [glob -directory \
[file join [pwd] [file dirname [info nameofexecutable]]] \
tcldde*.dll] 0]
load $lib dde
}] {
puts "Unable to find the dde package. Skipping dde tests."
::tcltest::cleanupTests
return
}
}
puts $f [list dde servername $ddeServerName]
puts $f {
after 200 {set ready 1}
vwait ready
puts ready
vwait done
after 200 {set final 1}
vwait final
exit
}
close $f
set f [open |[list [interpreter] $::scriptName] r]
fconfigure $f -buffering line -blocking 1
gets $f
return $f
}
# -------------------------------------------------------------------------
test winDde-1.1 {Settings the server's topic name} {pcOnly} {
list [dde servername foobar] [dde servername] [dde servername self]
} {foobar foobar self}
test winDde-2.1 {Checking for other services} {pcOnly} {
expr [llength [dde services {} {}]] >= 0
} 1
test winDde-2.2 {Checking for existence, with service and topic specified} \
{pcOnly} {
llength [dde services TclEval self]
} 1
test winDde-2.3 {Checking for existence, with only the service specified} \
{pcOnly} {
expr [llength [dde services TclEval {}]] >= 1
} 1
# -------------------------------------------------------------------------
test winDde-3.1 {DDE execute locally} {pcOnly} {
set a ""
dde execute TclEval self {set a "foo"}
set a
} foo
test winDde-3.2 {DDE execute -async locally} {pcOnly} {
set a ""
dde execute -async TclEval self {set a "foo"}
update
set a
} foo
test winDde-3.3 {DDE request locally} {pcOnly} {
set a ""
dde execute TclEval self {set a "foo"}
dde request TclEval self a
} foo
test winDde-3.4 {DDE eval locally} {pcOnly} {
set a ""
dde eval self set a "foo"
} foo
test winDde-3.5 {DDE request locally} {pcOnly} {
set a ""
dde execute TclEval self {set a "foo"}
dde request -binary TclEval self a
} "foo\x00"
# -------------------------------------------------------------------------
test winDde-4.1 {DDE execute remotely} {stdio pcOnly} {
set a ""
set name child-4.1
set child [createChildProcess $name]
dde execute TclEval $name {set a "foo"}
dde execute TclEval $name {set done 1}
update
set a
} ""
test winDde-4.2 {DDE execute async remotely} {stdio pcOnly} {
set a ""
set name child-4.2
set child [createChildProcess $name]
dde execute -async TclEval $name {set a "foo"}
update
dde execute TclEval $name {set done 1}
update
set a
} ""
test winDde-4.3 {DDE request remotely} {stdio pcOnly} {
set a ""
set name chile-4.3
set child [createChildProcess $name]
dde execute TclEval $name {set a "foo"}
set a [dde request TclEval $name a]
dde execute TclEval $name {set done 1}
update
set a
} foo
test winDde-4.4 {DDE eval remotely} {stdio pcOnly} {
set a ""
set name child-4.4
set child [createChildProcess $name]
set a [dde eval $name set a "foo"]
dde execute TclEval $name {set done 1}
update
set a
} foo
# -------------------------------------------------------------------------
test winDde-5.1 {check for bad arguments} {pcOnly} {
catch {dde execute "" "" "" ""} result
set result
} {wrong # args: should be "dde execute ?-async? serviceName topicName value"}
test winDde-5.2 {check for bad arguments} {pcOnly} {
catch {dde execute "" "" ""} result
set result
} {cannot execute null data}
test winDde-5.3 {check for bad arguments} {pcOnly} {
catch {dde execute -foo "" "" ""} result
set result
} {wrong # args: should be "dde execute ?-async? serviceName topicName value"}
test winDde-5.4 {DDE eval bad arguments} {pcOnly} {
list [catch {dde eval "" "foo"} msg] $msg
} {1 {invalid service name ""}}
# -------------------------------------------------------------------------
#cleanup
#catch {interp delete $slave}; # ensure we clean up the slave.
file delete -force $::scriptName
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
tcl8.4.20/tests/list.test 0000644 0036047 0045461 00000007573 11737050674 013751 0 ustar dgp 771div # Commands covered: list
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# First, a bunch of individual tests
test list-1.1 {basic tests} {list a b c} {a b c}
test list-1.2 {basic tests} {list {a b} c} {{a b} c}
test list-1.3 {basic tests} {list \{a b c} {\{a b c}
test list-1.4 {basic tests} "list a{}} b{} c}" "a\\{\\}\\} b{} c\\}"
test list-1.5 {basic tests} {list a\[ b\] } "{a\[} b\\]"
test list-1.6 {basic tests} {list c\ d\t } "{c } {d\t}"
test list-1.7 {basic tests} {list e\n f\$ } "{e\n} {f\$}"
test list-1.8 {basic tests} {list g\; h\\} {{g;} h\\}
test list-1.9 {basic tests} "list a\\\[} b\\\]} " "a\\\[\\\} b\\\]\\\}"
test list-1.10 {basic tests} "list c\\\} d\\t} " "c\\} d\\t\\}"
test list-1.11 {basic tests} "list e\\n} f\\$} " "e\\n\\} f\\$\\}"
test list-1.12 {basic tests} "list g\\;} h\\\\} " "g\\;\\} {h\\}}"
test list-1.13 {basic tests} {list a {{}} b} {a {{}} b}
test list-1.14 {basic tests} {list a b xy\\} "a b xy\\\\"
test list-1.15 {basic tests} "list a b\} e\\" "a b\\} e\\\\"
test list-1.16 {basic tests} "list a b\}\\\$ e\\\$\\" "a b\\}\\\$ e\\\$\\\\"
test list-1.17 {basic tests} {list a\f \{\f} "{a\f} \\\{\\f"
test list-1.18 {basic tests} {list a\r \{\r} "{a\r} \\\{\\r"
test list-1.19 {basic tests} {list a\v \{\v} "{a\v} \\\{\\v"
test list-1.20 {basic tests} {list \"\}\{} "\\\"\\}\\{"
test list-1.21 {basic tests} {list a b c\\\nd} "a b c\\\\\\nd"
test list-1.22 {basic tests} {list "{ab}\\"} \\{ab\\}\\\\
test list-1.23 {basic tests} {list \{} "\\{"
test list-1.24 {basic tests} {list} {}
# For the next round of tests create a list and then pick it apart
# with "index" to make sure that we get back exactly what went in.
set num 0
proc lcheck {testid a b c} {
global num d
set d [list $a $b $c]
test ${testid}-0 {what goes in must come out} {lindex $d 0} $a
test ${testid}-1 {what goes in must come out} {lindex $d 1} $b
test ${testid}-2 {what goes in must come out} {lindex $d 2} $c
}
lcheck list-2.1 a b c
lcheck list-2.2 "a b" c\td e\nf
lcheck list-2.3 {{a b}} {} { }
lcheck list-2.4 \$ \$ab ab\$
lcheck list-2.5 \; \;ab ab\;
lcheck list-2.6 \[ \[ab ab\[
lcheck list-2.7 \\ \\ab ab\\
lcheck list-2.8 {"} {"ab} {ab"} ;#" Stupid emacs highlighting!
lcheck list-2.9 {a b} { ab} {ab }
lcheck list-2.10 a{ a{b \{ab
lcheck list-2.11 a} a}b }ab
lcheck list-2.12 a\\} {a \}b} {a \{c}
lcheck list-2.13 xyz \\ 1\\\n2
lcheck list-2.14 "{ab}\\" "{ab}xy" abc
concat {}
# Check that tclListObj.c's SetListFromAny handles possible overlarge
# string rep lengths in the source object.
proc slowsort list {
set result {}
set last [expr [llength $list] - 1]
while {$last > 0} {
set minIndex [expr [llength $list] - 1]
set min [lindex $list $last]
set i [expr $minIndex-1]
while {$i >= 0} {
if {[string compare [lindex $list $i] $min] < 0} {
set minIndex $i
set min [lindex $list $i]
}
set i [expr $i-1]
}
set result [concat $result [list $min]]
if {$minIndex == 0} {
set list [lrange $list 1 end]
} else {
set list [concat [lrange $list 0 [expr $minIndex-1]] \
[lrange $list [expr $minIndex+1] end]]
}
set last [expr $last-1]
}
return [concat $result $list]
}
test list-3.1 {SetListFromAny and lrange/concat results} {
slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/winPipe.test 0000644 0036047 0045461 00000042613 11737050674 014403 0 ustar dgp 771div #
# winPipe.test --
#
# This file contains a collection of tests for tclWinPipe.c
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest
namespace import -force ::tcltest::*
unset -nocomplain path
testConstraint exec [llength [info commands exec]]
set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
set ::tcltest::testConstraints(cat32) [file exists $cat32]
if {[catch {puts console1 ""}]} {
set ::tcltest::testConstraints(AllocConsole) 1
} else {
set ::tcltest::testConstraints(.console) 1
}
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big
append big $big
append big $big
append big $big
append big $big
set path(little) [makeFile {} little]
set f [open $path(little) w]
puts -nonewline $f "little"
close $f
set path(big) [makeFile {} big]
set f [open $path(big) w]
puts -nonewline $f $big
close $f
proc contents {file} {
set f [open $file r]
set r [read $f]
close $f
set r
}
set path(more) [makeFile {
while {[eof stdin] == 0} {
puts -nonewline [read stdin]
}
} more]
set path(stdout) [makeFile {} stdout]
set path(stderr) [makeFile {} stderr]
test winpipe-1.1 {32 bit comprehensive tests: from little file} {pcOnly exec cat32} {
exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.2 {32 bit comprehensive tests: from big file} {pcOnly exec cat32} {
exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {pcOnly nt exec cat32} {
exec [interpreter] more < little | $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {pcOnly nt exec cat32} {
exec [interpreter] more < big | $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {pcOnly 95 exec cat32} {
exec command /c type big |& $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.6 {32 bit comprehensive tests: from console} \
{pcOnly cat32 AllocConsole} {
# would block waiting for human input
} {}
test winpipe-1.7 {32 bit comprehensive tests: from NUL} {pcOnly exec cat32} {
exec $cat32 < nul > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {{} stderr32}
test winpipe-1.8 {32 bit comprehensive tests: from socket} {pcOnly cat32} {
# doesn't work
} {}
test winpipe-1.9 {32 bit comprehensive tests: from nowhere} \
{pcOnly exec cat32 .console} {
exec $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {{} stderr32}
test winpipe-1.10 {32 bit comprehensive tests: from file handle} \
{pcOnly exec cat32} {
set f [open $path(little) r]
exec $cat32 <@$f > $path(stdout) 2> $path(stderr)
close $f
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.11 {32 bit comprehensive tests: read from application} \
{pcOnly exec cat32} {
set f [open "|[list $cat32] < $path(little)" r]
gets $f line
catch {close $f} msg
list $line $msg
} {little stderr32}
test winpipe-1.12 {32 bit comprehensive tests: a little to file} \
{pcOnly exec cat32} {
exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.13 {32 bit comprehensive tests: a lot to file} \
{pcOnly exec cat32} {
exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.14 {32 bit comprehensive tests: a little to pipe} \
{pcOnly exec stdio cat32} {
exec $cat32 < $path(little) | [interpreter] $path(more) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.15 {32 bit comprehensive tests: a lot to pipe} \
{pcOnly exec stdio cat32} {
exec $cat32 < $path(big) | [interpreter] $path(more) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.16 {32 bit comprehensive tests: to console} {pcOnly exec cat32} {
catch {exec $cat32 << "You should see this\n" >@stdout} msg
set msg
} stderr32
test winpipe-1.17 {32 bit comprehensive tests: to NUL} {pcOnly exec cat32} {
# some apps hang when sending a large amount to NUL. $cat32 isn't one.
catch {exec $cat32 < $path(big) > nul} msg
set msg
} stderr32
test winpipe-1.18 {32 bit comprehensive tests: to nowhere} \
{pcOnly exec cat32 .console} {
exec $cat32 < $path(big) >&@stdout
} {}
test winpipe-1.19 {32 bit comprehensive tests: to file handle} {pcOnly exec cat32} {
set f1 [open $path(stdout) w]
set f2 [open $path(stderr) w]
exec $cat32 < $path(little) >@$f1 2>@$f2
close $f1
close $f2
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.20 {32 bit comprehensive tests: write to application} \
{pcOnly exec cat32} {
set f [open |[list $cat32 >$path(stdout)] w]
puts -nonewline $f "foo"
catch {close $f} msg
list [contents $path(stdout)] $msg
} {foo stderr32}
test winpipe-1.21 {32 bit comprehensive tests: read/write application} \
{pcOnly exec cat32} {
set f [open "|[list $cat32]" r+]
puts $f $big
puts $f \032
flush $f
set r [read $f 64]
catch {close $f}
set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
test winpipe-1.22 {Checking command.com for Win95/98 hanging} {pcOnly 95 exec} {
exec command.com /c dir /b
set result 1
} 1
file delete more
test winpipe-4.1 {Tcl_WaitPid} {pcOnly nt exec cat32} {
proc readResults {f} {
global x result
if { [eof $f] } {
close $f
set x 1
} else {
set line [read $f ]
set result "$result$line"
}
}
set f [open "|[list $cat32] < big 2> $path(stderr)" r]
fconfigure $f -buffering none -blocking 0
fileevent $f readable "readResults $f"
set x 0
set result ""
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {pcOnly exec} {
set f [open "|[tcltest::interpreter]" w+]
set pid [pid $f]
puts $f "testexcept float_underflow"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGFPE}
test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {pcOnly exec} {
set f [open "|[tcltest::interpreter]" w+]
set pid [pid $f]
puts $f "testexcept access_violation"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGSEGV}
test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {pcOnly exec} {
set f [open "|[tcltest::interpreter]" w+]
set pid [pid $f]
puts $f "testexcept illegal_instruction"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGILL}
test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {pcOnly exec} {
set f [open "|[tcltest::interpreter]" w+]
set pid [pid $f]
puts $f "testexcept ctrl+c"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGINT}
set path(nothing) [makeFile {} nothing]
close [open $path(nothing) w]
catch {set env_tmp $env(TMP)}
catch {set env_temp $env(TEMP)}
set env(TMP) c:/
set env(TEMP) c:/
test winpipe-5.1 {TclpCreateTempFile: cleanup temp files} {pcOnly exec} {
set x {}
set existing [glob -nocomplain c:/tcl*.tmp]
exec [interpreter] < nothing
foreach p [glob -nocomplain c:/tcl*.tmp] {
if {[lsearch $existing $p] == -1} {
lappend x $p
}
}
set x
} {}
test winpipe-5.2 {TclpCreateTempFile: TMP and TEMP not defined} {pcOnly exec} {
set tmp $env(TMP)
set temp $env(TEMP)
unset env(TMP)
unset env(TEMP)
exec [interpreter] < nothing
set env(TMP) $tmp
set env(TEMP) $temp
set x {}
} {}
test winpipe-5.3 {TclpCreateTempFile: TMP specifies non-existent directory} \
{pcOnly exec } {
set tmp $env(TMP)
set env(TMP) snarky
exec [interpreter] < nothing
set env(TMP) $tmp
set x {}
} {}
test winpipe-5.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \
{pcOnly exec} {
set tmp $env(TMP)
set temp $env(TEMP)
unset env(TMP)
set env(TEMP) snarky
exec [interpreter] < nothing
set env(TMP) $tmp
set env(TEMP) $temp
set x {}
} {}
test winpipe-6.1 {PipeSetupProc & PipeCheckProc: read threads} \
{pcOnly exec cat32} {
set f [open "|[list $cat32]" r+]
fconfigure $f -blocking 0
fileevent $f writable { set x writable }
set x {}
vwait x
fileevent $f writable {}
fileevent $f readable { lappend x readable }
after 100 { lappend x timeout }
vwait x
puts $f foobar
flush $f
vwait x
lappend x [read $f]
after 100 { lappend x timeout }
vwait x
fconfigure $f -blocking 1
lappend x [catch {close $f} msg] $msg
} {writable timeout readable {foobar
} timeout 1 stderr32}
test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \
{pcOnly exec cat32} {
set f [open "|[list $cat32]" r+]
fconfigure $f -blocking 0
fileevent $f writable { set x writable }
set x {}
vwait x
puts -nonewline $f $big$big$big$big
flush $f
after 100 { lappend x timeout }
vwait x
lappend x [catch {close $f} msg] $msg
} {writable timeout 0 {}}
set path(echoArgs.tcl) [makeFile {
puts "[list $argv0 $argv]"
} echoArgs.tcl]
### validate the raw output of BuildCommandLine().
###
test winpipe-7.1 {BuildCommandLine: null arguments} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo "" bar
} {foo "" bar}
test winpipe-7.2 {BuildCommandLine: null arguments} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {} bar
} {foo "" bar}
test winpipe-7.3 {BuildCommandLine: dbl quote quoting #1} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {"} bar
} {foo \" bar}
test winpipe-7.4 {BuildCommandLine: dbl quote quoting #2} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {""} bar
} {foo \"\" bar}
test winpipe-7.5 {BuildCommandLine: dbl quote quoting #3} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {" } bar
} {foo "\" " bar}
test winpipe-7.6 {BuildCommandLine: dbl quote quoting #4} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {a="b"} bar
} {foo a=\"b\" bar}
test winpipe-7.7 {BuildCommandLine: dbl quote quoting #5} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {a = "b"} bar
} {foo "a = \"b\"" bar}
test winpipe-7.8 {BuildCommandLine: dbl quote quoting #6} {pcOnly exec} {
exec $env(COMSPEC) /c echo {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}
} {\"hello\" \"\"hello\"\" \"\"\"hello\"\"\" \"\\\"hello\\\"\" "he llo" "he \" llo"}
test winpipe-7.9 {BuildCommandLine: N backslashes followed a quote rule #1} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\ bar
} {foo \ bar}
test winpipe-7.10 {BuildCommandLine: N backslashes followed a quote rule #2} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\\ bar
} {foo \\ bar}
test winpipe-7.11 {BuildCommandLine: N backslashes followed a quote rule #3} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\ bar
} {foo "\ \\" bar}
test winpipe-7.12 {BuildCommandLine: N backslashes followed a quote rule #4} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\\\ bar
} {foo "\ \\\\" bar}
test winpipe-7.13 {BuildCommandLine: N backslashes followed a quote rule #5} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\\\\\ bar
} {foo "\ \\\\\\" bar}
test winpipe-7.14 {BuildCommandLine: N backslashes followed a quote rule #6} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\\" bar
} {foo "\ \\\"" bar}
test winpipe-7.15 {BuildCommandLine: N backslashes followed a quote rule #7} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\\\\" bar
} {foo "\ \\\\\"" bar}
test winpipe-7.16 {BuildCommandLine: N backslashes followed a quote rule #8} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\\\\\\" bar
} {foo "\ \\\\\\\"" bar}
test winpipe-7.17 {BuildCommandLine: special chars #4} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \{ bar
} "foo \{ bar"
test winpipe-7.18 {BuildCommandLine: special chars #5} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \} bar
} "foo \} bar"
### validate the pass-thru from BuildCommandLine() to the crt's parse_cmdline().
###
test winpipe-8.1 {BuildCommandLine/parse_cmdline pass-thru: null arguments} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo "" bar
} [list $path(echoArgs.tcl) [list foo {} bar]]
test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: null arguments} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {} bar
} [list $path(echoArgs.tcl) [list foo {} bar]]
test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #1} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {"} bar
} [list $path(echoArgs.tcl) [list foo {"} bar]]
test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #2} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {""} bar
} [list $path(echoArgs.tcl) [list foo {""} bar]]
test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #3} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {" } bar
} [list $path(echoArgs.tcl) [list foo {" } bar]]
test winpipe-8.6 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #4} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {a="b"} bar
} [list $path(echoArgs.tcl) [list foo {a="b"} bar]]
test winpipe-8.7 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #5} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {a = "b"} bar
} [list $path(echoArgs.tcl) [list foo {a = "b"} bar]]
test winpipe-8.8 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #6} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}
} [list $path(echoArgs.tcl) [list {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}]]
test winpipe-8.9 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #1} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\ bar
} [list $path(echoArgs.tcl) [list foo \\ bar]]
test winpipe-8.10 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #2} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\\ bar
} [list $path(echoArgs.tcl) [list foo \\\\ bar]]
test winpipe-8.11 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #3} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\ bar
} [list $path(echoArgs.tcl) [list foo \\\ \\ bar]]
test winpipe-8.12 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #4} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\ bar
} [list $path(echoArgs.tcl) [list foo \\\ \\\\ bar]]
test winpipe-8.13 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #5} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\\ bar
} [list $path(echoArgs.tcl) [list foo \\\ \\\\\\ bar]]
test winpipe-8.14 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #6} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\" bar
} [list $path(echoArgs.tcl) [list foo \\\ \\\" bar]]
test winpipe-8.15 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #7} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\" bar
} [list $path(echoArgs.tcl) [list foo \\\ \\\\\" bar]]
test winpipe-8.16 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #8} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\\\" bar
} [list $path(echoArgs.tcl) [list foo \\\ \\\\\\\" bar]]
test winpipe-8.17 {BuildCommandLine/parse_cmdline pass-thru: special chars #1} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \{ bar
} [list $path(echoArgs.tcl) [list foo \{ bar]]
test winpipe-8.18 {BuildCommandLine/parse_cmdline pass-thru: special chars #2} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \} bar
} [list $path(echoArgs.tcl) [list foo \} bar]]
test winpipe-8.19 {ensure parse_cmdline isn't doing wildcard replacement} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo * makefile.?c bar
} [list $path(echoArgs.tcl) [list foo * makefile.?c bar]]
# restore old values for env(TMP) and env(TEMP)
if {[catch {set env(TMP) $env_tmp}]} {
unset env(TMP)
}
if {[catch {set env(TEMP) $env_temp}]} {
unset env(TEMP)
}
# cleanup
file delete big little stdout stderr nothing echoArgs.tcl
::tcltest::cleanupTests
return
tcl8.4.20/tests/pid.test 0000644 0036047 0045461 00000003654 11737050674 013546 0 ustar dgp 771div # Commands covered: pid
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# If pid is not defined just return with no error
# Some platforms may not have the pid command implemented
if {[info commands pid] == ""} {
puts "pid is not implemented for this machine"
::tcltest::cleanupTests
return
}
test pid-1.1 {pid command} {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
test pid-1.2 {pid command} -constraints {unixOrPc unixExecs} -setup {
set path(test1) [makeFile {} test1]
file delete $path(test1)
} -body {
set f [open |[list echo foo | cat >$path(test1)] w]
set pids [pid $f]
close $f
list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \
[regexp {^[0-9]+$} [lindex $pids 1]] \
[expr {[lindex $pids 0] == [lindex $pids 1]}]
} -cleanup {
removeFile test1
} -result {2 1 1 0}
test pid-1.3 {pid command} -setup {
set path(test1) [makeFile {} test1]
file delete $path(test1)
} -body {
set f [open $path(test1) w]
set pids [pid $f]
close $f
set pids
} -cleanup {
removeFile test1
} -result {}
test pid-1.4 {pid command} {
list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channelId?"}}
test pid-1.5 {pid command} {
list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/winTime.test 0000644 0036047 0045461 00000003655 11737050674 014407 0 ustar dgp 771div # This file tests the tclWinTime.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testwinclock [llength [info commands testwinclock]]
# The next two tests will crash on Windows if the check for negative
# clock values is not done properly.
test winTime-1.1 {TclpGetDate} {pcOnly} {
set ::env(TZ) JST-9
set result [clock format -1 -format %Y]
unset ::env(TZ)
set result
} {1970}
test winTime-1.2 {TclpGetDate} {pcOnly} {
set ::env(TZ) PST8
set result [clock format 1 -format %Y]
unset ::env(TZ)
set result
} {1969}
# Next test tries to make sure that the Tcl clock stays in step
# with the Windows clock. 30 sec really isn't enough,
# but how much time does a tester have patience for?
test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock} {
# May fail due to OS/hardware discrepancies. See:
# http://support.microsoft.com/default.aspx?scid=kb;en-us;274323
set failed {}
set ok 1
foreach start_sec [testwinclock] break
while { 1 } {
foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break
set diff [expr { $tcl_sec - $sys_sec
+ 1.0e-6 * ( $tcl_usec - $sys_usec ) }]
if { abs($diff) > 0.06 } {
set failed "Tcl clock differs from system clock by $diff sec"
break
} else {
testwinsleep 1
}
if { $sys_sec - $start_sec >= 30 } break
}
set failed
} {}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/reg.test 0000644 0036047 0045461 00000073561 11737050674 013553 0 ustar dgp 771div # reg.test --
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
# (Don't panic if you are seeing this as part of the reg distribution
# and aren't using Tcl -- reg's own regression tester also knows how
# to read this file, ignoring the Tcl-isms.)
#
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# All tests require the testregexp command, return if this
# command doesn't exist
::tcltest::testConstraint testregexp \
[expr {[info commands testregexp] != {}}]
::tcltest::testConstraint localeRegexp 0
# This file uses some custom procedures, defined below, for regexp regression
# testing. The name of the procedure indicates the general nature of the
# test:
# e compile error expected
# f match failure expected
# m successful match
# i successful match with -indices (used in checking things like
# nonparticipating subexpressions)
# p unsuccessful match with -indices (!!) (used in checking
# partial-match reporting)
# There is also "doing" which sets up title and major test number for each
# block of tests.
# The first 3 arguments are constant: a minor number (which often gets
# a letter or two suffixed to it internally), some flags, and the RE itself.
# For e, the remaining argument is the name of the compile error expected,
# less the leading "REG_". For the rest, the next argument is the string
# to try the match against. Remaining arguments are the substring expected
# to be matched, and any substrings expected to be matched by subexpressions.
# (For f, these arguments are optional, and if present are ignored except
# that they indicate how many subexpressions should be present in the RE.)
# It is an error for the number of subexpression arguments to be wrong.
# Cases involving nonparticipating subexpressions, checking where empty
# substrings are located, etc. should be done using i and p.
# The flag characters are complex and a bit eclectic. Generally speaking,
# lowercase letters are compile options, uppercase are expected re_info
# bits, and nonalphabetics are match options, controls for how the test is
# run, or testing options. The one small surprise is that AREs are the
# default, and you must explicitly request lesser flavors of RE. The flags
# are as follows. It is admitted that some are not very mnemonic.
# There are some others which are purely debugging tools and are not
# useful in this file.
#
# - no-op (placeholder)
# + provide fake xy equivalence class and ch collating element
# % force small state-set cache in matcher (to test cache replace)
# ^ beginning of string is not beginning of line
# $ end of string is not end of line
# * test is Unicode-specific, needs big character set
#
# & test as both ARE and BRE
# b BRE
# e ERE
# a turn advanced-features bit on (error unless ERE already)
# q literal string, no metacharacters at all
#
# i case-independent matching
# o ("opaque") no subexpression capture
# p newlines are half-magic, excluded from . and [^ only
# w newlines are half-magic, significant to ^ and $ only
# n newlines are fully magic, both effects
# x expanded RE syntax
# t incomplete-match reporting
#
# A backslash-_a_lphanumeric seen
# B ERE/ARE literal-_b_race heuristic used
# E backslash (_e_scape) seen within []
# H looka_h_ead constraint seen
# I _i_mpossible to match
# L _l_ocale-specific construct seen
# M unportable (_m_achine-specific) construct seen
# N RE can match empty (_n_ull) string
# P non-_P_OSIX construct seen
# Q {} _q_uantifier seen
# R back _r_eference seen
# S POSIX-un_s_pecified syntax seen
# T prefers shortest (_t_iny)
# U saw original-POSIX botch: unmatched right paren in ERE (_u_gh)
# The one area we can't easily test is memory-allocation failures (which
# are hard to provoke on command). Embedded NULs also are not tested at
# the moment, but this is a historical accident which should be fixed.
# test procedures and related
set ask "about"
set xflags "xflags"
set testbypassed 0
# re_info abbreviation mapping table
set infonames(A) "REG_UBSALNUM"
set infonames(B) "REG_UBRACES"
set infonames(E) "REG_UBBS"
set infonames(H) "REG_ULOOKAHEAD"
set infonames(I) "REG_UIMPOSSIBLE"
set infonames(L) "REG_ULOCALE"
set infonames(M) "REG_UUNPORT"
set infonames(N) "REG_UEMPTYMATCH"
set infonames(P) "REG_UNONPOSIX"
set infonames(Q) "REG_UBOUNDS"
set infonames(R) "REG_UBACKREF"
set infonames(S) "REG_UUNSPEC"
set infonames(T) "REG_USHORTEST"
set infonames(U) "REG_UPBOTCH"
set infonameorder "RHQBAUEPSMLNIT" ;# must match bit order, lsb first
# set major test number and description
proc doing {major desc} {
global prefix description testbypassed
if {$testbypassed != 0} {
puts stdout "!!! bypassed $testbypassed tests in\
$prefix, `$description'"
}
set prefix reg-$major
set description "reg $desc"
set testbypassed 0
}
# build test number (internal)
proc tno {testid} {
return [join $testid .]
}
# build description, with possible modifiers (internal)
proc desc {testid} {
global description
set d $description
if {[llength $testid] > 1} {
set d "([lreplace $testid 0 0]) $d"
}
return $d
}
# build trailing options and flags argument from a flags string (internal)
proc flags {fl} {
global xflags
set args [list]
set flags ""
foreach f [split $fl ""] {
switch -exact -- $f {
"i" { lappend args "-nocase" }
"x" { lappend args "-expanded" }
"n" { lappend args "-line" }
"p" { lappend args "-linestop" }
"w" { lappend args "-lineanchor" }
"-" { }
default { append flags $f }
}
}
if {[string compare $flags ""] != 0} {
lappend args -$xflags $flags
}
return $args
}
# build info-flags list from a flags string (internal)
proc infoflags {fl} {
global infonames infonameorder
set ret [list]
foreach f [split $infonameorder ""] {
if {[string first $f $fl] >= 0} {
lappend ret $infonames($f)
}
}
return $ret
}
# compilation error expected
proc e {testid flags re err} {
global prefix ask errorCode
# Tcl locale stuff doesn't do the ch/xy test fakery yet
if {[string first "+" $flags] >= 0} {
# This will register as a skipped test
test $prefix.[tno $testid] [desc $testid] localeRegexp {} {}
return
}
# if &, test as both ARE and BRE
set amp [string first "&" $flags]
if {$amp >= 0} {
set f [string range $flags 0 [expr $amp - 1]]
append f [string range $flags [expr $amp + 1] end]
e [linsert $testid end ARE] ${f} $re $err
e [linsert $testid end BRE] ${f}b $re $err
return
}
set cmd [concat [list testregexp -$ask] [flags $flags] [list $re]]
set run "list \[catch \{$cmd\}\] \[lindex \$errorCode 1\]"
test $prefix.[tno $testid] [desc $testid] \
{testregexp} $run [list 1 REG_$err]
}
# match failure expected
proc f {testid flags re target args} {
global prefix description ask
# Tcl locale stuff doesn't do the ch/xy test fakery yet
if {[string first "+" $flags] >= 0} {
# This will register as a skipped test
test $prefix.[tno $testid] [desc $testid] localeRegexp {} {}
return
}
# if &, test as both ARE and BRE
set amp [string first "&" $flags]
if {$amp >= 0} {
set f [string range $flags 0 [expr $amp - 1]]
append f [string range $flags [expr $amp + 1] end]
eval [linsert $args 0 f [linsert $testid end ARE] ${f} $re \
$target]
eval [linsert $args 0 f [linsert $testid end BRE] ${f}b $re \
$target]
return
}
set f [flags $flags]
set infoflags [infoflags $flags]
set ccmd [concat [list testregexp -$ask] $f [list $re]]
set nsub [expr [llength $args] - 1]
if {$nsub == -1} {
# didn't tell us number of subexps
set ccmd "lreplace \[$ccmd\] 0 0"
set info [list $infoflags]
} else {
set info [list $nsub $infoflags]
}
lappend testid "compile"
test $prefix.[tno $testid] [desc $testid] {testregexp} $ccmd $info
set testid [lreplace $testid end end "execute"]
set ecmd [concat [list testregexp] $f [list $re $target]]
test $prefix.[tno $testid] [desc $testid] {testregexp} $ecmd 0
}
# match expected, internal routine that does the work
# parameters like the "real" routines except they don't have "opts",
# which is a possibly-empty list of switches for the regexp match attempt
# The ! flag is used to indicate expected match failure (for REG_EXPECT,
# which wants argument testing even in the event of failure).
proc matchexpected {opts testid flags re target args} {
global prefix description ask regBug
if {[info exists regBug] && $regBug} {
# This will register as a skipped test
test $prefix.[tno $testid] [desc $testid] knownBug {format 0} {1}
return
}
# Tcl locale stuff doesn't do the ch/xy test fakery yet
if {[string first "+" $flags] >= 0} {
# This will register as a skipped test
test $prefix.[tno $testid] [desc $testid] localeRegexp {} {}
return
}
# if &, test as both BRE and ARE
set amp [string first "&" $flags]
if {$amp >= 0} {
set f [string range $flags 0 [expr $amp - 1]]
append f [string range $flags [expr $amp + 1] end]
eval [concat [list matchexpected $opts \
[linsert $testid end ARE] ${f} $re $target] $args]
eval [concat [list matchexpected $opts \
[linsert $testid end BRE] ${f}b $re $target] $args]
return
}
set f [flags $flags]
set infoflags [infoflags $flags]
set ccmd [concat [list testregexp -$ask] $f [list $re]]
set ecmd [concat [list testregexp] $opts $f [list $re $target]]
set nsub [expr [llength $args] - 1]
set names [list]
set refs ""
for {set i 0} {$i <= $nsub} {incr i} {
if {$i == 0} {
set name match
} else {
set name sub$i
}
lappend names $name
append refs " \$$name"
set $name ""
}
if {[string first "o" $flags] >= 0} { ;# REG_NOSUB kludge
set nsub 0 ;# unsigned value cannot be -1
}
if {[string first "t" $flags] >= 0} { ;# REG_EXPECT
incr nsub -1 ;# the extra does not count
}
set ecmd [concat $ecmd $names]
set erun "list \[$ecmd\] $refs"
set retcode [list 1]
if {[string first "!" $flags] >= 0} {
set retcode [list 0]
}
set result [concat $retcode $args]
set info [list $nsub $infoflags]
lappend testid "compile"
test $prefix.[tno $testid] [desc $testid] {testregexp} $ccmd $info
set testid [lreplace $testid end end "execute"]
test $prefix.[tno $testid] [desc $testid] {testregexp} $erun $result
}
# match expected (no missing, empty, or ambiguous submatches)
# m testno flags re target mat submat ...
proc m {args} {
eval matchexpected [linsert $args 0 [list]]
}
# match expected (full fanciness)
# i testno flags re target mat submat ...
proc i {args} {
eval matchexpected [linsert $args 0 [list "-indices"]]
}
# partial match expected
# p testno flags re target mat "" ...
# Quirk: number of ""s must be one more than number of subREs.
proc p {args} {
set f [lindex $args 1] ;# add ! flag
set args [lreplace $args 1 1 "!$f"]
eval matchexpected [linsert $args 0 [list "-indices"]]
}
# test is a knownBug
proc knownBug {args} {
set ::regBug 1
uplevel #0 $args
set ::regBug 0
}
# the tests themselves
# support functions and preliminary misc.
# This is sensitive to changes in message wording, but we really have to
# test the code->message expansion at least once.
test reg-0.1 "regexp error reporting" {
list [catch {regexp (*) ign} msg] $msg
} {1 {couldn't compile regular expression pattern: quantifier operand invalid}}
doing 1 "basic sanity checks"
m 1 & abc abc abc
f 2 & abc def
m 3 & abc xyabxabce abc
doing 2 "invalid option combinations"
e 1 qe a INVARG
e 2 qa a INVARG
e 3 qx a INVARG
e 4 qn a INVARG
e 5 ba a INVARG
doing 3 "basic syntax"
i 1 &NS "" a {0 -1}
m 2 NS a| a a
m 3 - a|b a a
m 4 - a|b b b
m 5 NS a||b b b
m 6 & ab ab ab
doing 4 "parentheses"
m 1 - (a)e ae ae a
m 2 o (a)e ae
m 3 b {\(a\)b} ab ab a
m 4 - a((b)c) abc abc bc b
m 5 - a(b)(c) abc abc b c
e 6 - a(b EPAREN
e 7 b {a\(b} EPAREN
# sigh, we blew it on the specs here... someday this will be fixed in POSIX,
# but meanwhile, it's fixed in AREs
m 8 eU a)b a)b a)b
e 9 - a)b EPAREN
e 10 b {a\)b} EPAREN
m 11 P a(?:b)c abc abc
e 12 e a(?:b)c BADRPT
i 13 S a()b ab {0 1} {1 0}
m 14 SP a(?:)b ab ab
i 15 S a(|b)c ac {0 1} {1 0}
m 16 S a(b|)c abc abc b
doing 5 "simple one-char matching"
# general case of brackets done later
m 1 & a.b axb axb
f 2 &n "a.b" "a\nb"
m 3 & {a[bc]d} abd abd
m 4 & {a[bc]d} acd acd
f 5 & {a[bc]d} aed
f 6 & {a[^bc]d} abd
m 7 & {a[^bc]d} aed aed
f 8 &p "a\[^bc]d" "a\nd"
doing 6 "context-dependent syntax"
# plus odds and ends
e 1 - * BADRPT
m 2 b * * *
m 3 b {\(*\)} * * *
e 4 - (*) BADRPT
m 5 b ^* * *
e 6 - ^* BADRPT
f 7 & ^b ^b
m 8 b x^ x^ x^
f 9 I x^ x
m 10 n "\n^" "x\nb" "\n"
f 11 bS {\(^b\)} ^b
m 12 - (^b) b b b
m 13 & {x$} x x
m 14 bS {\(x$\)} x x x
m 15 - {(x$)} x x x
m 16 b {x$y} "x\$y" "x\$y"
f 17 I {x$y} xy
m 18 n "x\$\n" "x\n" "x\n"
e 19 - + BADRPT
e 20 - ? BADRPT
doing 7 "simple quantifiers"
m 1 &N a* aa aa
i 2 &N a* b {0 -1}
m 3 - a+ aa aa
m 4 - a?b ab ab
m 5 - a?b b b
e 6 - ** BADRPT
m 7 bN ** *** ***
e 8 & a** BADRPT
e 9 & a**b BADRPT
e 10 & *** BADRPT
e 11 - a++ BADRPT
e 12 - a?+ BADRPT
e 13 - a?* BADRPT
e 14 - a+* BADRPT
e 15 - a*+ BADRPT
doing 8 "braces"
m 1 NQ "a{0,1}" "" ""
m 2 NQ "a{0,1}" ac a
e 3 - "a{1,0}" BADBR
e 4 - "a{1,2,3}" BADBR
e 5 - "a{257}" BADBR
e 6 - "a{1000}" BADBR
e 7 - "a{1" EBRACE
e 8 - "a{1n}" BADBR
m 9 BS "a{b" "a\{b" "a\{b"
m 10 BS "a{" "a\{" "a\{"
m 11 bQ "a\\{0,1\\}b" cb b
e 12 b "a\\{0,1" EBRACE
e 13 - "a{0,1\\" BADBR
m 14 Q "a{0}b" ab b
m 15 Q "a{0,0}b" ab b
m 16 Q "a{0,1}b" ab ab
m 17 Q "a{0,2}b" b b
m 18 Q "a{0,2}b" aab aab
m 19 Q "a{0,}b" aab aab
m 20 Q "a{1,1}b" aab ab
m 21 Q "a{1,3}b" aaaab aaab
f 22 Q "a{1,3}b" b
m 23 Q "a{1,}b" aab aab
f 24 Q "a{2,3}b" ab
m 25 Q "a{2,3}b" aaaab aaab
f 26 Q "a{2,}b" ab
m 27 Q "a{2,}b" aaaab aaaab
doing 9 "brackets"
m 1 & {a[bc]} ac ac
m 2 & {a[-]} a- a-
m 3 & {a[[.-.]]} a- a-
m 4 &L {a[[.zero.]]} a0 a0
m 5 &LM {a[[.zero.]-9]} a2 a2
m 6 &M {a[0-[.9.]]} a2 a2
m 7 &+L {a[[=x=]]} ax ax
m 8 &+L {a[[=x=]]} ay ay
f 9 &+L {a[[=x=]]} az
e 10 & {a[0-[=x=]]} ERANGE
m 11 &L {a[[:digit:]]} a0 a0
e 12 & {a[[:woopsie:]]} ECTYPE
f 13 &L {a[[:digit:]]} ab
e 14 & {a[0-[:digit:]]} ERANGE
m 15 &LP {[[:<:]]a} a a
m 16 &LP {a[[:>:]]} a a
e 17 & {a[[..]]b} ECOLLATE
e 18 & {a[[==]]b} ECOLLATE
e 19 & {a[[::]]b} ECTYPE
e 20 & {a[[.a} EBRACK
e 21 & {a[[=a} EBRACK
e 22 & {a[[:a} EBRACK
e 23 & {a[} EBRACK
e 24 & {a[b} EBRACK
e 25 & {a[b-} EBRACK
e 26 & {a[b-c} EBRACK
m 27 &M {a[b-c]} ab ab
m 28 & {a[b-b]} ab ab
m 29 &M {a[1-2]} a2 a2
e 30 & {a[c-b]} ERANGE
e 31 & {a[a-b-c]} ERANGE
m 32 &M {a[--?]b} a?b a?b
m 33 & {a[---]b} a-b a-b
m 34 & {a[]b]c} a]c a]c
m 35 EP {a[\]]b} a]b a]b
f 36 bE {a[\]]b} a]b
m 37 bE {a[\]]b} "a\\]b" "a\\]b"
m 38 eE {a[\]]b} "a\\]b" "a\\]b"
m 39 EP {a[\\]b} "a\\b" "a\\b"
m 40 eE {a[\\]b} "a\\b" "a\\b"
m 41 bE {a[\\]b} "a\\b" "a\\b"
e 42 - {a[\Z]b} EESCAPE
m 43 & {a[[b]c} "a\[c" "a\[c"
m 44 EMP* {a[\u00fe-\u0507][\u00ff-\u0300]b} \
"a\u0102\u02ffb" "a\u0102\u02ffb"
doing 10 "anchors and newlines"
m 1 & ^a a a
f 2 &^ ^a a
i 3 &N ^ a {0 -1}
i 4 & {a$} aba {2 2}
f 5 {&$} {a$} a
i 6 &N {$} ab {2 1}
m 7 &n ^a a a
m 8 &n "^a" "b\na" "a"
i 9 &w "^a" "a\na" {0 0}
i 10 &n^ "^a" "a\na" {2 2}
m 11 &n {a$} a a
m 12 &n "a\$" "a\nb" "a"
i 13 &n "a\$" "a\na" {0 0}
i 14 N ^^ a {0 -1}
m 15 b ^^ ^ ^
i 16 N {$$} a {1 0}
m 17 b {$$} "\$" "\$"
m 18 &N {^$} "" ""
f 19 &N {^$} a
i 20 &nN "^\$" "a\n\nb" {2 1}
m 21 N {$^} "" ""
m 22 b {$^} "\$^" "\$^"
m 23 P {\Aa} a a
m 24 ^P {\Aa} a a
f 25 ^nP {\Aa} "b\na"
m 26 P {a\Z} a a
m 27 {$P} {a\Z} a a
f 28 {$nP} {a\Z} "a\nb"
e 29 - ^* BADRPT
e 30 - {$*} BADRPT
e 31 - {\A*} BADRPT
e 32 - {\Z*} BADRPT
doing 11 "boundary constraints"
m 1 &LP {[[:<:]]a} a a
m 2 &LP {[[:<:]]a} -a a
f 3 &LP {[[:<:]]a} ba
m 4 &LP {a[[:>:]]} a a
m 5 &LP {a[[:>:]]} a- a
f 6 &LP {a[[:>:]]} ab
m 7 bLP {\} a a
f 10 bLP {a\>} ab
m 11 LP {\ya} a a
f 12 LP {\ya} ba
m 13 LP {a\y} a a
f 14 LP {a\y} ab
m 15 LP {a\Y} ab a
f 16 LP {a\Y} a-
f 17 LP {a\Y} a
f 18 LP {-\Y} -a
m 19 LP {-\Y} -% -
f 20 LP {\Y-} a-
e 21 - {[[:<:]]*} BADRPT
e 22 - {[[:>:]]*} BADRPT
e 23 b {\<*} BADRPT
e 24 b {\>*} BADRPT
e 25 - {\y*} BADRPT
e 26 - {\Y*} BADRPT
m 27 LP {\ma} a a
f 28 LP {\ma} ba
m 29 LP {a\M} a a
f 30 LP {a\M} ab
f 31 ILP {\Ma} a
f 32 ILP {a\m} a
doing 12 "character classes"
m 1 LP {a\db} a0b a0b
f 2 LP {a\db} axb
f 3 LP {a\Db} a0b
m 4 LP {a\Db} axb axb
m 5 LP "a\\sb" "a b" "a b"
m 6 LP "a\\sb" "a\tb" "a\tb"
m 7 LP "a\\sb" "a\nb" "a\nb"
f 8 LP {a\sb} axb
m 9 LP {a\Sb} axb axb
f 10 LP "a\\Sb" "a b"
m 11 LP {a\wb} axb axb
f 12 LP {a\wb} a-b
f 13 LP {a\Wb} axb
m 14 LP {a\Wb} a-b a-b
m 15 LP {\y\w+z\y} adze-guz guz
m 16 LPE {a[\d]b} a1b a1b
m 17 LPE "a\[\\s]b" "a b" "a b"
m 18 LPE {a[\w]b} axb axb
doing 13 "escapes"
e 1 & "a\\" EESCAPE
m 2 - {a\]+)>} a
} 1
test reg-33.4 {Bug 505048} {
regexp {\A\s*([^b]*)b} ab
} 1
test reg-33.5 {Bug 505048} {
regexp {\A\s*[^b]*(b)} ab
} 1
test reg-33.6 {Bug 505048} {
regexp {\A(\s*)[^b]*(b)} ab
} 1
test reg-33.7 {Bug 505048} {
regexp {\A\s*[^b]*b} ab
} 1
test reg-33.8 {Bug 505048} {
regexp -inline {\A\s*[^b]*b} ab
} ab
test reg-33.9 {Bug 505048} {
regexp -indices -inline {\A\s*[^b]*b} ab
} {{0 1}}
test reg-33.10 {Bug 840258} {
regsub {(^|\n)+\.*b} \n.b {} tmp
} 1
test reg-33.11 {Bug 840258} {
regsub {(^|[\n\r]+)\.*\?<.*?(\n|\r)+} \
"TQ\r\n.?<5000267>Test already stopped\r\n" {} tmp
} 1
test reg-33.12 {Bug 1810264 - bad read} {
regexp {\3161573148} {\3161573148}
} 0
test reg-33.13 {Bug 1810264 - infinite loop} {
regexp {($|^)*} {x}
} 1
test reg-33.14 {Bug 1810264 - super-expensive expression} {
set start [clock seconds]
regexp {(x{100}){100}$y} {x}
set time [expr {[clock seconds] - $start}]
expr {$time < 5 ? "ok" : "Complex RE took $time seconds - bad!"}
} ok
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/notify.test 0000755 0036047 0045461 00000021050 11737050674 014273 0 ustar dgp 771div # -*- tcl -*-
#
# notify.test --
#
# This file tests several functions in the file, 'generic/tclNotify.c'.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testevent [llength [info commands testevent]]
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one tail {lappend delivered one; expr 1}
vwait done
set delivered
} \
-result {one}
test notify-1.2 {Tcl_QueueEvent and delivery of events in order} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one tail {lappend delivered one; expr 1}
testevent queue two tail {lappend delivered two; expr 1}
testevent queue three tail {lappend delivered three; expr 1}
vwait done
set delivered
} \
-result {one two three}
test notify-1.3 {Tcl_QueueEvent at head} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one head {lappend delivered one; expr 1}
vwait done
set delivered
} \
-result one
test notify-1.4 {Tcl_QueueEvent multiple events at head} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one head {lappend delivered one; expr 1}
testevent queue two head {lappend delivered two; expr 1}
testevent queue three head {lappend delivered three; expr 1}
vwait done
set delivered
} \
-result {three two one}
test notify-1.5 {Tcl_QueueEvent marker event into an empty queue} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one mark {lappend delivered one; expr 1}
vwait done
set delivered
} \
-result one
test notify-1.6 {Tcl_QueueEvent first marker event in a nonempty queue} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one tail {lappend delivered one; expr 1}
testevent queue two mark {lappend delivered two; expr 1}
testevent queue three head {lappend delivered three; expr 1}
vwait done
set delivered
} \
-result {three two one}
test notify-1.7 {Tcl_QueueEvent second marker event} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one mark {lappend delivered one; expr 1}
testevent queue two mark {lappend delivered two; expr 1}
vwait done
set delivered
} \
-result {one two}
test notify-1.8 {Tcl_QueueEvent preexisting event following second marker} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one mark {lappend delivered one; expr 1}
testevent queue two tail {lappend delivered two; expr 1}
testevent queue three mark {lappend delivered three; expr 1}
vwait done
set delivered
} \
-result {one three two}
test notify-2.1 {remove sole element, don't replace } \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one tail {lappend delivered one; expr 1}
testevent delete one
vwait done
set delivered
} \
-result {}
test notify-2.2 {remove and replace sole element} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one tail {lappend delivered one; expr 1}
testevent delete one
testevent queue two tail {lappend delivered two; expr 1}
vwait done
set delivered
} \
-result two
test notify-2.3 {remove first element} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one tail {lappend delivered one; expr 1}
testevent queue two tail {lappend delivered two; expr 1}
testevent delete one
vwait done
set delivered
} \
-result {two}
test notify-2.4 {remove and replace first element} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one tail {lappend delivered one; expr 1}
testevent queue two tail {lappend delivered two; expr 1}
testevent delete one
testevent queue three head {lappend delivered three; expr 1};
vwait done
set delivered
} \
-result {three two}
test notify-2.5 {remove last element} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one tail {lappend delivered one; expr 1}
testevent queue two tail {lappend delivered two; expr 1}
testevent delete two
vwait done
set delivered
} \
-result {one}
test notify-2.6 {remove and replace last element} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one tail {lappend delivered one; expr 1}
testevent queue two tail {lappend delivered two; expr 1}
testevent delete two
testevent queue three tail {lappend delivered three; expr 1};
vwait done
set delivered
} \
-result {one three}
test notify-2.7 {remove a middle element} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one tail {lappend delivered one; expr 1}
testevent queue two tail {lappend delivered two; expr 1}
testevent queue three tail {lappend delivered three; expr 1}
testevent delete two
vwait done
set delivered
} \
-result {one three}
test notify-2.8 {remove a marker event that's the sole event in the queue} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one mark {lappend delivered one; expr 1}
testevent delete one
vwait done
set delivered
} \
-result {}
test notify-2.9 {remove and replace a marker event that's the sole event} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one mark {lappend delivered one; expr 1}
testevent delete one
testevent queue two mark {lappend delivered two; expr 1}
vwait done
set delivered
} \
-result two
test notify-2.10 {remove marker event from head} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one mark {lappend delivered one; expr 1}
testevent queue two mark {lappend delivered two; expr 1}
testevent delete one
vwait done
set delivered
} \
-result two
test notify-2.11 {remove and replace marker event at head} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one mark {lappend delivered one; expr 1}
testevent queue two tail {lappend delivered two; expr 1}
testevent delete one
testevent queue three mark {lappend delivered three; expr 1}
vwait done
set delivered
} \
-result {three two}
test notify-2.12 {remove marker event at tail} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one mark {lappend delivered one; expr 1}
testevent queue two mark {lappend delivered two; expr 1}
testevent delete two
vwait done
set delivered
} \
-result {one}
test notify-2.13 {remove and replace marker event at tail} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one mark {lappend delivered one; expr 1}
testevent queue two mark {lappend delivered two; expr 1}
testevent delete two
testevent queue three mark {lappend delivered three; expr 1}
vwait done
set delivered
} \
-result {one three}
test notify-2.14 {remove marker event from middle} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one mark {lappend delivered one; expr 1}
testevent queue two mark {lappend delivered two; expr 1}
testevent queue three mark {lappend delivered three; expr 1}
testevent delete two
vwait done
set delivered
} \
-result {one three}
test notify-2.15 {remove and replace marker event at middle} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
testevent queue one mark {lappend delivered one; expr 1}
testevent queue two mark {lappend delivered two; expr 1}
testevent queue three tail {lappend delivered three; expr 1}
testevent delete two
testevent queue four mark {lappend delivered four; expr 1};
vwait done
set delivered
} \
-result {one four three}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/unknown.test 0000644 0036047 0045461 00000003515 11737050674 014465 0 ustar dgp 771div # Commands covered: unknown
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset x}
catch {rename unknown unknown.old}
test unknown-1.1 {non-existent "unknown" command} {
list [catch {_non-existent_ foo bar} msg] $msg
} {1 {invalid command name "_non-existent_"}}
proc unknown {args} {
global x
set x $args
}
test unknown-2.1 {calling "unknown" command} {
foobar x y z
set x
} {foobar x y z}
test unknown-2.2 {calling "unknown" command with lots of args} {
foobar 1 2 3 4 5 6 7
set x
} {foobar 1 2 3 4 5 6 7}
test unknown-2.3 {calling "unknown" command with lots of args} {
foobar 1 2 3 4 5 6 7 8
set x
} {foobar 1 2 3 4 5 6 7 8}
test unknown-2.4 {calling "unknown" command with lots of args} {
foobar 1 2 3 4 5 6 7 8 9
set x
} {foobar 1 2 3 4 5 6 7 8 9}
test unknown-3.1 {argument quoting in calls to "unknown"} {
foobar \{ \} a\{b \; "\\" \$a a\[b \]
set x
} "foobar \\{ \\} a\\{b {;} \\\\ {\$a} {a\[b} \\]"
proc unknown args {
error "unknown failed"
}
test unknown-4.1 {errors in "unknown" procedure} {
list [catch {non-existent a b} msg] $msg $errorCode
} {1 {unknown failed} NONE}
# cleanup
catch {rename unknown {}}
catch {rename unknown.old unknown}
::tcltest::cleanupTests
return
tcl8.4.20/tests/io.test 0000644 0036047 0045461 00000644560 12052456744 013407 0 ustar dgp 771div # -*- tcl -*-
# Functionality covered: operation of all IO commands, and all procedures
# defined in generic/tclIO.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::interpreter
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::test
namespace import ::tcltest::testConstraint
namespace import ::tcltest::viewFile
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0
# set up a long data file for some of the following tests
set path(longfile) [makeFile {} longfile]
set f [open $path(longfile) w]
fconfigure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
\#123456789abcdef01
\#"
}
close $f
set path(cat) [makeFile {
set f stdin
if {$argv != ""} {
set f [open [lindex $argv 0]]
}
fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a
fconfigure stdout -encoding binary -translation lf -buffering none
fileevent $f readable "foo $f"
proc foo {f} {
set x [read $f]
catch {puts -nonewline $x}
if {[eof $f]} {
close $f
exit 0
}
}
vwait forever
} cat]
set thisScript [file join [pwd] [info script]]
proc contents {file} {
set f [open $file]
fconfigure $f -translation binary
set a [read $f]
close $f
return $a
}
test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
# no test, need to cause an async error.
} {}
set path(test1) [makeFile {} test1]
test io-1.6 {Tcl_WriteChars: WriteBytes} {
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "a\u4e4d\0"
close $f
contents $path(test1)
} "a\x4d\x00"
test io-1.7 {Tcl_WriteChars: WriteChars} {
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
puts -nonewline $f "a\u4e4d\0"
close $f
contents $path(test1)
} "a\x93\xe1\x00"
set path(test2) [makeFile {} test2]
test io-1.8 {Tcl_WriteChars: WriteChars} {
# This test written for SF bug #506297.
#
# Executing this test without the fix for the referenced bug
# applied to tcl will cause tcl, more specifically WriteChars, to
# go into an infinite loop.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp
puts -nonewline $f [format %s%c [string repeat " " 4] 12399]
close $f
contents $path(test2)
} " \x1b\$B\$O\x1b(B"
test io-1.9 {Tcl_WriteChars: WriteChars} {
# When closing a channel with an encoding that appends
# escape bytes, check for the case where the escape
# bytes overflow the current IO buffer. The bytes
# should be moved into a new buffer.
set data "1234567890 [format %c 12399]"
set sizes [list]
# With default buffer size
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size equal to the length
# of the data, the escape bytes would
# go into the next buffer.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 16
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size that is large enough
# to hold 1 byte of escaped data, but
# not all 3. This should not write
# the escape bytes to the first buffer
# and then again to the second buffer.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 17
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size that can hold 2 out of
# 3 bytes of escaped data.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 18
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size that can hold all the
# data and escape bytes.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 19
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
set sizes
} {19 19 19 19 19}
test io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-2.2 {WriteBytes: savedLF > 0} {
# After flushing buffer, there was a \n left over from the last
# \n -> \r\n expansion. It gets stuck at beginning of this buffer.
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffersize 16 -translation crlf
puts -nonewline $f "123456789012345\n12"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
test io-2.3 {WriteBytes: flush on line} {
# Tcl "line" buffering has weird behavior: if current buffer contains
# a \n, entire buffer gets flushed. Logical behavior would be to flush
# only up to the \n.
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffering line -translation crlf
puts -nonewline $f "\n12"
set x [contents $path(test1)]
close $f
set x
} "\r\n12"
test io-2.4 {WriteBytes: reset sawLF after each buffer} {
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffering line -translation lf \
-buffersize 16
puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test io-3.1 {WriteChars: compatibility with WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} {
# After flushing buffer, there was a \n left over from the last
# \n -> \r\n expansion. It gets stuck at beginning of this buffer.
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffersize 16 -translation crlf
puts -nonewline $f "123456789012345\n12"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} {
# Tcl "line" buffering has weird behavior: if current buffer contains
# a \n, entire buffer gets flushed. Logical behavior would be to flush
# only up to the \n.
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffering line -translation crlf
puts -nonewline $f "\n12"
set x [contents $path(test1)]
close $f
set x
} "\r\n12"
test io-3.4 {WriteChars: loop over stage buffer} {
# stage buffer maps to more than can be queued at once.
set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 16
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.5 {WriteChars: saved != 0} {
# Bytes produced by UtfToExternal from end of last channel buffer
# had to be moved to beginning of next channel buffer to preserve
# requested buffersize.
set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 17
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} {
# One incomplete UTF-8 character at end of staging buffer. Backup
# in src to the beginning of that UTF-8 character and try again.
#
# Translate the first 16 bytes, produce 14 bytes of output, 2 left over
# (first two bytes of \uff21 in UTF-8). Given those two bytes try
# translating them again, find that no bytes are read produced, and break
# to outer loop where those two bytes will have the remaining 4 bytes
# (the last byte of \uff21 plus the all of \uff22) appended.
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis -buffersize 16
puts -nonewline $f "12345678901234\uff21\uff22"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"]
test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} {
# When translating UTF-8 to external, the produced bytes went past end
# of the channel buffer. This is done purpose -- we then truncate the
# bytes at the end of the partial character to preserve the requested
# blocksize on flush. The truncated bytes are moved to the beginning
# of the next channel buffer.
set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 17
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.8 {WriteChars: reset sawLF after each buffer} {
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffering line -translation lf \
-buffersize 16
puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test io-4.1 {TranslateOutputEOL: lf} {
# search for \n
set f [open $path(test1) w]
fconfigure $f -buffering line -translation lf
puts $f "abcde"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcde\n" "abcde\n"]
test io-4.2 {TranslateOutputEOL: cr} {
# search for \n, replace with \r
set f [open $path(test1) w]
fconfigure $f -buffering line -translation cr
puts $f "abcde"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcde\r" "abcde\r"]
test io-4.3 {TranslateOutputEOL: crlf} {
# simple case: search for \n, replace with \r
set f [open $path(test1) w]
fconfigure $f -buffering line -translation crlf
puts $f "abcde"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcde\r\n" "abcde\r\n"]
test io-4.4 {TranslateOutputEOL: crlf} {
# keep storing more bytes in output buffer until output buffer is full.
# We have 13 bytes initially that would turn into 18 bytes. Fill
# dest buffer while (dstEnd < dstMax).
set f [open $path(test1) w]
fconfigure $f -translation crlf -buffersize 16
puts -nonewline $f "1234567\n\n\n\n\nA"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567\r\n\r\n\r\n\r\n\r" "1234567\r\n\r\n\r\n\r\n\r\nA"]
test io-4.5 {TranslateOutputEOL: crlf} {
# Check for overflow of the destination buffer
set f [open $path(test1) w]
fconfigure $f -translation crlf -buffersize 12
puts -nonewline $f "12345678901\n456789012345678901234"
close $f
set x [contents $path(test1)]
} "12345678901\r\n456789012345678901234"
test io-5.1 {CheckFlush: not full} {
set f [open $path(test1) w]
fconfigure $f
puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test io-5.2 {CheckFlush: full} {
set f [open $path(test1) w]
fconfigure $f -buffersize 16
puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567890123456" "12345678901234567890"]
test io-5.3 {CheckFlush: not line} {
set f [open $path(test1) w]
fconfigure $f -buffering line
puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test io-5.4 {CheckFlush: line} {
set f [open $path(test1) w]
fconfigure $f -buffering line -translation lf -encoding ascii
puts -nonewline $f "1234567890\n1234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567890\n1234567890" "1234567890\n1234567890"]
test io-5.5 {CheckFlush: none} {
set f [open $path(test1) w]
fconfigure $f -buffering none
puts -nonewline $f "1234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567890" "1234567890"]
test io-6.1 {Tcl_GetsObj: working} {
set f [open $path(test1) w]
puts $f "foo\nboo"
close $f
set f [open $path(test1)]
set x [gets $f]
close $f
set x
} {foo}
test io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} {
# no test, need to cause an async error.
} {}
test io-6.3 {Tcl_GetsObj: how many have we used?} {
# if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved}
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f "abc\ndefg"
close $f
set f [open $path(test1)]
set x [list [tell $f] [gets $f line] [tell $f] [gets $f line] $line]
close $f
set x
} {0 3 5 4 defg}
test io-6.4 {Tcl_GetsObj: encoding == NULL} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts $f "\x81\u1234\0"
close $f
set f [open $path(test1)]
fconfigure $f -translation binary
set x [list [gets $f line] $line]
close $f
set x
} [list 3 "\x81\x34\x00"]
test io-6.5 {Tcl_GetsObj: encoding != NULL} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts $f "\x88\xea\x92\x9a"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
close $f
set x
} [list 2 "\u4e00\u4e01"]
set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
append a $a
append a $a
test io-6.6 {Tcl_GetsObj: loop test} {
# if (dst >= dstEnd)
set f [open $path(test1) w]
puts $f $a
puts $f hi
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line]
close $f
set x
} [list 256 $a]
test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} {
# if (FilterInputBytes(chanPtr, &gs) != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
puts -nonewline $f "hi\nwould"
flush $f
gets $f
fconfigure $f -blocking 0
set x [gets $f line]
close $f
set x
} {-1}
test io-6.8 {Tcl_GetsObj: remember if EOF is seen} {
set f [open $path(test1) w]
puts $f "abcdef\x1aghijk\nwombat"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar \x1a
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {6 abcdef -1 {}}
test io-6.9 {Tcl_GetsObj: remember if EOF is seen} {
set f [open $path(test1) w]
puts $f "abcdefghijk\nwom\u001abat"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar \x1a
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {11 abcdefghijk 3 wom}
# Comprehensive tests
test io-6.10 {Tcl_GetsObj: lf mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.11 {Tcl_GetsObj: lf mode: lone \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {0 {} -1 {}}
test io-6.12 {Tcl_GetsObj: lf mode: lone \r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\r" -1 ""]
test io-6.13 {Tcl_GetsObj: lf mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.15 {Tcl_GetsObj: lf mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""]
test io-6.16 {Tcl_GetsObj: cr mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.17 {Tcl_GetsObj: cr mode: lone \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\n" -1 ""]
test io-6.18 {Tcl_GetsObj: cr mode: lone \r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {0 {} -1 {}}
test io-6.19 {Tcl_GetsObj: cr mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.21 {Tcl_GetsObj: cr mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""]
test io-6.22 {Tcl_GetsObj: crlf mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.23 {Tcl_GetsObj: crlf mode: lone \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\n" -1 ""]
test io-6.24 {Tcl_GetsObj: crlf mode: lone \r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\r" -1 ""]
test io-6.25 {Tcl_GetsObj: crlf mode: \r\r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 2 "\r\r" -1 ""]
test io-6.26 {Tcl_GetsObj: crlf mode: \r\n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.27 {Tcl_GetsObj: crlf mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.29 {Tcl_GetsObj: crlf mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""]
test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} {
# if (eol >= dstEnd)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 15]
test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} {
# (FilterInputBytes() != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {crlf lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r"
fconfigure $f -buffersize 16
set x [gets $f]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [fblocked $f] [testchannel inputbuffered $f]
close $f
set x
} [list "bbbbbbbbbbbbbb" -1 "" 1 16]
test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} {
# not (FilterInputBytes() != 0)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r\n123"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [tell $f] [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 17 3]
test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} {
# eol still equals dstEnd
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} [list 16 "123456789012345\r" 1]
test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} {
# not (*eol == '\n')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\rabcd\r\nefg"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [tell $f]]
close $f
set x
} [list 20 "123456789012345\rabcd" 22]
test io-6.35 {Tcl_GetsObj: auto mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.36 {Tcl_GetsObj: auto mode: lone \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.37 {Tcl_GetsObj: auto mode: lone \r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.38 {Tcl_GetsObj: auto mode: \r\r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" 0 "" -1 ""]
test io-6.39 {Tcl_GetsObj: auto mode: \r\n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.40 {Tcl_GetsObj: auto mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.42 {Tcl_GetsObj: auto mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
close $f
set x
} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} {
# if (chanPtr->flags & INPUT_SAW_CR)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "\nabcd\refg\x1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
lappend x [gets $f line] $line
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} {
# not (*eol == '\n')
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "abcd\refg\x1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
lappend x [gets $f line] $line
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} {
# Tcl_ExternalToUtf()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
fconfigure $f -encoding unicode
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
gets $f
fconfigure $f -blocking 0
set x [list [gets $f line] $line [testchannel queuedcr $f]]
fconfigure $f -blocking 1
puts -nonewline $f "\nabcd\refg"
lappend x [gets $f line] $line [testchannel queuedcr $f]
close $f
set x
} [list 15 "123456789abcdef" 1 4 "abcd" 0]
test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} {
# memmove()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
gets $f
fconfigure $f -blocking 0
set x [list [gets $f line] $line [testchannel queuedcr $f]]
fconfigure $f -blocking 1
puts -nonewline $f "\n\x1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
close $f
set x
} [list 15 "123456789abcdef" 1 -1 "" 0]
test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} {
# (eol == dstEnd)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -buffersize 16
set x [list [gets $f] [testchannel inputbuffered $f]]
close $f
set x
} [list "123456789012345" 15]
test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} {
# PeekAhead() did not get any, so (eol >= dstEnd)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -buffersize 16
set x [list [gets $f] [testchannel queuedcr $f]]
close $f
set x
} [list "123456789012345" 1]
test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} {
# if (*eol == '\n') {skip++}
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\r\n78901"
close $f
set f [open $path(test1)]
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 0 8 "78901"]
test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} {
# not (*eol == '\n')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\r78901"
close $f
set f [open $path(test1)]
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 0 7 "78901"]
test io-6.51 {Tcl_GetsObj: auto mode: \n} {
# else if (*eol == '\n') {goto gotoeol;}
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\n78901"
close $f
set f [open $path(test1)]
set x [list [gets $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 7 "78901"]
test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
# if (eof != NULL)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\x1ak9012345\r"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar \x1a
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 0 6 ""]
test io-6.53 {Tcl_GetsObj: device EOF} {
# didn't produce any bytes
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} {-1 {} 1}
test io-6.54 {Tcl_GetsObj: device EOF} {
# got some bytes before EOF.
set f [open $path(test1) w]
puts -nonewline $f abc
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} {3 abc 1}
test io-6.55 {Tcl_GetsObj: overconverted} {
# Tcl_ExternalToUtf(), make sure state updated
set f [open $path(test1) w]
fconfigure $f -encoding iso2022-jp
puts $f "there\u4e00ok\n\u4e01more bytes\nhere"
close $f
set f [open $path(test1)]
fconfigure $f -encoding iso2022-jp
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} {
update
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -buffering none
puts -nonewline $f "foobar"
fconfigure $f -blocking 0
variable x {}
after 500 [namespace code { lappend x timeout }]
fileevent $f readable [namespace code { lappend x [gets $f] }]
vwait [namespace which -variable x]
vwait [namespace which -variable x]
fconfigure $f -blocking 1
puts -nonewline $f "baz\n"
after 500 [namespace code { lappend x timeout }]
fconfigure $f -blocking 0
vwait [namespace which -variable x]
vwait [namespace which -variable x]
close $f
set x
} {{} timeout foobarbaz timeout}
test io-7.1 {FilterInputBytes: split up character at end of buffer} {
# (result == TCL_CONVERT_MULTIBYTE)
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -buffersize 16
set x [gets $f]
close $f
set x
} "1234567890123\uff10\uff11\uff12\uff13\uff14"
test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} [list 10 "1234567890" 0]
test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
lappend x [gets $f line] $line
close $f
set x
} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} {
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -encoding binary -buffering none
puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
fconfigure $f -encoding shiftjis -blocking 0
fileevent $f read [namespace code "ready $f"]
variable x {}
proc ready {f} {
variable x
lappend x [gets $f line] $line [fblocked $f]
}
vwait [namespace which -variable x]
fconfigure $f -encoding binary -blocking 1
puts $f "\x51\x82\x52"
fconfigure $f -encoding shiftjis
vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0]
test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} {
# (bufPtr->nextPtr == NULL)
set f [open $path(test1) w]
fconfigure $f -encoding ascii -translation lf
puts -nonewline $f "123456789012345\r\n2345678"
close $f
set f [open $path(test1)]
fconfigure $f -encoding ascii -translation auto -buffersize 16
# here
gets $f
set x [testchannel inputbuffered $f]
close $f
set x
} "7"
test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} {
# not (bufPtr->nextPtr == NULL)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation lf -encoding ascii -buffering none
puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
variable x {}
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [gets $f line] $line [testchannel inputbuffered $f]
}
fconfigure $f -encoding unicode -buffersize 16 -blocking 0
vwait [namespace which -variable x]
fconfigure $f -translation auto -encoding ascii -blocking 1
# here
vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 42 15 "123456789012345" 25]
test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} {
# (bytesLeft == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
flush $f
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} [list 15 "abcdefghijklmno" 1]
set a "123456789012345678901234567890"
append a "123456789012345678901234567890"
append a "1234567890123456789012345678901"
test io-8.4 {PeekAhead: cached data available in this buffer} {
# not (bytesLeft == 0)
set f [open $path(test1) w+]
fconfigure $f -translation binary
puts $f "${a}\r\nabcdef"
close $f
set f [open $path(test1)]
fconfigure $f -encoding binary -translation auto
# "${a}\r" was converted in one operation (because ENCODING_LINESIZE
# is 30). To check if "\n" follows, calls PeekAhead and determines
# that cached data is available in buffer w/o having to call driver.
set x [gets $f]
close $f
set x
} $a
unset a
test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} {
# (bufPtr->nextAdded < bufPtr->length)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
flush $f
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} {15 abcdefghijklmno 1}
test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} {
# ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffersize 16
puts -nonewline $f "abcdefghijklmno\r"
flush $f
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} {15 abcdefghijklmno 1}
test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} {
# Make sure bytes are removed from buffer.
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffering none
puts -nonewline $f "abcdefghijklmno\r"
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
puts -nonewline $f "\x1a"
lappend x [gets $f line] $line
close $f
set x
} {15 abcdefghijklmno 1 -1 {}}
test io-9.1 {CommonGetsCleanup} {
} {}
test io-10.1 {Tcl_ReadChars: CheckChannelErrors} {
# no test, need to cause an async error.
} {}
test io-10.2 {Tcl_ReadChars: loop until enough copied} {
# one time
# for (copied = 0; (unsigned) toRead > 0; )
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1)]
set x [read $f 5]
close $f
set x
} {abcde}
test io-10.3 {Tcl_ReadChars: loop until enough copied} {
# multiple times
# for (copied = 0; (unsigned) toRead > 0; )
set f [open $path(test1) w]
puts $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f 19]
close $f
set x
} {abcdefghijklmnopqrs}
test io-10.4 {Tcl_ReadChars: no more in channel buffer} {
# (copiedNow < 0)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-10.5 {Tcl_ReadChars: stop on EOF} {
# (chanPtr->flags & CHANNEL_EOF)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-11.1 {ReadBytes: want to read a lot} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
fconfigure $f -encoding binary
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-11.2 {ReadBytes: want to read all} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
fconfigure $f -encoding binary
# here
set x [read $f]
close $f
set x
} {abcdefghijkl}
test io-11.3 {ReadBytes: allocate more space} {
# (toRead > length - offset - 1)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -buffersize 16 -encoding binary
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
test io-11.4 {ReadBytes: EOF char found} {
# (TranslateInputEOL() != 0)
set f [open $path(test1) w]
puts $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -eofchar m -encoding binary
# here
set x [list [read $f] [eof $f] [read $f] [eof $f]]
close $f
set x
} [list "abcdefghijkl" 1 "" 1]
test io-12.1 {ReadChars: want to read a lot} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-12.2 {ReadChars: want to read all} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f]
close $f
set x
} {abcdefghijkl}
test io-12.3 {ReadChars: allocate more space} {
# (toRead > length - offset - 1)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} {
# (srcRead == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -encoding binary -buffering none -buffersize 16
puts -nonewline $f "123456789012345\x96"
fconfigure $f -encoding shiftjis -blocking 0
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [read $f] [testchannel inputbuffered $f]
}
variable x {}
fconfigure $f -encoding shiftjis
vwait [namespace which -variable x]
fconfigure $f -encoding binary -blocking 1
puts -nonewline $f "\x7b"
after 500 ;# Give the cat process time to catch up
fconfigure $f -encoding shiftjis -blocking 0
vwait [namespace which -variable x]
close $f
set x
} [list "123456789012345" 1 "\u672c" 0]
test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe fileevent} {
set path(test1) [makeFile {
fconfigure stdout -encoding binary -buffering none
gets stdin; puts -nonewline "\xe7"
gets stdin; puts -nonewline "\x89"
gets stdin; puts -nonewline "\xa6"
} test1]
set f [open "|[list [interpreter] $path(test1)]" r+]
fileevent $f readable [namespace code {
lappend x [read $f]
if {[eof $f]} {
lappend x eof
}
}]
puts $f "go1"
flush $f
fconfigure $f -blocking 0 -encoding utf-8
variable x {}
vwait [namespace which -variable x]
after 500 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
puts $f "go2"
flush $f
vwait [namespace which -variable x]
after 500 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
puts $f "go3"
flush $f
vwait [namespace which -variable x]
vwait [namespace which -variable x]
lappend x [catch {close $f} msg] $msg
set x
} "{} timeout {} timeout \u7266 {} eof 0 {}"
test io-13.1 {TranslateInputEOL: cr mode} {} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\rdef\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "abcd\ndef\n"
test io-13.2 {TranslateInputEOL: crlf mode} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\n"
test io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\r"
test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\rfgh"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\rfgh"
test io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\nfgh"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\nfgh"
test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} {
# (chanPtr->flags & INPUT_SAW_CR)
# This test may fail on slower machines.
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -blocking 0 -buffering none -translation {auto lf}
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [read $f] [testchannel queuedcr $f]
}
variable x {}
variable y {}
puts -nonewline $f "abcdefghj\r"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
puts -nonewline $f "\n01234"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
close $f
set x
} [list "abcdefghj\n" 1 "01234" 0]
test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [read $f] [testchannel queuedcr $f]]
close $f
set x
} [list "abcd\n" 1]
test io-13.8 {TranslateInputEOL: auto mode: \r\n} {
# (*src == '\n')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcd\ndef"
test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\rdef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcd\ndef"
test io-13.10 {TranslateInputEOL: auto mode: \n} {
# not (*src == '\r')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\ndef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcd\ndef"
test io-13.11 {TranslateInputEOL: EOF char} {
# (*chanPtr->inEofChar != '\0')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\ndefgh"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -eofchar e
set x [read $f]
close $f
set x
} "abcd\nd"
test io-13.12 {TranslateInputEOL: find EOF char in src} {
# (*chanPtr->inEofChar != '\0')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -eofchar e
set x [read $f]
close $f
set x
} "\n\n\nab\n\nd"
# Test standard handle management. The functions tested are
# Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are
# also testing channel table management.
if {[info commands testchannel] != ""} {
set consoleFileNames [lsort [testchannel open]]
} else {
# just to avoid an error
set consoleFileNames [list]
}
test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} {
set l ""
lappend l [fconfigure stdin -buffering]
lappend l [fconfigure stdout -buffering]
lappend l [fconfigure stderr -buffering]
lappend l [lsort [testchannel open]]
set l
} [list line line none $consoleFileNames]
test io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} {
interp create x
set l ""
lappend l [x eval {fconfigure stdin -buffering}]
lappend l [x eval {fconfigure stdout -buffering}]
lappend l [x eval {fconfigure stderr -buffering}]
interp delete x
set l
} {line line none}
set path(test3) [makeFile {} test3]
test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} {
set f [open $path(test1) w]
puts -nonewline $f {
close stdin
close stdout
close stderr
set f [}
puts $f [list open $path(test1) r]]
puts $f "set f2 \[[list open $path(test2) w]]"
puts $f "set f3 \[[list open $path(test3) w]]"
puts $f { puts stdout [gets stdin]
puts stdout out
puts stderr err
close $f
close $f2
close $f3
}
close $f
set result [exec [interpreter] $path(test1)]
set f [open $path(test2) r]
set f2 [open $path(test3) r]
lappend result [read $f] [read $f2]
close $f
close $f2
set result
} {{
out
} {err
}}
# This test relies on the fact that the smallest available fd is used first.
test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unixOnly} {
set f [open $path(test1) w]
puts -nonewline $f { close stdin
close stdout
close stderr
set f [}
puts $f [list open $path(test1) r]]
puts $f "set f2 \[[list open $path(test2) w]]"
puts $f "set f3 \[[list open $path(test3) w]]"
puts $f { puts stdout [gets stdin]
puts stdout $f2
puts stderr $f3
close $f
close $f2
close $f3
}
close $f
set result [exec [interpreter] $path(test1)]
set f [open $path(test2) r]
set f2 [open $path(test3) r]
lappend result [read $f] [read $f2]
close $f
close $f2
set result
} {{ close stdin
file1
} {file2
}}
catch {interp delete z}
test io-14.5 {Tcl_GetChannel: stdio name translation} {
interp create z
eof stdin
catch {z eval flush stdin} msg1
catch {z eval close stdin} msg2
catch {z eval flush stdin} msg3
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{channel "stdin" wasn't opened for writing} {} {can not find channel named "stdin"}}
test io-14.6 {Tcl_GetChannel: stdio name translation} {
interp create z
eof stdout
catch {z eval flush stdout} msg1
catch {z eval close stdout} msg2
catch {z eval flush stdout} msg3
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{} {} {can not find channel named "stdout"}}
test io-14.7 {Tcl_GetChannel: stdio name translation} {
interp create z
eof stderr
catch {z eval flush stderr} msg1
catch {z eval close stderr} msg2
catch {z eval flush stderr} msg3
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
test io-14.8 {reuse of stdio special channels} {stdio openpipe} {
file delete $path(script)
file delete $path(test1)
set f [open $path(script) w]
puts -nonewline $f {
close stderr
set f [}
puts $f [list open $path(test1) w]]
puts -nonewline $f {
puts stderr hello
close $f
set f [}
puts $f [list open $path(test1) r]]
puts $f {
puts [gets $f]
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
set c [gets $f]
close $f
set c
} hello
test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} {
file delete $path(script)
file delete $path(test1)
set f [open $path(script) w]
puts $f {
array set path [lindex $argv 0]
set f [open $path(test1) w]
puts $f hello
close $f
close stderr
set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r]
puts [gets $f]
}
close $f
set f [open "|[list [interpreter] $path(script) [array get path]]" r]
set c [gets $f]
close $f
# Added delay to give Windows time to stop the spawned process and clean
# up its grip on the file test1. Added delete as proper test cleanup.
# The failing tests were 18.1 and 18.2 as first re-users of file "test1".
after 10000
file delete $path(script)
file delete $path(test1)
set c
} hello
test io-15.1 {Tcl_CreateCloseHandler} {
} {}
test io-16.1 {Tcl_DeleteCloseHandler} {
} {}
# Test channel table management. The functions tested are
# GetChannelTable, DeleteChannelTable, Tcl_RegisterChannel,
# Tcl_UnregisterChannel, Tcl_GetChannel and Tcl_CreateChannel.
#
# These functions use "eof stdin" to ensure that the standard
# channels are added to the channel table of the interpreter.
test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
set l1 [testchannel refcount stdin]
eof stdin
interp create x
set l ""
lappend l [expr [testchannel refcount stdin] - $l1]
x eval {eof stdin}
lappend l [expr [testchannel refcount stdin] - $l1]
interp delete x
lappend l [expr [testchannel refcount stdin] - $l1]
set l
} {0 1 0}
test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
set l1 [testchannel refcount stdout]
eof stdin
interp create x
set l ""
lappend l [expr [testchannel refcount stdout] - $l1]
x eval {eof stdout}
lappend l [expr [testchannel refcount stdout] - $l1]
interp delete x
lappend l [expr [testchannel refcount stdout] - $l1]
set l
} {0 1 0}
test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
set l1 [testchannel refcount stderr]
eof stdin
interp create x
set l ""
lappend l [expr [testchannel refcount stderr] - $l1]
x eval {eof stderr}
lappend l [expr [testchannel refcount stderr] - $l1]
interp delete x
lappend l [expr [testchannel refcount stderr] - $l1]
set l
} {0 1 0}
test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
file delete $path(test1)
set l ""
set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
lappend l $msg
} else {
lappend l "very broken: $f found after being closed"
}
string compare [string tolower $l] \
[list 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
file delete $path(test1)
set l ""
set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
interp create x
interp share "" $f x
lappend l [lindex [testchannel info $f] 15]
x eval close $f
lappend l [lindex [testchannel info $f] 15]
interp delete x
lappend l [lindex [testchannel info $f] 15]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
lappend l $msg
} else {
lappend l "very broken: $f found after being closed"
}
string compare [string tolower $l] \
[list 1 2 1 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
file delete $path(test1)
set l ""
set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
interp create x
interp share "" $f x
lappend l [lindex [testchannel info $f] 15]
interp delete x
lappend l [lindex [testchannel info $f] 15]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
lappend l $msg
} else {
lappend l "very broken: $f found after being closed"
}
string compare [string tolower $l] \
[list 1 2 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} {
eof stdin
} 0
test io-19.2 {testing Tcl_GetChannel, user opened handle} {
file delete $path(test1)
set f [open $path(test1) w]
set x [eof $f]
close $f
set x
} 0
test io-19.3 {Tcl_GetChannel, channel not found} {
list [catch {eof file34} msg] $msg
} {1 {can not find channel named "file34"}}
test io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
set l ""
lappend l [eof $f]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
lappend l $msg
} else {
lappend l "very broken: $f found after being closed"
}
string compare [string tolower $l] \
[list 0 [format "can not find channel named \"%s\"" $f]]
} 0
test io-20.1 {Tcl_CreateChannel: initial settings} {
set a [open $path(test2) w]
set old [encoding system]
encoding system ascii
set f [open $path(test1) w]
set x [fconfigure $f -encoding]
close $f
encoding system $old
close $a
set x
} {ascii}
test io-20.2 {Tcl_CreateChannel: initial settings} {pcOnly} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} [list [list \x1a ""] {auto crlf}]
test io-20.3 {Tcl_CreateChannel: initial settings} {unixOnly} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{{} {}} {auto lf}}
set path(stdout) [makeFile {} stdout]
test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} {
set f [open $path(script) w]
puts -nonewline $f {
close stdout
set f1 [}
puts $f [list open $path(stdout) w]]
puts $f {
fconfigure $f1 -buffersize 777
puts stderr [fconfigure stdout -buffersize]
}
close $f
set f [open "|[list [interpreter] $path(script)]"]
catch {close $f} msg
set msg
} {777}
test io-21.1 {CloseChannelsOnExit} {
} {}
# Test management of attributes associated with a channel, such as
# its default translation, its name and type, etc. The functions
# tested in this group are Tcl_GetChannelName,
# Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData
# not tested because files do not use the instance data.
test io-22.1 {Tcl_GetChannelMode} {
# Not used anywhere in Tcl.
} {}
test io-23.1 {Tcl_GetChannelName} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
set n [testchannel name $f]
close $f
string compare $n $f
} 0
test io-24.1 {Tcl_GetChannelType} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
set t [testchannel type $f]
close $f
string compare $t file
} 0
test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} {
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts $f "1234567890\n098765432"
close $f
set f [open $path(test1) r]
gets $f
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
close $f
set l
} {10 11}
test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [tell $f]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [tell $f]
close $f
file delete $path(test1)
set l
} {6 6 0 6}
test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} {
# "pid" command uses Tcl_GetChannelInstanceData
# Don't care what pid is (but must be a number), just want to exercise it.
set f [open "|[list [interpreter] << exit]"]
expr [pid $f]
close $f
} {}
# Test flushing. The functions tested here are FlushChannel.
test io-27.1 {FlushChannel, no output buffered} {
file delete $path(test1)
set f [open $path(test1) w]
flush $f
set s [file size $path(test1)]
close $f
set s
} 0
test io-27.2 {FlushChannel, some output buffered} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set l ""
puts $f hello
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
lappend l [file size $path(test1)]
set l
} {0 6 6}
test io-27.3 {FlushChannel, implicit flush on close} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set l ""
puts $f hello
lappend l [file size $path(test1)]
close $f
lappend l [file size $path(test1)]
set l
} {0 6}
test io-27.4 {FlushChannel, implicit flush when buffer fills} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
fconfigure $f -buffersize 60
set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
}
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
{unixOrPc} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffersize 60 -eofchar {}
set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
}
lappend l [file size $path(test1)]
close $f
lappend l [file size $path(test1)]
set l
} {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test io-27.6 {FlushChannel, async flushing, async close} \
{stdio asyncPipeClose openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f \[[list open $path(output) w]]"
puts $f {
fconfigure $f -translation lf -buffering none -eofchar {}
while {![eof stdin]} {
after 20
puts -nonewline $f [read stdin 1024]
}
close $f
}
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
close $f
set f [open "|[list [interpreter] $path(pipe)]" w]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 20
update
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
} ok
# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close.
test io-28.1 {CloseChannel called when all references are dropped} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
interp create x
interp share "" $f x
set l ""
lappend l [testchannel refcount $f]
x eval close $f
interp delete x
lappend l [testchannel refcount $f]
close $f
set l
} {2 1}
test io-28.2 {CloseChannel called when all references are dropped} {
file delete $path(test1)
set f [open $path(test1) w]
interp create x
interp share "" $f x
puts -nonewline $f abc
close $f
x eval puts $f def
x eval close $f
interp delete x
set f [open $path(test1) r]
set l [gets $f]
close $f
set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} \
{stdio asyncPipeClose nonPortable openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f {
# Need to not have eof char appended on close, because the other
# side of the pipe already closed, so that writing would cause an
# error "invalid file".
fconfigure stdout -eofchar {}
fconfigure stderr -eofchar {}
set f [open $path(output) w]
fconfigure $f -translation lf -buffering none
for {set x 0} {$x < 20} {incr x} {
after 20
puts -nonewline $f [read stdin 1024]
}
close $f
}
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
close $f
set f [open "|[list [interpreter] pipe]" r+]
fconfigure $f -blocking off -eofchar {}
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 20480) && ($counter < 1000)} {
incr counter
after 20
update
}
if {$counter == 1000} {
set result probably_broken
} else {
set result ok
}
} ok
test io-28.4 {Tcl_Close} {testchannel} {
file delete $path(test1)
set l ""
lappend l [lsort [testchannel open]]
set f [open $path(test1) w]
lappend l [lsort [testchannel open]]
close $f
lappend l [lsort [testchannel open]]
set x [list $consoleFileNames \
[lsort [eval list $consoleFileNames $f]] \
$consoleFileNames]
string compare $l $x
} 0
test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly testchannel openpipe} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
close stdin
puts [testchannel open]
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
set l [gets $f]
close $f
set l
} {file1 file2}
test io-29.1 {Tcl_WriteChars, channel not writable} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.2 {Tcl_WriteChars, empty string} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar {}
puts -nonewline $f ""
close $f
file size $path(test1)
} 0
test io-29.3 {Tcl_WriteChars, nonempty string} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar {}
puts -nonewline $f hello
close $f
file size $path(test1)
} 5
test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering full -eofchar {}
puts $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {6 0 0 6}
test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering line -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {5 0 0 11}
test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering none -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {0 5 0 11}
test io-29.7 {Tcl_Flush, full buffering} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering full -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {5 0 11 0 0 11}
test io-29.8 {Tcl_Flush, full buffering} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering line
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {5 0 0 5 0 11 0 11}
test io-29.9 {Tcl_Flush, channel not writable} {
list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.10 {Tcl_WriteChars, looping and buffering} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
puts $f1 [gets $f2]
}
close $f2
close $f1
file size $path(test1)
} 387
test io-29.11 {Tcl_WriteChars, no newline, implicit flush} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -eofchar {}
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
puts -nonewline $f1 [gets $f2]
}
close $f1
close $f2
file size $path(test1)
} 377
test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 "set f1 \[[list open $path(longfile) r]]"
puts $f1 {
for {set x 0} {$x < 10} {incr x} {
puts [gets $f1]
}
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r]
set f2 [open $path(longfile) r]
set y ok
for {set x 0} {$x < 10} {incr x} {
set l1 [gets $f1]
set l2 [gets $f2]
if {"$l1" != "$l2"} {
set y broken
}
}
close $f1
close $f2
set y
} ok
test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts [gets stdin]
puts [gets stdin]
}
close $f1
set y ok
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -buffering line
set f2 [open $path(longfile) r]
set line [gets $f2]
puts $f1 $line
set backline [gets $f1]
if {"$line" != "$backline"} {
set y broken
}
set line [gets $f2]
puts $f1 $line
set backline [gets $f1]
if {"$line" != "$backline"} {
set y broken
}
close $f1
close $f2
set y
} ok
test io-29.14 {Tcl_WriteChars, buffering and implicit flush at close} {
file delete $path(test3)
set f [open $path(test3) w]
puts -nonewline $f "Text1"
puts -nonewline $f " Text 2"
puts $f " Text 3"
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} {Text1 Text 2 Text 3}
test io-29.15 {Tcl_Flush, channel not open for writing} {
file delete $path(test1)
set fd [open $path(test1) w]
close $fd
set fd [open $path(test1) r]
set x [list [catch {flush $fd} msg] $msg]
close $fd
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} {
set fd [open "|[list [interpreter] cat longfile]" r]
set x [list [catch {flush $fd} msg] $msg]
catch {close $fd}
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
set x [file size $path(test1)]
close $f1
set x
} 18
test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} {
file delete $path(test1)
set x ""
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
close $f1
set x
} {18 24 30}
test io-29.19 {Explicit and implicit flushes} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
set x ""
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
close $f1
lappend x [file size $path(test1)]
set x
} {18 24 30}
test io-29.20 {Implicit flush when buffer is full} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
for {set x 0} {$x < 100} {incr x} {
puts $f1 $line
}
set z ""
lappend z [file size $path(test1)]
for {set x 0} {$x < 100} {incr x} {
puts $f1 $line
}
lappend z [file size $path(test1)]
close $f1
lappend z [file size $path(test1)]
set z
} {4096 12288 12600}
test io-29.21 {Tcl_Flush to pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {set x [read stdin 6]}
puts $f1 {set cnt [string length $x]}
puts $f1 {puts "read $cnt characters"}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
catch {close $f1}
set x
} "read 6 characters"
test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
fconfigure stdout -buffering full
puts hello
puts hello
flush stdout
gets stdin
puts bye
flush stdout
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set x ""
lappend x [gets $f1]
lappend x [gets $f1]
puts $f1 hello
flush $f1
lappend x [gets $f1]
close $f1
set x
} {hello hello bye}
test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts hello
puts hello
gets stdin
puts bye
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set x ""
lappend x [gets $f1]
lappend x [gets $f1]
puts $f1 hello
flush $f1
lappend x [gets $f1]
close $f1
set x
} {hello hello bye}
test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} {
set f [open $path(test3) w]
puts $f "Line 1"
puts $f "Line 2"
set f2 [open $path(test3)]
set x {}
lappend x [read -nonewline $f2]
close $f2
flush $f
set f2 [open $path(test3)]
lappend x [read -nonewline $f2]
close $f2
close $f
set x
} "{} {Line 1\nLine 2}"
test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} {
file delete $path(test3)
set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w]
puts $f "Line 1"
puts $f "Line 2"
close $f
after 100
set f [open $path(test3) r]
set x [read $f]
close $f
set x
} "Line 1\nLine 2\n"
test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} {
set f [open "|[list cat -u]" r+]
puts $f "Line1"
flush $f
set x [gets $f]
close $f
set x
} {Line1}
test io-29.27 {Tcl_Flush on closed pipeline} {stdio openpipe} {
file delete $path(pipe)
set f [open $path(pipe) w]
puts $f {exit}
close $f
set f [open "|[list [interpreter] $path(pipe)]" r+]
gets $f
puts $f output
after 50
#
# The flush below will get a SIGPIPE. This is an expected part of
# test and indicates that the test operates correctly. If you run
# this test under a debugger, the signal will by intercepted unless
# you disable the debugger's signal interception.
#
if {[catch {flush $f} msg]} {
set x [list 1 $msg $errorCode]
catch {close $f}
} else {
if {[catch {close $f} msg]} {
set x [list 1 $msg $errorCode]
} else {
set x {this was supposed to fail and did not}
}
}
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
test io-29.28 {Tcl_WriteChars, lf mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts $f hello\nthere\nand\nhere
flush $f
set s [file size $path(test1)]
close $f
set s
} 21
test io-29.29 {Tcl_WriteChars, cr mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
puts $f hello\nthere\nand\nhere
close $f
file size $path(test1)
} 21
test io-29.30 {Tcl_WriteChars, crlf mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
puts $f hello\nthere\nand\nhere
close $f
file size $path(test1)
} 25
test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f \[[list open $path(output) w]]"
puts $f {fconfigure $f -translation lf}
set x [list while {![eof stdin]}]
set x "$x {"
puts $f $x
puts $f { puts -nonewline $f [read stdin 4096]}
puts $f { flush $f}
puts $f "}"
puts $f {close $f}
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
close $f
set f [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 5
update
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
{stdio asyncPipeClose openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f \[[list open $path(output) w]]"
puts $f {fconfigure $f -translation lf}
set x [list while {![eof stdin]}]
set x "$x \{"
puts $f $x
puts $f { after 20}
puts $f { puts -nonewline $f [read stdin 1024]}
puts $f { flush $f}
puts $f "\}"
puts $f {close $f}
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
close $f
set f [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 20
update
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
} ok
test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
set f [open $path(script) w]
puts $f "set f \[[list open $path(test1) w]]"
puts $f {fconfigure $f -translation lf
puts $f hello
puts $f bye
puts $f strange
}
close $f
exec [interpreter] $path(script)
set f [open $path(test1) r]
set r [read $f]
close $f
set r
} "hello\nbye\nstrange\n"
test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} {
variable c 0
variable x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
proc writelots {s l} {
for {set i 0} {$i < 2000} {incr i} {
puts $s $l
}
}
proc accept {s a p} {
variable x
fileevent $s readable [namespace code [list readit $s]]
fconfigure $s -blocking off
set x accepted
}
proc readit {s} {
variable c
variable x
set l [gets $s]
if {[eof $s]} {
close $s
set x done
} elseif {([string length $l] > 0) || ![fblocked $s]} {
incr c
}
}
set ss [socket -server [namespace code accept] 0]
set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait [namespace which -variable x]
fconfigure $cs -blocking off
writelots $cs $l
close $cs
close $ss
vwait [namespace which -variable x]
set c
} 2000
test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} {
# On Mac, this test screws up sockets such that subsequent tests using port 2828
# either cause errors or panic().
catch {interp delete x}
catch {interp delete y}
interp create x
interp create y
set s [socket -server [namespace code accept] 0]
proc accept {s a p} {
puts $s hello
close $s
}
set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
interp share {} $c x
interp share {} $c y
close $c
x eval {
proc readit {s} {
gets $s
if {[eof $s]} {
close $s
}
}
}
y eval {
proc readit {s} {
gets $s
if {[eof $s]} {
close $s
}
}
}
x eval "fileevent $c readable \{readit $c\}"
y eval "fileevent $c readable \{readit $c\}"
y eval [list close $c]
update
close $s
interp delete x
interp delete y
} ""
# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.
test io-30.1 {Tcl_Write lf, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
test io-30.2 {Tcl_Write lf, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
test io-30.3 {Tcl_Write lf, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
test io-30.4 {Tcl_Write cr, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
test io-30.5 {Tcl_Write cr, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hello\rthere\rand\rhere\r"
test io-30.6 {Tcl_Write cr, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hello\rthere\rand\rhere\r"
test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
test io-30.8 {Tcl_Write crlf, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hello\r\nthere\r\nand\r\nhere\r\n"
test io-30.9 {Tcl_Write crlf, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hello\n\nthere\n\nand\n\nhere\n\n"
test io-30.10 {Tcl_Write lf, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
list $c $x
} {{hello
there
and
here
} auto}
test io-30.11 {Tcl_Write cr, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
list $c $x
} {{hello
there
and
here
} auto}
test io-30.12 {Tcl_Write crlf, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
list $c $x
} {{hello
there
and
here
} auto}
test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
puts $f $line
}
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set c [read $f]
close $f
string length $c
} [expr 700*15+1]
test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
puts $f $line
}
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set c [read $f]
close $f
string length $c
} [expr 700*15+1]
test io-30.15 {Tcl_Write mixed, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set c [read $f]
close $f
set c
} {hello
there
and
here
}
test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\nand\rhere\n\x1a
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set c [read $f]
close $f
set c
} {hello
there
and
here
}
test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar \x1a -translation lf
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set c [read $f]
close $f
set c
} {hello
there
and
here
}
test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1 {} 1}
test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1 {} 1}
test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar {}
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aghi 0 qrs 0 {} 1"
test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar {}
set l ""
set x [gets $f]
lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {0 1 {} 1}
test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar {}
set l ""
set x [gets $f]
lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {0 1 {} 1}
test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets.
test io-31.1 {Tcl_Write lf, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 6 auto there 12 auto}
test io-31.2 {Tcl_Write cr, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 6 auto there 12 auto}
test io-31.3 {Tcl_Write crlf, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 7 auto there 14 auto}
test io-31.4 {Tcl_Write lf, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 6 lf there 12 lf}
test io-31.5 {Tcl_Write lf, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 cr 1 {} 21 cr 1}
test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.7 {Tcl_Write cr, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {hello 6 cr 0 there 12 cr 0}
test io-31.8 {Tcl_Write cr, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 lf 1 {} 21 lf 1}
test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {hello 7 crlf 0 there 14 crlf 0}
test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {hello 6 cr 0 6 13 cr 0}
test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {6 7 lf 0 6 14 lf 0}
test io-31.13 {binary mode is synonym of lf mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation binary
set x [fconfigure $f -translation]
close $f
set x
} lf
#
# Test io-9.14 has been removed because "auto" output translation mode is
# not supoprted.
#
test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\rand\r\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\rand\r\nhere\r
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\rand\r\nhere\n
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\rand\r\nhere\r\n
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "hello\nthere\nand\rhere\n\%c" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar \x1a -translation lf
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar {}
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar {}
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar {}
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
puts $f $line
}
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set c ""
while {[gets $f line] >= 0} {
append c $line\n
}
close $f
string length $c
} [expr 700*15+1]
test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
puts $f $line
}
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set c ""
while {[gets $f line] >= 0} {
append c $line\n
}
close $f
string length $c
} [expr 700*15+1]
# Test Tcl_Read and buffering.
test io-32.1 {Tcl_Read, channel not readable} {
list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test io-32.2 {Tcl_Read, zero byte count} {
read stdin 0
} ""
test io-32.3 {Tcl_Read, negative byte count} {
set f [open $path(longfile) r]
set l [list [catch {read $f -1} msg] $msg]
close $f
set l
} {1 {bad argument "-1": should be "nonewline"}}
test io-32.4 {Tcl_Read, positive byte count} {
set f [open $path(longfile) r]
set x [read $f 1024]
set s [string length $x]
unset x
close $f
set s
} 1024
test io-32.5 {Tcl_Read, multiple buffers} {
set f [open $path(longfile) r]
fconfigure $f -buffersize 100
set x [read $f 1024]
set s [string length $x]
unset x
close $f
set s
} 1024
test io-32.6 {Tcl_Read, very large read} {
set f1 [open $path(longfile) r]
set z [read $f1 1000000]
close $f1
set l [string length $z]
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set f1 [open $path(longfile) r]
fconfigure $f1 -blocking off
set z [read $f1 20]
close $f1
set l [string length $z]
set x ok
if {$l != 20} {
set x broken
}
set x
} ok
test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set f1 [open $path(longfile) r]
fconfigure $f1 -blocking off
set z [read $f1 1000000]
close $f1
set x ok
set l [string length $z]
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.9 {Tcl_Read, read to end of file} {
set f1 [open $path(longfile) r]
set z [read $f1]
close $f1
set l [string length $z]
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.10 {Tcl_Read from a pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [read $f1]
close $f1
set x
} "hello\n"
test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x ""
lappend x [read $f1 6]
puts $f1 hello
flush $f1
lappend x [read $f1]
close $f1
set x
} {{hello
} {hello
}}
test io-32.12 {Tcl_Read, -nonewline} {
file delete $path(test1)
set f1 [open $path(test1) w]
puts $f1 hello
puts $f1 bye
close $f1
set f1 [open $path(test1) r]
set c [read -nonewline $f1]
close $f1
set c
} {hello
bye}
test io-32.13 {Tcl_Read, -nonewline} {
file delete $path(test1)
set f1 [open $path(test1) w]
puts $f1 hello
puts $f1 bye
close $f1
set f1 [open $path(test1) r]
set c [read -nonewline $f1]
close $f1
list [string length $c] $c
} {9 {hello
bye}}
test io-32.14 {Tcl_Read, reading in small chunks} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [list [read $f 1] [read $f 2] [read $f]]
close $f
set x
} {T wo { lines: this one
and this one
}}
test io-32.15 {Tcl_Read, asking for more input than available} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [read $f 100]
close $f
set x
} {Two lines: this one
and this one
}
test io-32.16 {Tcl_Read, read to end of file with -nonewline} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [read -nonewline $f]
close $f
set x
} {Two lines: this one
and this one}
# Test Tcl_Gets.
test io-33.1 {Tcl_Gets, reading what was written} {
file delete $path(test1)
set f1 [open $path(test1) w]
set y "first line"
puts $f1 $y
close $f1
set f1 [open $path(test1) r]
set x [gets $f1]
set z ok
if {"$x" != "$y"} {
set z broken
}
close $f1
set z
} ok
test io-33.2 {Tcl_Gets into variable} {
set f1 [open $path(longfile) r]
set c [gets $f1 x]
set l [string length x]
set z ok
if {$l != $l} {
set z broken
}
close $f1
set z
} ok
test io-33.3 {Tcl_Gets from pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
close $f1
set z ok
if {"$x" != "hello"} {
set z broken
}
set z
} ok
test io-33.4 {Tcl_Gets with long line} {
file delete $path(test3)
set f [open $path(test3) w]
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
close $f
set f [open $path(test3)]
set x [gets $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test io-33.5 {Tcl_Gets with long line} {
set f [open $path(test3)]
set x [gets $f y]
close $f
list $x $y
} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test io-33.6 {Tcl_Gets and end of file} {
file delete $path(test3)
set f [open $path(test3) w]
puts -nonewline $f "Test1\nTest2"
close $f
set f [open $path(test3)]
set x {}
set y {}
lappend x [gets $f y] $y
set y {}
lappend x [gets $f y] $y
set y {}
lappend x [gets $f y] $y
close $f
set x
} {5 Test1 5 Test2 -1 {}}
test io-33.7 {Tcl_Gets and bad variable} {
set f [open $path(test3) w]
puts $f "Line 1"
puts $f "Line 2"
close $f
catch {unset x}
set x 24
set f [open $path(test3) r]
set result [list [catch {gets $f x(0)} msg] $msg]
close $f
set result
} {1 {can't set "x(0)": variable isn't array}}
test io-33.8 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 100} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 100} {incr y} {gets $f}
close $f
set y
} 100
test io-33.9 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 200} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 200} {incr y} {gets $f}
close $f
set y
} 200
test io-33.10 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 300} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 300} {incr y} {gets $f}
close $f
set y
} 300
# Test Tcl_Seek and Tcl_Tell.
test io-34.1 {Tcl_Seek to current position at start of file} {
set f1 [open $path(longfile) r]
seek $f1 0 current
set c [tell $f1]
close $f1
set c
} 0
test io-34.2 {Tcl_Seek to offset from start} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 start
set c [tell $f1]
close $f1
set c
} 10
test io-34.3 {Tcl_Seek to end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 0 end
set c [tell $f1]
close $f1
set c
} 54
test io-34.4 {Tcl_Seek to offset from end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c [tell $f1]
close $f1
set c
} 44
test io-34.5 {Tcl_Seek to offset from current position} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 current
seek $f1 10 current
set c [tell $f1]
close $f1
set c
} 20
test io-34.6 {Tcl_Seek to offset from end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c [tell $f1]
set r [read $f1]
close $f1
list $c $r
} {44 {rstuvwxyz
}}
test io-34.7 {Tcl_Seek to offset from end of file, then to current position} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c1 [tell $f1]
set r1 [read $f1 5]
seek $f1 0 current
set c2 [tell $f1]
close $f1
list $c1 $r1 $c2
} {44 rstuv 49}
test io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} {
set f1 [open "|[list [interpreter]]" r+]
set x [list [catch {seek $f1 0 current} msg] $msg]
close $f1
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error during seek on "": invalid argument}}
test io-34.9 {Tcl_Seek, testing buffered input flushing} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -eofchar {}
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
close $f
set f [open $path(test3) RDWR]
set x [read $f 1]
seek $f 3
lappend x [read $f 1]
seek $f 0 start
lappend x [read $f 1]
seek $f 10 current
lappend x [read $f 1]
seek $f -2 end
lappend x [read $f 1]
seek $f 50 end
lappend x [read $f 1]
seek $f 1
lappend x [read $f 1]
close $f
set x
} {a d a l Y {} b}
set path(test3) [makeFile {} test3]
test io-34.10 {Tcl_Seek testing flushing of buffered input} {
set f [open $path(test3) w]
fconfigure $f -translation lf
puts $f xyz\n123
close $f
set f [open $path(test3) r+]
fconfigure $f -translation lf
set x [gets $f]
seek $f 0 current
puts $f 456
close $f
list $x [viewFile test3]
} "xyz {xyz
456}"
test io-34.11 {Tcl_Seek testing flushing of buffered output} {
set f [open $path(test3) w]
puts $f xyz\n123
close $f
set f [open $path(test3) w+]
puts $f xyzzy
seek $f 2
set x [gets $f]
close $f
list $x [viewFile test3]
} "zzy xyzzy"
test io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
puts $f xyz\n123
close $f
set f [open $path(test3) a+]
fconfigure $f -translation lf -eofchar {}
puts $f xyzzy
flush $f
set x [tell $f]
seek $f -4 cur
set y [gets $f]
close $f
list $x [viewFile test3] $y
} {14 {xyz
123
xyzzy} zzy}
test io-34.13 {Tcl_Tell at start of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
set p [tell $f1]
close $f1
set p
} 0
test io-34.14 {Tcl_Tell after seek to end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 0 end
set c1 [tell $f1]
close $f1
set c1
} 54
test io-34.15 {Tcl_Tell combined with seeking} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 start
set c1 [tell $f1]
seek $f1 10 current
set c2 [tell $f1]
close $f1
list $c1 $c2
} {10 20}
test io-34.16 {Tcl_tell on pipe: always -1} {stdio openpipe} {
set f1 [open "|[list [interpreter]]" r+]
set c [tell $f1]
close $f1
set c
} -1
test io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} {
set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello}
flush $f1
set c [tell $f1]
gets $f1
close $f1
set c
} -1
test io-34.18 {Tcl_Tell combined with seeking and reading} {
file delete $path(test2)
set f [open $path(test2) w]
fconfigure $f -translation lf -eofchar {}
puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n"
close $f
set f [open $path(test2)]
fconfigure $f -translation lf
set x [tell $f]
read $f 3
lappend x [tell $f]
seek $f 2
lappend x [tell $f]
seek $f 10 current
lappend x [tell $f]
seek $f 0 end
lappend x [tell $f]
close $f
set x
} {0 3 2 12 30}
test io-34.19 {Tcl_Tell combined with opening in append mode} {
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
puts $f "abcdefghijklmnopqrstuvwxyz"
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
set f [open $path(test3) a]
set c [tell $f]
close $f
set c
} 54
test io-34.20 {Tcl_Tell combined with writing} {
set f [open $path(test3) w]
set l ""
seek $f 29 start
lappend l [tell $f]
puts -nonewline $f a
seek $f 39 start
lappend l [tell $f]
puts -nonewline $f a
lappend l [tell $f]
seek $f 407 end
lappend l [tell $f]
close $f
set l
} {29 39 40 447}
test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -encoding binary
set l ""
lappend l [tell $f]
puts -nonewline $f abcdef
lappend l [tell $f]
flush $f
lappend l [tell $f]
# 4GB offset!
seek $f 0x100000000
lappend l [tell $f]
puts -nonewline $f abcdef
lappend l [tell $f]
close $f
lappend l [file size $f]
# truncate...
close [open $path(test3) w]
lappend l [file size $f]
set l
} {0 6 6 4294967296 4294967302 4294967302 0}
# Test Tcl_Eof
test io-35.1 {Tcl_Eof} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f hello
puts $f hello
close $f
set f [open $path(test1)]
set x [eof $f]
lappend x [eof $f]
gets $f
lappend x [eof $f]
gets $f
lappend x [eof $f]
gets $f
lappend x [eof $f]
lappend x [eof $f]
close $f
set x
} {0 0 0 0 1 1}
test io-35.2 {Tcl_Eof with pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
close $f1
set x
} {0 0 0 1}
test io-35.3 {Tcl_Eof with pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
close $f1
set x
} {0 0 0 1 1 1}
test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {{} 1}
test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} {
file delete $path(pipe)
set f [open $path(pipe) w]
puts $f {
exit
}
close $f
set f [open "|[list [interpreter] $path(pipe)]" r]
set l ""
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {{} 1}
test io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {9 8 1}
test io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {9 8 1}
test io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {9 8 1}
test io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {9 8 1}
test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {11 8 1}
test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {11 8 1}
test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {21 8 1}
test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {21 8 1}
# Test Tcl_InputBlocked
test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} {
set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello_from_pipe}
flush $f1
gets $f1
fconfigure $f1 -blocking off -buffering full
puts $f1 {puts hello}
set x ""
lappend x [gets $f1]
lappend x [fblocked $f1]
flush $f1
after 200
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [gets $f1]
lappend x [fblocked $f1]
close $f1
set x
} {{} 1 hello 0 {} 1}
test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} {
set f1 [open "|[list [interpreter]]" r+]
fconfigure $f1 -buffering line
puts $f1 {puts hello_from_pipe}
set x ""
lappend x [gets $f1]
lappend x [fblocked $f1]
puts $f1 {exit}
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [eof $f1]
close $f1
set x
} {hello_from_pipe 0 {} 0 1}
test io-36.3 {Tcl_InputBlocked vs files, short read} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
set l ""
lappend l [fblocked $f]
lappend l [read $f 3]
lappend l [fblocked $f]
lappend l [read -nonewline $f]
lappend l [fblocked $f]
lappend l [eof $f]
close $f
set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} {
proc in {f} {
variable l
variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
set l ""
fileevent $f readable [namespace code [list in $f]]
variable x
vwait [namespace which -variable x]
set l
} {abc def ghi jkl mno {p
} eof}
test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
lappend l [fblocked $f]
lappend l [read $f 3]
lappend l [fblocked $f]
lappend l [read -nonewline $f]
lappend l [fblocked $f]
lappend l [eof $f]
close $f
set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} {
proc in {f} {
variable l
variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
fileevent $f readable [namespace code [list in $f]]
variable x
vwait [namespace which -variable x]
set l
} {abc def ghi jkl mno {p
} eof}
# Test Tcl_InputBuffered
test io-37.1 {Tcl_InputBuffered} {testchannel} {
set f [open $path(longfile) r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
close $f
set l
} {4093 3}
test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} {
set f [open $path(longfile) r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
seek $f 0 current
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
close $f
set l
} {4093 3 0 3}
# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize
test io-38.1 {Tcl_GetChannelBufferSize, default buffer size} {
set f [open $path(longfile) r]
set s [fconfigure $f -buffersize]
close $f
set s
} 4096
test io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} {
set f [open $path(longfile) r]
set l ""
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 10000
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 1
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize -1
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 0
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 100000
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 10000000
lappend l [fconfigure $f -buffersize]
close $f
set l
} {4096 10000 1 1 1 100000 1048576}
test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} {
# This test crashes the interp if Bug #427196 is not fixed
set chan [open [info script] r]
fconfigure $chan -buffersize 10
set var [read $chan 2]
fconfigure $chan -buffersize 32
append var [read $chan]
close $chan
} {}
# Test Tcl_SetChannelOption, Tcl_GetChannelOption
test io-39.1 {Tcl_GetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
set x [fconfigure $f1 -blocking]
close $f1
set x
} 1
#
# Test 17.2 was removed.
#
test io-39.2 {Tcl_GetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
set x [fconfigure $f1 -buffering]
close $f1
set x
} full
test io-39.3 {Tcl_GetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -buffering line
set x [fconfigure $f1 -buffering]
close $f1
set x
} line
test io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
set l ""
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering line
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering none
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering line
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering full
lappend l [fconfigure $f1 -buffering]
close $f1
set l
} {full line none line full}
test io-39.5 {Tcl_GetChannelOption, invariance} {
file delete $path(test1)
set f1 [open $path(test1) w]
set l ""
lappend l [fconfigure $f1 -buffering]
lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg]
lappend l [fconfigure $f1 -buffering]
close $f1
set l
} {full {1 {bad value for -buffering: must be one of full, line, or none}} full}
test io-39.6 {Tcl_SetChannelOption, multiple options} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line
puts $f1 hello
puts $f1 bye
set x [file size $path(test1)]
close $f1
set x
} 10
test io-39.7 {Tcl_SetChannelOption, buffering, translation} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 bye
set x ""
fconfigure $f1 -buffering line
lappend x [file size $path(test1)]
puts $f1 really_bye
lappend x [file size $path(test1)]
close $f1
set x
} {0 21}
test io-39.8 {Tcl_SetChannelOption, different buffering options} {
file delete $path(test1)
set f1 [open $path(test1) w]
set l ""
fconfigure $f1 -translation lf -buffering none -eofchar {}
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
fconfigure $f1 -buffering full
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
fconfigure $f1 -buffering none
lappend l [file size $path(test1)]
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
close $f1
lappend l [file size $path(test1)]
set l
} {5 10 10 10 20 20}
test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} {
file delete $path(test1)
set f1 [open $path(test1) w]
close $f1
set f1 [open $path(test1) r]
set x ""
lappend x [fconfigure $f1 -blocking]
fconfigure $f1 -blocking off
lappend x [fconfigure $f1 -blocking]
lappend x [gets $f1]
lappend x [read $f1 1000]
lappend x [fblocked $f1]
lappend x [eof $f1]
close $f1
set x
} {1 0 {} {} 0 1}
test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
gets stdin
after 100
puts hi
gets stdin
}
close $f1
set x ""
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -blocking off -buffering line
lappend x [fconfigure $f1 -blocking]
lappend x [gets $f1]
lappend x [fblocked $f1]
fconfigure $f1 -blocking on
puts $f1 hello
fconfigure $f1 -blocking off
lappend x [gets $f1]
lappend x [fblocked $f1]
fconfigure $f1 -blocking on
puts $f1 bye
fconfigure $f1 -blocking off
lappend x [gets $f1]
lappend x [fblocked $f1]
fconfigure $f1 -blocking on
lappend x [fconfigure $f1 -blocking]
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [eof $f1]
lappend x [gets $f1]
lappend x [eof $f1]
close $f1
set x
} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1}
test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size clipped to lower bound} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -buffersize -10
set x [fconfigure $f -buffersize]
close $f
set x
} 1
test io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size clipped to upper bound} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -buffersize 10000000
set x [fconfigure $f -buffersize]
close $f
set x
} 1048576
test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -buffersize 40000
set x [fconfigure $f -buffersize]
close $f
set x
} 40000
test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -encoding {}
puts -nonewline $f \xe7\x89\xa6
close $f
set f [open $path(test1) r]
fconfigure $f -encoding utf-8
set x [read $f]
close $f
set x
} \u7266
test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f \xe7\x89\xa6
close $f
set f [open $path(test1) r]
fconfigure $f -encoding utf-8
set x [read $f]
close $f
set x
} \u7266
test io-39.16 {Tcl_SetChannelOption: -encoding, errors} {
file delete $path(test1)
set f [open $path(test1) w]
set result [list [catch {fconfigure $f -encoding foobar} msg] $msg]
close $f
set result
} {1 {unknown encoding "foobar"}}
test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} {
set f [open "|[list [interpreter] $path(cat)]" r+]
fconfigure $f -encoding binary
puts -nonewline $f "\xe7"
flush $f
fconfigure $f -encoding utf-8 -blocking 0
variable x {}
fileevent $f readable [namespace code { lappend x [read $f] }]
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
fconfigure $f -encoding utf-8
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
fconfigure $f -encoding binary
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
close $f
set x
} "{} timeout {} timeout \xe7 timeout"
test io-39.18 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
set s1 [socket -server [namespace code accept] 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
fconfigure $s2 -translation {auto lf}
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto lf}
test io-39.19 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
set s1 [socket -server [namespace code accept] 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
fconfigure $s2 -translation {auto crlf}
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto crlf}
test io-39.20 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
set s1 [socket -server [namespace code accept] 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
fconfigure $s2 -translation {auto cr}
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto cr}
test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
set s1 [socket -server [namespace code accept] 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
fconfigure $s2 -translation {auto auto}
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto crlf}
test io-39.22 {Tcl_SetChannelOption, invariance} {unixOnly} {
file delete $path(test1)
set f1 [open $path(test1) w+]
set l ""
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar {ON GO}
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar D
lappend l [fconfigure $f1 -eofchar]
close $f1
set l
} {{{} {}} {O G} {D D}}
test io-39.22a {Tcl_SetChannelOption, invariance} {
file delete $path(test1)
set f1 [open $path(test1) w+]
set l [list]
fconfigure $f1 -eofchar {ON GO}
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar D
lappend l [fconfigure $f1 -eofchar]
lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg]
close $f1
set l
} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}}
test io-39.23 {Tcl_GetChannelOption, server socket is not readable or
writeable, it should still have valid -eofchar and -translation options } {
set l [list]
set sock [socket -server [namespace code accept] 0]
lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
close $sock
set l
} {{{}} auto}
test io-39.24 {Tcl_SetChannelOption, server socket is not readable or
writable so we can't change -eofchar or -translation } {
set l [list]
set sock [socket -server [namespace code accept] 0]
fconfigure $sock -eofchar D -translation lf
lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
close $sock
set l
} {{{}} auto}
test io-40.1 {POSIX open access modes: RDWR} {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
set f [open $path(test3) RDWR]
puts -nonewline $f "ab"
seek $f 0 current
set x [gets $f]
close $f
set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
} {zzy abzzy}
test io-40.2 {POSIX open access modes: CREAT} {unixOnly} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT} 0600]
file stat $path(test3) stats
set x [format "0%o" [expr $stats(mode)&0777]]
puts $f "line 1"
close $f
set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
} {0600 {line 1}}
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
catch {testConstraint umask2 [expr {[exec umask] == 2}]}
test io-40.3 {POSIX open access modes: CREAT} {unixOnly umask2} {
# This test only works if your umask is 2, like ouster's.
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT}]
close $f
file stat test3 stats
format "0%o" [expr $stats(mode)&0777]
} 0664
test io-40.4 {POSIX open access modes: CREAT} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -eofchar {}
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY CREAT}]
fconfigure $f -eofchar {}
puts -nonewline $f "ab"
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} abzzy
test io-40.5 {POSIX open access modes: APPEND} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY APPEND}]
fconfigure $f -translation lf
puts $f "new line"
seek $f 0
puts $f "abc"
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
set x ""
seek $f 6 current
lappend x [gets $f]
lappend x [gets $f]
close $f
set x
} {{new line} abc}
test io-40.6 {POSIX open access modes: EXCL} -match regexp -body {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
open $path(test3) {WRONLY CREAT EXCL}
} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists}
test io-40.7 {POSIX open access modes: EXCL} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT EXCL}]
fconfigure $f -eofchar {}
puts $f "A test line"
close $f
viewFile test3
} {A test line}
test io-40.8 {POSIX open access modes: TRUNC} {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY TRUNC}]
puts $f abc
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} abc
test io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} {
file delete $path(test3)
set f [open $path(test3) {WRONLY NONBLOCK CREAT}]
puts $f "NONBLOCK test"
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} {NONBLOCK test}
test io-40.10 {POSIX open access modes: RDONLY} {
set f [open $path(test1) w]
puts $f "two lines: this one"
puts $f "and this"
close $f
set f [open $path(test1) RDONLY]
set x [list [gets $f] [catch {puts $f Test} msg] $msg]
close $f
string compare [string tolower $x] \
[list {two lines: this one} 1 \
[format "channel \"%s\" wasn't opened for writing" $f]]
} 0
test io-40.11 {POSIX open access modes: RDONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) RDONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test io-40.12 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test io-40.13 {POSIX open access modes: WRONLY} {
makeFile xyzzy test3
set f [open $path(test3) WRONLY]
fconfigure $f -eofchar {}
puts -nonewline $f "ab"
seek $f 0 current
set x [list [catch {gets $f} msg] $msg]
close $f
lappend x [viewFile test3]
string compare [string tolower $x] \
[list 1 "channel \"$f\" wasn't opened for reading" abzzy]
} 0
test io-40.14 {POSIX open access modes: RDWR} -match regexp -body {
file delete $path(test3)
open $path(test3) RDWR
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test io-40.15 {POSIX open access modes: RDWR} {
makeFile xyzzy test3
set f [open $path(test3) RDWR]
puts -nonewline $f "ab"
seek $f 0 current
set x [gets $f]
close $f
lappend x [viewFile test3]
} {zzy abzzy}
if {![file exists ~/_test_] && [file writable ~]} {
test io-40.16 {tilde substitution in open} -setup {
makeFile {Some text} _test_ ~
} -body {
file exists [file join $env(HOME) _test_]
} -cleanup {
removeFile _test_ ~
} -result 1
}
test io-40.17 {tilde substitution in open} {
set home $env(HOME)
unset env(HOME)
set x [list [catch {open ~/foo} msg] $msg]
set env(HOME) $home
set x
} {1 {couldn't find HOME environment variable to expand path}}
test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent foo} msg] $msg
} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent foo bar baz q} msg] $msg
} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
test io-41.3 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent gorp readable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.4 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent gorp writable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.5 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent gorp who-knows} msg] $msg
} {1 {bad event name "who-knows": must be readable or writable}}
#
# Test fileevent on a file
#
set path(foo) [makeFile {} foo]
set f [open $path(foo) w+]
test io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {fileevent} {
list [fileevent $f readable] [fileevent $f writable]
} {{} {}}
test io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} {
set result {}
fileevent $f r "first script"
lappend result [fileevent $f readable]
fileevent $f r "new script"
lappend result [fileevent $f readable]
fileevent $f r "yet another"
lappend result [fileevent $f readable]
fileevent $f r ""
lappend result [fileevent $f readable]
} {{first script} {new script} {yet another} {}}
test io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} {
set result {}
fileevent $f r "first scr\0ipt"
lappend result [string length [fileevent $f readable]]
fileevent $f r "new scr\0ipt"
lappend result [string length [fileevent $f readable]]
fileevent $f r "yet ano\0ther"
lappend result [string length [fileevent $f readable]]
fileevent $f r ""
lappend result [fileevent $f readable]
} {13 11 12 {}}
test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs fileevent} {
set result {}
fileevent $f readable "script 1"
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f writable "write script"
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f readable {}
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f writable {}
lappend result [fileevent $f readable] [fileevent $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent openpipe} -body {
set result {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f r "read f"
fileevent $f2 r "read f2"
fileevent $f3 r "read f3"
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f2 r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f3 r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}}
test io-44.1 {FileEventProc procedure: normal read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent openpipe} -body {
fileevent $f2 readable [namespace code {
set x [gets $f2]; fileevent $f2 readable {}
}]
puts $f2 text; flush $f2
variable x initial
vwait [namespace which -variable x]
set x
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {text}
test io-44.2 {FileEventProc procedure: error in read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent openpipe} -body {
proc ::bgerror args "set [namespace which -variable x] \$args"
fileevent $f2 readable {error bogus}
puts $f2 text; flush $f2
variable x initial
vwait [namespace which -variable x]
rename ::bgerror {}
list $x [fileevent $f2 readable]
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent openpipe} -body {
fileevent $f2 writable [namespace code {
lappend x "triggered"
incr count -1
if {$count <= 0} {
fileevent $f2 writable {}
}
}]
variable x initial
set count 3
vwait [namespace which -variable x]
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set x
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {initial triggered triggered triggered}
test io-44.4 {FileEventProc procedure: eror in write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent openpipe} -body {
proc ::bgerror args "set [namespace which -variable x] \$args"
fileevent $f2 writable {error bad-write}
variable x initial
vwait [namespace which -variable x]
rename ::bgerror {}
list $x [fileevent $f2 writable]
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} {
set f4 [open "|[list [interpreter] $path(cat) << foo]" r]
fileevent $f4 readable [namespace code {
if {[gets $f4 line] < 0} {
lappend x eof
fileevent $f4 readable {}
} else {
lappend x $line
}
}]
variable x initial
vwait [namespace which -variable x]
vwait [namespace which -variable x]
close $f4
set x
} {initial foo eof}
close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "binding triggered: \"[gets $f]\""
fileevent $f readable {}
}]
close $f
set x initial
after 100 [namespace code { set y done }]
variable y
vwait [namespace which -variable y]
set x
} {initial}
test io-45.2 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "f triggered: \"[gets $f]\""
fileevent $f readable {}
}]
fileevent $f2 readable [namespace code {
lappend x "f2 triggered: \"[gets $f2]\""
fileevent $f2 readable {}
}]
close $f
variable x initial
vwait [namespace which -variable x]
close $f2
set x
} {initial {f2 triggered: "foo bar"}}
test io-45.3 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
fileevent $f readable {f script}
fileevent $f2 readable {f2 script}
fileevent $f3 readable {f3 script}
set x {}
close $f2
lappend x [catch {fileevent $f readable} msg] $msg \
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable} msg] $msg
close $f3
lappend x [catch {fileevent $f readable} msg] $msg \
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable}]
close $f
lappend x [catch {fileevent $f readable}] \
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
testConstraint testfevent [llength [info commands testfevent]]
test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} {
testfevent create
set script "set f \[[list open $path(foo) r]]\n"
append script {
set x "no event"
fileevent $f readable [namespace code {
set x "f triggered: [gets $f]"
fileevent $f readable {}
}]
}
testfevent cmd $script
after 1 ;# We must delay because Windows takes a little time to notice
update
testfevent cmd {close $f}
list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
variable x 0
after 100 {set x triggered}
vwait [namespace which -variable x]
set x
}
} {triggered}
test io-46.3 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
set x 0
after 10 {lappend x timer}
after 30
set result $x
update idletasks
lappend result $x
update
lappend result $x
}
} {0 0 {0 timer}}
test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
fileevent $f readable {script 1}
testfevent create
testfevent share $f2
testfevent cmd "fileevent $f2 readable {script 2}"
fileevent $f3 readable {sript 3}
set x {}
lappend x [fileevent $f2 readable]
testfevent delete
lappend x [fileevent $f readable] [fileevent $f2 readable] \
[fileevent $f3 readable]
close $f
close $f2
close $f3
set x
} {{} {script 1} {} {sript 3}}
test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
set f4 [open $path(foo) r]
fileevent $f readable {script 1}
testfevent create
testfevent share $f2
testfevent share $f3
testfevent cmd "fileevent $f2 readable {script 2}
fileevent $f3 readable {script 3}"
fileevent $f4 readable {script 4}
testfevent delete
set x [list [fileevent $f readable] [fileevent $f2 readable] \
[fileevent $f3 readable] [fileevent $f4 readable]]
close $f
close $f2
close $f3
close $f4
set x
} {{script 1} {} {} {script 4}}
test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
set f4 [open $path(foo) r]
testfevent create
testfevent share $f3
testfevent share $f4
fileevent $f readable {script 1}
fileevent $f2 readable {script 2}
testfevent cmd "fileevent $f3 readable {script 3}
fileevent $f4 readable {script 4}"
testfevent delete
set x [list [fileevent $f readable] [fileevent $f2 readable] \
[fileevent $f3 readable] [fileevent $f4 readable]]
close $f
close $f2
close $f3
close $f4
set x
} {{script 1} {script 2} {} {}}
test io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
fileevent $f readable {script 2}
fileevent $f2 readable {script 3}
set x [list [fileevent $f2 readable] \
[testfevent cmd "fileevent $f readable"] \
[fileevent $f readable]]
testfevent delete
close $f
close $f2
set x
} {{script 3} {script 1} {script 2}}
test io-47.5 {file events on shared files, deleting file events} {testfevent fileevent} {
set f [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
fileevent $f readable {script 2}
testfevent cmd "fileevent $f readable {}"
set x [list [testfevent cmd "fileevent $f readable"] \
[fileevent $f readable]]
testfevent delete
close $f
set x
} {{} {script 2}}
test io-47.6 {file events on shared files, deleting file events} {testfevent fileevent} {
set f [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
fileevent $f readable {script 2}
fileevent $f readable {}
set x [list [testfevent cmd "fileevent $f readable"] \
[fileevent $f readable]]
testfevent delete
close $f
set x
} {{script 1} {}}
set path(bar) [makeFile {} bar]
test io-48.1 {testing readability conditions} {fileevent} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
set f [open $path(bar) r]
fileevent $f readable [namespace code [list consume $f]]
proc consume {f} {
variable l
variable x
lappend l called
if {[eof $f]} {
close $f
set x done
} else {
gets $f
}
}
set l ""
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
test io-48.2 {testing readability conditions} {nonBlockFiles fileevent} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
set f [open $path(bar) r]
fileevent $f readable [namespace code [list consume $f]]
fconfigure $f -blocking off
proc consume {f} {
variable x
variable l
lappend l called
if {[eof $f]} {
close $f
set x done
} else {
gets $f
}
}
set l ""
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
test io-48.3 {testing readability conditions} {stdio unixOnly nonBlockFiles openpipe fileevent} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
set f [open $path(my_script) w]
puts $f {
proc copy_slowly {f} {
while {![eof $f]} {
puts [gets $f]
after 200
}
close $f
}
}
close $f
set f [open "|[list [interpreter]]" r+]
fileevent $f readable [namespace code [list consume $f]]
fconfigure $f -buffering line
fconfigure $f -blocking off
proc consume {f} {
variable l
variable x
if {[eof $f]} {
set x done
} else {
gets $f
lappend l [fblocked $f]
gets $f
lappend l [fblocked $f]
}
}
set l ""
variable x not_done
puts $f [list source $path(my_script)]
puts $f "set f \[[list open $path(bar) r]]"
puts $f {copy_slowly $f}
puts $f {exit}
vwait [namespace which -variable x]
close $f
list $x $l
} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
variable c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation lf
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation cr
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable c
variable x
variable l
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable c
variable x
variable l
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation crlf
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable c
variable x
variable l
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-49.1 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
lappend l [eof $f]
lappend l [read $f 1]
lappend l [eof $f]
close $f
set l
} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 {
} 7 0 {} 1"
test io-49.2 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 2]
lappend l [tell $f]
lappend l [read $f 2]
lappend l [tell $f]
lappend l [read $f 2]
lappend l [tell $f]
lappend l [eof $f]
lappend l [read $f 2]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1"
test io-49.3 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 3]
lappend l [tell $f]
lappend l [read $f 3]
lappend l [tell $f]
lappend l [eof $f]
lappend l [read $f 3]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1"
test io-49.4 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 3]
lappend l [tell $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1"
test io-49.5 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [set x [gets $f]]
lappend l [tell $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} [list 7 a\rb\rc 7 {} 7 1]
testConstraint testchannelevent [llength [info commands testchannelevent]]
test io-50.1 {testing handler deletion} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f]]
proc delhandler {f} {
variable z
set z called
testchannelevent $f delete 0
}
set z not_called
update
close $f
set z
} called
test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
proc delhandler {f i} {
variable z
lappend z "called delhandler $f $i"
testchannelevent $f delete 0
}
set z ""
update
close $f
string compare [string tolower $z] \
[list [list called delhandler $f 0] [list called delhandler $f 1]]
} 0
test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
set z ""
proc notcalled {f i} {
variable z
lappend z "notcalled was called!! $f $i"
}
proc delhandler {f i} {
variable z
testchannelevent $f delete 1
lappend z "delhandler $f $i called"
testchannelevent $f delete 0
lappend z "delhandler $f $i deleted myself"
}
set z ""
update
close $f
string compare [string tolower $z] \
[list [list delhandler $f 0 called] \
[list delhandler $f 0 deleted myself]]
} 0
test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delrecursive $f]]
proc delrecursive {f} {
variable z
variable u
if {"$u" == "recursive"} {
testchannelevent $f delete 0
lappend z "delrecursive deleting recursive"
} else {
lappend z "delrecursive calling recursive"
set u recursive
update
}
}
set u toplevel
set z ""
update
close $f
string compare [string tolower $z] \
{{delrecursive calling recursive} {delrecursive deleting recursive}}
} 0
test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f]]
testchannelevent $f add readable [namespace code [list del $f]]
proc notcalled {f} {
variable z
lappend z "notcalled was called!! $f"
}
proc del {f} {
variable u
variable z
if {"$u" == "recursive"} {
testchannelevent $f delete 1
testchannelevent $f delete 0
lappend z "del deleted notcalled"
lappend z "del deleted myself"
} else {
set u recursive
lappend z "del calling recursive"
update
lappend z "del after update"
}
}
set z ""
set u toplevel
update
close $f
string compare [string tolower $z] \
[list {del calling recursive} {del deleted notcalled} \
{del deleted myself} {del after update}]
} 0
test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list second $f]]
testchannelevent $f add readable [namespace code [list first $f]]
proc first {f} {
variable u
variable z
if {"$u" == "toplevel"} {
lappend z "first called"
set u first
update
lappend z "first after update"
} else {
lappend z "first called not toplevel"
}
}
proc second {f} {
variable u
variable z
if {"$u" == "first"} {
lappend z "second called, first time"
set u second
testchannelevent $f delete 0
} elseif {"$u" == "second"} {
lappend z "second called, second time"
testchannelevent $f delete 0
} else {
lappend z "second called, cannot happen!"
testchannelevent $f removeall
}
}
set z ""
set u toplevel
update
close $f
string compare [string tolower $z] \
[list {first called} {first called not toplevel} \
{second called, first time} {second called, second time} \
{first after update}]
} 0
test io-51.1 {Test old socket deletion on Macintosh} {socket} {
set x 0
set result ""
proc accept {s a p} {
variable x
variable wait
fconfigure $s -blocking off
puts $s "sock[incr x]"
close $s
set wait done
}
set ss [socket -server [namespace code accept] 0]
variable wait ""
set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
set wait ""
set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
set wait ""
set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
set wait ""
set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
close $ss
set result
} {sock1 sock2 sock3 sock4}
test io-52.1 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fcopy $f1 $f2 -command { # }
catch { fcopy $f1 $f2 } msg
close $f1
close $f2
string compare $msg "channel \"$f1\" is busy"
} {0}
test io-52.2 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
set f3 [open $thisScript]
fcopy $f1 $f2 -command { # }
catch { fcopy $f3 $f2 } msg
close $f1
close $f2
close $f3
string compare $msg "channel \"$f2\" is busy"
} {0}
test io-52.3 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
set s0 [fcopy $f1 $f2]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.4 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -size 40
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
lappend result [file size $path(test1)]
} {0 0 40}
test io-52.5 {TclCopyChannel, all} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
fcopy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified.
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
fcopy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
fcopy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.6 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
set s0 [fcopy $f1 $f2 -size [expr [file size $thisScript] + 5]]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.7 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
fcopy $f1 $f2
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
close $f1
close $f2
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.8 {TclCopyChannel} {stdio openpipe fcopy} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
fconfigure $f1 -translation lf
puts $f1 "
puts ready
gets stdin
set f1 \[open [list $thisScript] r\]
fconfigure \$f1 -translation lf
puts \[read \$f1 100\]
close \$f1
"
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -translation lf
gets $f1
puts $f1 ready
flush $f1
set f2 [open $path(test1) w]
fconfigure $f2 -translation lf
set s0 [fcopy $f1 $f2 -size 40]
catch {close $f1}
close $f2
list $s0 [file size $path(test1)]
} {40 40}
# Empty files, to register them with the test facility
set path(kyrillic.txt) [makeFile {} kyrillic.txt]
set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt]
set path(utf8-rp.txt) [makeFile {} utf8-rp.txt]
# Create kyrillic file, use lf translation to avoid os eol issues
set out [open $path(kyrillic.txt) w]
fconfigure $out -encoding koi8-r -translation lf
puts $out "\u0410\u0410"
close $out
test io-52.9 {TclCopyChannel & encodings} {fcopy} {
# Copy kyrillic to UTF-8, using fcopy.
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
fconfigure $in -encoding koi8-r -translation lf
fconfigure $out -encoding utf-8 -translation lf
fcopy $in $out
close $in
close $out
# Do the same again, but differently (read/puts).
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-rp.txt) w]
fconfigure $in -encoding koi8-r -translation lf
fconfigure $out -encoding utf-8 -translation lf
puts -nonewline $out [read $in]
close $in
close $out
list [file size $path(kyrillic.txt)] \
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
test io-52.10 {TclCopyChannel & encodings} {fcopy} {
# encoding to binary (=> implies that the
# internal utf-8 is written)
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
fconfigure $in -encoding koi8-r -translation lf
# -translation binary is also -encoding binary
fconfigure $out -translation binary
fcopy $in $out
close $in
close $out
file size $path(utf8-fcopy.txt)
} 5
test io-52.11 {TclCopyChannel & encodings} {fcopy} {
# binary to encoding => the input has to be
# in utf-8 to make sense to the encoder
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
# -translation binary is also -encoding binary
fconfigure $in -translation binary
fconfigure $out -encoding koi8-r -translation lf
fcopy $in $out
close $in
close $out
file size $path(kyrillic.txt)
} 3
test io-53.1 {CopyData} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -size 0
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
lappend result [file size $path(test1)]
} {0 0 0}
test io-53.2 {CopyData} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -command [namespace code {set s0}]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
variable s0
vwait [namespace which -variable s0]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-53.3 {CopyData: background read underflow} {stdio unixOnly openpipe fcopy} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts -nonewline $f1 {
puts ready
flush stdout ;# Don't assume line buffered!
fcopy stdin stdout -command { set x }
vwait x
set f [}
puts $f1 [list open $path(test1) w]]
puts $f1 {
fconfigure $f -translation lf
puts $f "done"
close $f
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set result [gets $f1]
puts $f1 line1
flush $f1
lappend result [gets $f1]
puts $f1 line2
flush $f1
lappend result [gets $f1]
close $f1
after 500
set f [open $path(test1)]
lappend result [read $f]
close $f
set result
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio unixOnly openpipe fileevent fcopy} {
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts ready
fcopy stdin stdout -command { set x }
vwait x
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f "done"
close $f
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set result [gets $f1]
fconfigure $f1 -blocking 0
puts $f1 $big
flush $f1
after 500
set result ""
fileevent $f1 read [namespace code {
append result [read $f1 1024]
if {[string length $result] >= [string length $big]} {
set x done
}
}]
vwait [namespace which -variable x]
close $f1
set big {}
set x
} done
set result {}
proc FcopyTestAccept {sock args} {
after 1000 "close $sock"
}
proc FcopyTestDone {bytes {error {}}} {
variable fcopyTestDone
if {[string length $error]} {
set fcopyTestDone 1
} else {
set fcopyTestDone 0
}
}
test io-53.5 {CopyData: error during fcopy} {socket fcopy} {
variable fcopyTestDone
set listen [socket -server [namespace code FcopyTestAccept] 0]
set in [open $thisScript] ;# 126 K
set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]]
catch {unset fcopyTestDone}
close $listen ;# This means the socket open never really succeeds
fcopy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
if ![info exists fcopyTestDone] {
vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g.
}
close $in
close $out
set fcopyTestDone ;# 1 for error condition
} 1
test io-53.6 {CopyData: error during fcopy} {stdio openpipe fcopy} {
variable fcopyTestDone
file delete $path(pipe)
file delete $path(test1)
catch {unset fcopyTestDone}
set f1 [open $path(pipe) w]
puts $f1 "exit 1"
close $f1
set in [open "|[list [interpreter] $path(pipe)]" r+]
set out [open $path(test1) w]
fcopy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
if ![info exists fcopyTestDone] {
vwait [namespace which -variable fcopyTestDone]
}
catch {close $in}
close $out
set fcopyTestDone ;# 0 for plain end of file
} {0}
proc doFcopy {in out {bytes 0} {error {}}} {
variable fcopyTestDone
variable fcopyTestCount
incr fcopyTestCount $bytes
if {[string length $error]} {
set fcopyTestDone 1
} elseif {[eof $in]} {
set fcopyTestDone 0
} else {
# Delay next fcopy to wait for size>0 input bytes
after 100 [list
fcopy $in $out -size 1000 \
-command [namespace code [list doFcopy $in $out]]
]
}
}
test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} {
variable fcopyTestDone
file delete $path(pipe)
catch {unset fcopyTestDone}
set fcopyTestCount 0
set f1 [open $path(pipe) w]
puts $f1 {
# Write 10 bytes / 10 msec
proc Write {count} {
puts -nonewline "1234567890"
if {[incr count -1]} {
after 10 [list Write $count]
} else {
set ::ready 1
}
}
fconfigure stdout -buffering none
Write 345 ;# 3450 bytes ~3.45 sec
vwait ready
exit 0
}
close $f1
set in [open "|[list [interpreter] $path(pipe) &]" r+]
set out [open $path(test1) w]
doFcopy $in $out
variable fcopyTestDone
if ![info exists fcopyTestDone] {
vwait [namespace which -variable fcopyTestDone]
}
catch {close $in}
close $out
# -1=error 0=script error N=number of bytes
expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1
} {3450}
test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup {
# copy progress callback. errors out intentionally
proc ::cmd args {
lappend ::RES "CMD $args"
error !STOP
}
# capture callback error here
proc ::bgerror args {
lappend ::RES "bgerror/OK $args"
set ::forever has-been-reached
return
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio openpipe fcopy} -body {
# Record input size, so that result is always defined
lappend ::RES [file size $bar]
# Run the copy. Should not invoke -command now.
fcopy $f $g -size 2 -command ::cmd
# Check that -command was not called synchronously
set sbs [file size $bar]
lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs
# Now let the async part happen. Should capture the error in cmd
# via bgerror. If not break the event loop via timer.
set token [after 1000 {
lappend ::RES {bgerror/FAIL timeout}
set ::forever has-been-reached
}]
vwait ::forever
catch {after cancel $token}
# Report
set ::RES
} -cleanup {
close $f
close $g
catch {unset ::RES}
catch {unset ::forever}
rename ::cmd {}
rename ::bgerror {}
removeFile foo
removeFile bar
} -result {0 sync/OK 0 {CMD 2} {bgerror/OK !STOP}}
test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} -setup {
# copy progress callback. errors out intentionally
proc ::cmd args {
lappend ::RES "CMD $args"
set ::forever has-been-reached
return
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio openpipe fcopy} -body {
# Initialize and force eof on the input.
seek $f 0 end ; read $f 1
set ::RES [eof $f]
# Run the copy. Should not invoke -command now.
fcopy $f $g -size 2 -command ::cmd
# Check that -command was not called synchronously
lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}]
# Now let the async part happen. Should capture the eof in cmd
# If not break the event loop via timer.
set token [after 1000 {
lappend ::RES {cmd/FAIL timeout}
set ::forever has-been-reached
}]
vwait ::forever
catch {after cancel $token}
# Report
set ::RES
} -cleanup {
close $f
close $g
catch {unset ::RES}
catch {unset ::forever}
rename ::cmd {}
removeFile foo
removeFile bar
} -result {1 sync/OK {CMD 0}}
test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup {
set out [makeFile {} out]
set err [makeFile {} err]
set pipe [open "|[list [info nameofexecutable] 2> $err]" r+]
fconfigure $pipe -translation binary -buffering line
puts $pipe {
fconfigure stdout -translation binary -buffering line
puts stderr Waiting...
after 1000
foreach x {a b c} {
puts stderr Looping...
puts $x
after 500
}
proc bye args {
if {[gets stdin line]<0} {
puts stderr "CHILD: EOF detected, exiting"
exit
} else {
puts stderr "CHILD: ignoring line: $line"
}
}
puts stderr Now-sleeping-forever
fileevent stdin readable bye
vwait forever
}
proc ::done args {
set ::forever OK
return
}
set ::forever {}
set out [open $out w]
} -constraints {stdio openpipe fcopy} -body {
fcopy $pipe $out -size 6 -command ::done
set token [after 5000 {
set ::forever {fcopy hangs}
}]
vwait ::forever
catch {after cancel $token}
set ::forever
} -cleanup {
close $pipe
rename ::done {}
after 1000 ;# Give Windows time to kill the process
catch {close $out}
removeFile out
removeFile err
catch {unset ::forever}
} -result OK
test io-53.10 {Bug 1350564, multi-directional fcopy} -setup {
set err [makeFile {} err]
set pipe [open "|[list [info nameofexecutable] 2> $err]" r+]
fconfigure $pipe -translation binary -buffering line
puts $pipe {
fconfigure stderr -buffering line
# Kill server when pipe closed by invoker.
proc bye args {
if {![eof stdin]} { gets stdin ; return }
puts stderr BYE
exit
}
# Server code. Bi-directional copy between 2 sockets.
proc geof {sok} {
puts stderr DONE/$sok
close $sok
}
proc new {sok args} {
puts stderr NEW/$sok
global l srv
fconfigure $sok -translation binary -buffering none
lappend l $sok
if {[llength $l]==2} {
close $srv
foreach {a b} $l break
fcopy $a $b -command [list geof $a]
fcopy $b $a -command [list geof $b]
puts stderr 2COPY
}
puts stderr ...
}
puts stderr SRV
set l {}
set srv [socket -server new 9999]
puts stderr WAITING
fileevent stdin readable bye
puts OK
vwait forever
}
# wait for OK from server.
gets $pipe
# Now the two clients.
proc ::done {sock} {
if {[eof $sock]} { close $sock ; return }
lappend ::forever [gets $sock]
return
}
set a [socket 127.0.0.1 9999]
set b [socket 127.0.0.1 9999]
fconfigure $a -translation binary -buffering none
fconfigure $b -translation binary -buffering none
fileevent $a readable [list ::done $a]
fileevent $b readable [list ::done $b]
} -constraints {stdio openpipe fcopy} -body {
# Now pass data through the server in both directions.
set ::forever {}
puts $a AB
vwait ::forever
puts $b BA
vwait ::forever
set ::forever
} -cleanup {
catch {close $a}
catch {close $b}
close $pipe
rename ::done {}
after 1000 ;# Give Windows time to kill the process
removeFile err
catch {unset ::forever}
} -result {AB BA}
test io-53.11 {Bug 2895565} -setup {
set in [makeFile {} in]
set f [open $in w]
fconfigure $f -encoding utf-8 -translation binary
puts -nonewline $f [string repeat "Ho hum\n" 11]
close $f
set inChan [open $in r]
fconfigure $inChan -translation binary
set out [makeFile {} out]
set outChan [open $out w]
fconfigure $outChan -encoding cp1252 -translation crlf
proc CopyDone {bytes args} {
variable done
if {[llength $args]} {
set done "Error: '[lindex $args 0]' after $bytes bytes copied"
} else {
set done "$bytes bytes copied"
}
}
} -body {
variable done
after 2000 [list set [namespace which -variable done] timeout]
fcopy $inChan $outChan -size 40 -command [namespace which CopyDone]
vwait [namespace which -variable done]
set done
} -cleanup {
close $outChan
close $inChan
removeFile out
removeFile in
} -result {40 bytes copied}
test io-54.1 {Recursive channel events} {socket fileevent} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
proc accept {s a p} {
variable as
fconfigure $s -translation lf
puts $s "line 1\nline2\nline3"
flush $s
set as $s
}
proc readit {s next} {
variable x
variable result
lappend result $next
if {$next == 1} {
fileevent $s readable [namespace code [list readit $s 2]]
vwait [namespace which -variable x]
}
incr x
}
set ss [socket -server [namespace code accept] 0]
# We need to delay on some systems until the creation of the
# server socket completes.
set done 0
for {set i 0} {$i < 10} {incr i} {
if {![catch {set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]}]} {
set done 1
break
}
after 100
}
if {$done == 0} {
close $ss
error "failed to connect to server"
}
variable result {}
variable x 0
variable as
vwait [namespace which -variable as]
fconfigure $cs -translation lf
lappend result [gets $cs]
fconfigure $cs -blocking off
fileevent $cs readable [namespace code [list readit $cs 1]]
set a [after 2000 [namespace code { set x failure }]]
vwait [namespace which -variable x]
after cancel $a
close $as
close $ss
close $cs
list $result $x
} {{{line 1} 1 2} 2}
test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileevent} {
set accept {}
set after {}
variable s [socket -server [namespace code accept] 0]
proc accept {s a p} {
variable counter
variable accept
set accept $s
set counter 0
fconfigure $s -blocking off -buffering line -translation lf
fileevent $s readable [namespace code "doit $s"]
}
proc doit {s} {
variable counter
variable after
incr counter
set l [gets $s]
if {"$l" == ""} {
fileevent $s readable [namespace code "doit1 $s"]
set after [after 1000 [namespace code newline]]
}
}
proc doit1 {s} {
variable counter
variable accept
incr counter
set l [gets $s]
close $s
set accept {}
}
proc producer {} {
variable s
variable writer
set writer [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
fconfigure $writer -buffering line
puts -nonewline $writer hello
flush $writer
}
proc newline {} {
variable done
variable writer
puts $writer hello
flush $writer
set done 1
}
producer
variable done
vwait [namespace which -variable done]
close $writer
close $s
after cancel $after
if {$accept != {}} {close $accept}
set counter
} 1
set path(fooBar) [makeFile {} fooBar]
test io-55.1 {ChannelEventScriptInvoker: deletion} {fileevent} {
variable x
proc eventScript {fd} {
variable x
close $fd
error "planned error"
set x whoops
}
proc ::bgerror {args} "set [namespace which -variable x] got_error"
set f [open $path(fooBar) w]
fileevent $f writable [namespace code [list eventScript $f]]
variable x not_done
vwait [namespace which -variable x]
set x
} {got_error}
test io-56.1 {ChannelTimerProc} {testchannelevent} {
set f [open $path(fooBar) w]
puts $f "this is a test"
close $f
set f [open $path(fooBar) r]
testchannelevent $f add readable [namespace code {
read $f 1
incr x
}]
variable x 0
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set result $x
testchannelevent $f set 0 none
after idle [namespace code {set y done}]
variable y
vwait [namespace which -variable y]
close $f
lappend result $y
} {2 done}
test io-57.1 {buffered data and file events, gets} {fileevent} {
proc accept {sock args} {
variable s2
set s2 $sock
}
set server [socket -server [namespace code accept] 0]
set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
variable s2
vwait [namespace which -variable s2]
update
fileevent $s2 readable [namespace code {lappend result readable}]
puts $s "12\n34567890"
flush $s
variable result [gets $s2]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [gets $s2]
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {12 readable 34567890 timer}
test io-57.2 {buffered data and file events, read} {fileevent} {
proc accept {sock args} {
variable s2
set s2 $sock
}
set server [socket -server [namespace code accept] 0]
set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
variable s2
vwait [namespace which -variable s2]
update
fileevent $s2 readable [namespace code {lappend result readable}]
puts -nonewline $s "1234567890"
flush $s
variable result [read $s2 1]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [read $s2 9]
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} {
set out [open $path(script) w]
puts $out {
puts "normal message from pipe"
puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
variable x
variable result
if {[eof $pipe]} {
set x [catch {close $pipe} line]
lappend result catch $line
} else {
gets $pipe line
lappend result gets $line
}
}
close $out
set pipe [open "|[list [interpreter] $path(script)]" r]
fileevent $pipe readable [namespace code [list readit $pipe]]
variable x ""
set result ""
vwait [namespace which -variable x]
list $x $result
} {1 {gets {normal message from pipe} gets {} catch {error message from pipe}}}
testConstraint testmainthread [llength [info commands testmainthread]]
test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
# TIP #10
# More complicated tests (like that the reference changes as a
# channel is moved from thread to thread) can be done only in the
# extension which fully implements the moving of channels between
# threads, i.e. 'Threads'. Or we have to extend [testthread] as well.
set f [open $path(longfile) r]
set result [testchannel mthread $f]
close $f
string equal $result [testmainthread]
} {1}
test io-60.1 {writing illegal utf sequences} {openpipe fileevent} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
puts $out {
puts [encoding convertfrom identity \xe2]
exit 1
}
proc readit {pipe} {
variable x
variable result
if {[eof $pipe]} {
set x [catch {close $pipe} line]
lappend result catch $line
} else {
gets $pipe line
lappend result gets $line
}
}
close $out
set pipe [open "|[list [interpreter] $path(script)]" r]
fileevent $pipe readable [namespace code [list readit $pipe]]
variable x ""
set result ""
vwait [namespace which -variable x]
# cut of the remainder of the error stack, especially the filename
set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
list $x $result
} {1 {gets {} catch {error writing "stdout": invalid argument}}}
test io-61.1 {Reset eof state after changing the eof char} -setup {
set datafile [makeFile {} eofchar]
set f [open $datafile w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat "Ho hum\n" 11]
puts $f =
set line [string repeat "Ge gla " 4]
puts -nonewline $f [string repeat [string trimright $line]\n 834]
close $f
} -body {
set f [open $datafile r]
fconfigure $f -eofchar =
set res {}
lappend res [read $f; tell $f]
fconfigure $f -eofchar {}
lappend res [read $f 1]
lappend res [read $f; tell $f]
# Any seek zaps the internals into a good state.
#seek $f 0 start
#seek $f 0 current
#lappend res [read $f; tell $f]
close $f
set res
} -cleanup {
removeFile eofchar
} -result {77 = 23431}
# cleanup
foreach file [list fooBar longfile script output test1 pipe my_script \
test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return
tcl8.4.20/tests/lrange.test 0000644 0036047 0045461 00000005545 11737050674 014243 0 ustar dgp 771div # Commands covered: lrange
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
} {b c}
test lrange-1.2 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
} {{bcd e {f g {}}}}
test lrange-1.3 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 3 end
} {l15 d}
test lrange-1.4 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 4 10000
} {d}
test lrange-1.5 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 4 3
} {}
test lrange-1.6 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 10 11
} {}
test lrange-1.7 {range of list elements} {
lrange {a b c d e} -1 2
} {a b c}
test lrange-1.8 {range of list elements} {
lrange {a b c d e} -2 -1
} {}
test lrange-1.9 {range of list elements} {
lrange {a b c d e} -2 e
} {a b c d e}
test lrange-1.10 {range of list elements} {
lrange "a b\{c d" 1 2
} "b\\{c d"
test lrange-1.11 {range of list elements} {
lrange "a b c d" end end
} d
test lrange-1.12 {range of list elements} {
lrange "a b c d" end 100000
} d
test lrange-1.13 {range of list elements} {
lrange "a b c d" e 3
} d
test lrange-1.14 {range of list elements} {
lrange "a b c d" end 2
} {}
test lrange-1.15 {range of list elements} {
concat \"[lrange {a b \{\ } 0 2]"
} {"a b \{\ "}
test lrange-1.16 {list element quoting} {
lrange {[append a .b]} 0 end
} {{[append} a .b\]}
test lrange-2.1 {error conditions} {
list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer or end?-integer?}}
test lrange-2.4 {error conditions} {
list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer or end?-integer?}}
test lrange-2.5 {error conditions} {
list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/lsetComp.test 0000755 0036047 0045461 00000040110 11737050674 014547 0 ustar dgp 771div # This file is a -*- tcl -*- test script
# Commands covered: lset
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Procedure to evaluate a script within a proc, to test compilation
# functionality
proc evalInProc { script } {
proc testProc {} $script
set status [catch {
testProc
} result]
rename testProc {}
return [list $status $result]
}
# Tests for the bytecode compilation of the 'lset' command
test lsetComp-1.1 {lset, compiled, wrong \# args} {
evalInProc {
lset
}
} "1 {wrong \# args: should be \"lset listVar index ?index...? value\"}"
test lsetComp-2.1 {lset, compiled, list of args, not a simple var name} {
evalInProc {
set y x
set x {{1 2} {3 4}}
lset $y {1 1} 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-2.2 {lset, compiled, list of args, scalar on stack} {
evalInProc {
set ::x {{1 2} {3 4}}
lset ::x {1 1} 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-2.3 {lset, compiled, list of args, scalar, one-byte offset} {
evalInProc {
set x {{1 2} {3 4}}
lset x {1 1} 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-2.4 {lset, compiled, list of args, scalar, four-byte offset} {
evalInProc {
set x0 0; set x1 0; set x2 0; set x3 0;
set x4 0; set x5 0; set x6 0; set x7 0;
set x8 0; set x9 0; set x10 0; set x11 0;
set x12 0; set x13 0; set x14 0; set x15 0;
set x16 0; set x17 0; set x18 0; set x19 0;
set x20 0; set x21 0; set x22 0; set x23 0;
set x24 0; set x25 0; set x26 0; set x27 0;
set x28 0; set x29 0; set x30 0; set x31 0;
set x32 0; set x33 0; set x34 0; set x35 0;
set x36 0; set x37 0; set x38 0; set x39 0;
set x40 0; set x41 0; set x42 0; set x43 0;
set x44 0; set x45 0; set x46 0; set x47 0;
set x48 0; set x49 0; set x50 0; set x51 0;
set x52 0; set x53 0; set x54 0; set x55 0;
set x56 0; set x57 0; set x58 0; set x59 0;
set x60 0; set x61 0; set x62 0; set x63 0;
set x64 0; set x65 0; set x66 0; set x67 0;
set x68 0; set x69 0; set x70 0; set x71 0;
set x72 0; set x73 0; set x74 0; set x75 0;
set x76 0; set x77 0; set x78 0; set x79 0;
set x80 0; set x81 0; set x82 0; set x83 0;
set x84 0; set x85 0; set x86 0; set x87 0;
set x88 0; set x89 0; set x90 0; set x91 0;
set x92 0; set x93 0; set x94 0; set x95 0;
set x96 0; set x97 0; set x98 0; set x99 0;
set x100 0; set x101 0; set x102 0; set x103 0;
set x104 0; set x105 0; set x106 0; set x107 0;
set x108 0; set x109 0; set x110 0; set x111 0;
set x112 0; set x113 0; set x114 0; set x115 0;
set x116 0; set x117 0; set x118 0; set x119 0;
set x120 0; set x121 0; set x122 0; set x123 0;
set x124 0; set x125 0; set x126 0; set x127 0;
set x128 0; set x129 0; set x130 0; set x131 0;
set x132 0; set x133 0; set x134 0; set x135 0;
set x136 0; set x137 0; set x138 0; set x139 0;
set x140 0; set x141 0; set x142 0; set x143 0;
set x144 0; set x145 0; set x146 0; set x147 0;
set x148 0; set x149 0; set x150 0; set x151 0;
set x152 0; set x153 0; set x154 0; set x155 0;
set x156 0; set x157 0; set x158 0; set x159 0;
set x160 0; set x161 0; set x162 0; set x163 0;
set x164 0; set x165 0; set x166 0; set x167 0;
set x168 0; set x169 0; set x170 0; set x171 0;
set x172 0; set x173 0; set x174 0; set x175 0;
set x176 0; set x177 0; set x178 0; set x179 0;
set x180 0; set x181 0; set x182 0; set x183 0;
set x184 0; set x185 0; set x186 0; set x187 0;
set x188 0; set x189 0; set x190 0; set x191 0;
set x192 0; set x193 0; set x194 0; set x195 0;
set x196 0; set x197 0; set x198 0; set x199 0;
set x200 0; set x201 0; set x202 0; set x203 0;
set x204 0; set x205 0; set x206 0; set x207 0;
set x208 0; set x209 0; set x210 0; set x211 0;
set x212 0; set x213 0; set x214 0; set x215 0;
set x216 0; set x217 0; set x218 0; set x219 0;
set x220 0; set x221 0; set x222 0; set x223 0;
set x224 0; set x225 0; set x226 0; set x227 0;
set x228 0; set x229 0; set x230 0; set x231 0;
set x232 0; set x233 0; set x234 0; set x235 0;
set x236 0; set x237 0; set x238 0; set x239 0;
set x240 0; set x241 0; set x242 0; set x243 0;
set x244 0; set x245 0; set x246 0; set x247 0;
set x248 0; set x249 0; set x250 0; set x251 0;
set x252 0; set x253 0; set x254 0; set x255 0;
set x {{1 2} {3 4}}
lset x {1 1} 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-2.5 {lset, compiled, list of args, array on stack} {
evalInProc {
set ::y(0) {{1 2} {3 4}}
lset ::y(0) {1 1} 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-2.6 {lset, compiled, list of args, array, one-byte offset} {
evalInProc {
set y(0) {{1 2} {3 4}}
lset y(0) {1 1} 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-2.7 {lset, compiled, list of args, array, four-byte offset} {
evalInProc {
set x0 0; set x1 0; set x2 0; set x3 0;
set x4 0; set x5 0; set x6 0; set x7 0;
set x8 0; set x9 0; set x10 0; set x11 0;
set x12 0; set x13 0; set x14 0; set x15 0;
set x16 0; set x17 0; set x18 0; set x19 0;
set x20 0; set x21 0; set x22 0; set x23 0;
set x24 0; set x25 0; set x26 0; set x27 0;
set x28 0; set x29 0; set x30 0; set x31 0;
set x32 0; set x33 0; set x34 0; set x35 0;
set x36 0; set x37 0; set x38 0; set x39 0;
set x40 0; set x41 0; set x42 0; set x43 0;
set x44 0; set x45 0; set x46 0; set x47 0;
set x48 0; set x49 0; set x50 0; set x51 0;
set x52 0; set x53 0; set x54 0; set x55 0;
set x56 0; set x57 0; set x58 0; set x59 0;
set x60 0; set x61 0; set x62 0; set x63 0;
set x64 0; set x65 0; set x66 0; set x67 0;
set x68 0; set x69 0; set x70 0; set x71 0;
set x72 0; set x73 0; set x74 0; set x75 0;
set x76 0; set x77 0; set x78 0; set x79 0;
set x80 0; set x81 0; set x82 0; set x83 0;
set x84 0; set x85 0; set x86 0; set x87 0;
set x88 0; set x89 0; set x90 0; set x91 0;
set x92 0; set x93 0; set x94 0; set x95 0;
set x96 0; set x97 0; set x98 0; set x99 0;
set x100 0; set x101 0; set x102 0; set x103 0;
set x104 0; set x105 0; set x106 0; set x107 0;
set x108 0; set x109 0; set x110 0; set x111 0;
set x112 0; set x113 0; set x114 0; set x115 0;
set x116 0; set x117 0; set x118 0; set x119 0;
set x120 0; set x121 0; set x122 0; set x123 0;
set x124 0; set x125 0; set x126 0; set x127 0;
set x128 0; set x129 0; set x130 0; set x131 0;
set x132 0; set x133 0; set x134 0; set x135 0;
set x136 0; set x137 0; set x138 0; set x139 0;
set x140 0; set x141 0; set x142 0; set x143 0;
set x144 0; set x145 0; set x146 0; set x147 0;
set x148 0; set x149 0; set x150 0; set x151 0;
set x152 0; set x153 0; set x154 0; set x155 0;
set x156 0; set x157 0; set x158 0; set x159 0;
set x160 0; set x161 0; set x162 0; set x163 0;
set x164 0; set x165 0; set x166 0; set x167 0;
set x168 0; set x169 0; set x170 0; set x171 0;
set x172 0; set x173 0; set x174 0; set x175 0;
set x176 0; set x177 0; set x178 0; set x179 0;
set x180 0; set x181 0; set x182 0; set x183 0;
set x184 0; set x185 0; set x186 0; set x187 0;
set x188 0; set x189 0; set x190 0; set x191 0;
set x192 0; set x193 0; set x194 0; set x195 0;
set x196 0; set x197 0; set x198 0; set x199 0;
set x200 0; set x201 0; set x202 0; set x203 0;
set x204 0; set x205 0; set x206 0; set x207 0;
set x208 0; set x209 0; set x210 0; set x211 0;
set x212 0; set x213 0; set x214 0; set x215 0;
set x216 0; set x217 0; set x218 0; set x219 0;
set x220 0; set x221 0; set x222 0; set x223 0;
set x224 0; set x225 0; set x226 0; set x227 0;
set x228 0; set x229 0; set x230 0; set x231 0;
set x232 0; set x233 0; set x234 0; set x235 0;
set x236 0; set x237 0; set x238 0; set x239 0;
set x240 0; set x241 0; set x242 0; set x243 0;
set x244 0; set x245 0; set x246 0; set x247 0;
set x248 0; set x249 0; set x250 0; set x251 0;
set x252 0; set x253 0; set x254 0; set x255 0;
set y(0) {{1 2} {3 4}}
lset y(0) {1 1} 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-2.8 {lset, compiled, list of args, error } {
evalInProc {
set x { {1 2} {3 4} }
lset x {1 5} 5
}
} "1 {list index out of range}"
test lsetComp-2.9 {lset, compiled, list of args, error - is string preserved} {
set ::x { { 1 2 } { 3 4 } }
evalInProc {
lset ::x { 1 5 } 5
}
list $::x [lindex $::x 1]
} "{ { 1 2 } { 3 4 } } { 3 4 }"
test lsetComp-3.1 {lset, compiled, flat args, not a simple var name} {
evalInProc {
set y x
set x {{1 2} {3 4}}
lset $y 1 1 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-3.2 {lset, compiled, flat args, scalar on stack} {
evalInProc {
set ::x {{1 2} {3 4}}
lset ::x 1 1 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-3.3 {lset, compiled, flat args, scalar, one-byte offset} {
evalInProc {
set x {{1 2} {3 4}}
lset x 1 1 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-3.4 {lset, compiled, scalar, four-byte offset} {
evalInProc {
set x0 0; set x1 0; set x2 0; set x3 0;
set x4 0; set x5 0; set x6 0; set x7 0;
set x8 0; set x9 0; set x10 0; set x11 0;
set x12 0; set x13 0; set x14 0; set x15 0;
set x16 0; set x17 0; set x18 0; set x19 0;
set x20 0; set x21 0; set x22 0; set x23 0;
set x24 0; set x25 0; set x26 0; set x27 0;
set x28 0; set x29 0; set x30 0; set x31 0;
set x32 0; set x33 0; set x34 0; set x35 0;
set x36 0; set x37 0; set x38 0; set x39 0;
set x40 0; set x41 0; set x42 0; set x43 0;
set x44 0; set x45 0; set x46 0; set x47 0;
set x48 0; set x49 0; set x50 0; set x51 0;
set x52 0; set x53 0; set x54 0; set x55 0;
set x56 0; set x57 0; set x58 0; set x59 0;
set x60 0; set x61 0; set x62 0; set x63 0;
set x64 0; set x65 0; set x66 0; set x67 0;
set x68 0; set x69 0; set x70 0; set x71 0;
set x72 0; set x73 0; set x74 0; set x75 0;
set x76 0; set x77 0; set x78 0; set x79 0;
set x80 0; set x81 0; set x82 0; set x83 0;
set x84 0; set x85 0; set x86 0; set x87 0;
set x88 0; set x89 0; set x90 0; set x91 0;
set x92 0; set x93 0; set x94 0; set x95 0;
set x96 0; set x97 0; set x98 0; set x99 0;
set x100 0; set x101 0; set x102 0; set x103 0;
set x104 0; set x105 0; set x106 0; set x107 0;
set x108 0; set x109 0; set x110 0; set x111 0;
set x112 0; set x113 0; set x114 0; set x115 0;
set x116 0; set x117 0; set x118 0; set x119 0;
set x120 0; set x121 0; set x122 0; set x123 0;
set x124 0; set x125 0; set x126 0; set x127 0;
set x128 0; set x129 0; set x130 0; set x131 0;
set x132 0; set x133 0; set x134 0; set x135 0;
set x136 0; set x137 0; set x138 0; set x139 0;
set x140 0; set x141 0; set x142 0; set x143 0;
set x144 0; set x145 0; set x146 0; set x147 0;
set x148 0; set x149 0; set x150 0; set x151 0;
set x152 0; set x153 0; set x154 0; set x155 0;
set x156 0; set x157 0; set x158 0; set x159 0;
set x160 0; set x161 0; set x162 0; set x163 0;
set x164 0; set x165 0; set x166 0; set x167 0;
set x168 0; set x169 0; set x170 0; set x171 0;
set x172 0; set x173 0; set x174 0; set x175 0;
set x176 0; set x177 0; set x178 0; set x179 0;
set x180 0; set x181 0; set x182 0; set x183 0;
set x184 0; set x185 0; set x186 0; set x187 0;
set x188 0; set x189 0; set x190 0; set x191 0;
set x192 0; set x193 0; set x194 0; set x195 0;
set x196 0; set x197 0; set x198 0; set x199 0;
set x200 0; set x201 0; set x202 0; set x203 0;
set x204 0; set x205 0; set x206 0; set x207 0;
set x208 0; set x209 0; set x210 0; set x211 0;
set x212 0; set x213 0; set x214 0; set x215 0;
set x216 0; set x217 0; set x218 0; set x219 0;
set x220 0; set x221 0; set x222 0; set x223 0;
set x224 0; set x225 0; set x226 0; set x227 0;
set x228 0; set x229 0; set x230 0; set x231 0;
set x232 0; set x233 0; set x234 0; set x235 0;
set x236 0; set x237 0; set x238 0; set x239 0;
set x240 0; set x241 0; set x242 0; set x243 0;
set x244 0; set x245 0; set x246 0; set x247 0;
set x248 0; set x249 0; set x250 0; set x251 0;
set x252 0; set x253 0; set x254 0; set x255 0;
set x {{1 2} {3 4}}
lset x 1 1 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-3.5 {lset, compiled, flat args, array on stack} {
evalInProc {
set ::y(0) {{1 2} {3 4}}
lset ::y(0) 1 1 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-3.6 {lset, compiled, flat args, array, one-byte offset} {
evalInProc {
set y(0) {{1 2} {3 4}}
lset y(0) 1 1 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-3.7 {lset, compiled, flat args, array, four-byte offset} {
evalInProc {
set x0 0; set x1 0; set x2 0; set x3 0;
set x4 0; set x5 0; set x6 0; set x7 0;
set x8 0; set x9 0; set x10 0; set x11 0;
set x12 0; set x13 0; set x14 0; set x15 0;
set x16 0; set x17 0; set x18 0; set x19 0;
set x20 0; set x21 0; set x22 0; set x23 0;
set x24 0; set x25 0; set x26 0; set x27 0;
set x28 0; set x29 0; set x30 0; set x31 0;
set x32 0; set x33 0; set x34 0; set x35 0;
set x36 0; set x37 0; set x38 0; set x39 0;
set x40 0; set x41 0; set x42 0; set x43 0;
set x44 0; set x45 0; set x46 0; set x47 0;
set x48 0; set x49 0; set x50 0; set x51 0;
set x52 0; set x53 0; set x54 0; set x55 0;
set x56 0; set x57 0; set x58 0; set x59 0;
set x60 0; set x61 0; set x62 0; set x63 0;
set x64 0; set x65 0; set x66 0; set x67 0;
set x68 0; set x69 0; set x70 0; set x71 0;
set x72 0; set x73 0; set x74 0; set x75 0;
set x76 0; set x77 0; set x78 0; set x79 0;
set x80 0; set x81 0; set x82 0; set x83 0;
set x84 0; set x85 0; set x86 0; set x87 0;
set x88 0; set x89 0; set x90 0; set x91 0;
set x92 0; set x93 0; set x94 0; set x95 0;
set x96 0; set x97 0; set x98 0; set x99 0;
set x100 0; set x101 0; set x102 0; set x103 0;
set x104 0; set x105 0; set x106 0; set x107 0;
set x108 0; set x109 0; set x110 0; set x111 0;
set x112 0; set x113 0; set x114 0; set x115 0;
set x116 0; set x117 0; set x118 0; set x119 0;
set x120 0; set x121 0; set x122 0; set x123 0;
set x124 0; set x125 0; set x126 0; set x127 0;
set x128 0; set x129 0; set x130 0; set x131 0;
set x132 0; set x133 0; set x134 0; set x135 0;
set x136 0; set x137 0; set x138 0; set x139 0;
set x140 0; set x141 0; set x142 0; set x143 0;
set x144 0; set x145 0; set x146 0; set x147 0;
set x148 0; set x149 0; set x150 0; set x151 0;
set x152 0; set x153 0; set x154 0; set x155 0;
set x156 0; set x157 0; set x158 0; set x159 0;
set x160 0; set x161 0; set x162 0; set x163 0;
set x164 0; set x165 0; set x166 0; set x167 0;
set x168 0; set x169 0; set x170 0; set x171 0;
set x172 0; set x173 0; set x174 0; set x175 0;
set x176 0; set x177 0; set x178 0; set x179 0;
set x180 0; set x181 0; set x182 0; set x183 0;
set x184 0; set x185 0; set x186 0; set x187 0;
set x188 0; set x189 0; set x190 0; set x191 0;
set x192 0; set x193 0; set x194 0; set x195 0;
set x196 0; set x197 0; set x198 0; set x199 0;
set x200 0; set x201 0; set x202 0; set x203 0;
set x204 0; set x205 0; set x206 0; set x207 0;
set x208 0; set x209 0; set x210 0; set x211 0;
set x212 0; set x213 0; set x214 0; set x215 0;
set x216 0; set x217 0; set x218 0; set x219 0;
set x220 0; set x221 0; set x222 0; set x223 0;
set x224 0; set x225 0; set x226 0; set x227 0;
set x228 0; set x229 0; set x230 0; set x231 0;
set x232 0; set x233 0; set x234 0; set x235 0;
set x236 0; set x237 0; set x238 0; set x239 0;
set x240 0; set x241 0; set x242 0; set x243 0;
set x244 0; set x245 0; set x246 0; set x247 0;
set x248 0; set x249 0; set x250 0; set x251 0;
set x252 0; set x253 0; set x254 0; set x255 0;
set y(0) {{1 2} {3 4}}
lset y(0) 1 1 5
}
} "0 {{1 2} {3 5}}"
test lsetComp-3.8 {lset, compiled, flat args, error } {
evalInProc {
set x { {1 2} {3 4} }
lset x 1 5 5
}
} "1 {list index out of range}"
test lsetComp-3.9 {lset, compiled, flat args, error - is string preserved} {
set ::x { { 1 2 } { 3 4 } }
evalInProc {
lset ::x 1 5 5
}
list $::x [lindex $::x 1]
} "{ { 1 2 } { 3 4 } } { 3 4 }"
catch { rename evalInProc {} }
catch { unset ::x }
catch { unset ::y }
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/fileName.test 0000644 0036047 0045461 00000152527 12052456744 014515 0 ustar dgp 771div # This file tests the filename manipulation routines.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
tcltest::testConstraint testtranslatefilename [string equal testtranslatefilename [info commands testtranslatefilename]]
global env
if {[tcltest::testConstraint testsetplatform]} {
set platform [testgetplatform]
}
test filename-1.1 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype /
} absolute
test filename-1.2 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype /foo
} absolute
test filename-1.3 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype foo
} relative
test filename-1.4 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype c:/foo
} relative
test filename-1.5 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ~
} absolute
test filename-1.6 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ~/foo
} absolute
test filename-1.7 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ~foo
} absolute
test filename-1.8 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ./~foo
} relative
test filename-3.1 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype /
} volumerelative
test filename-3.2 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype \\
} volumerelative
test filename-3.3 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype /foo
} volumerelative
test filename-3.4 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype \\foo
} volumerelative
test filename-3.5 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:/
} absolute
test filename-3.6 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:\\
} absolute
test filename-3.7 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:/foo
} absolute
test filename-3.8 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:\\foo
} absolute
test filename-3.9 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:
} volumerelative
test filename-3.10 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:foo
} volumerelative
test filename-3.11 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype foo
} relative
test filename-3.12 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype //foo/bar
} absolute
test filename-3.13 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ~foo
} absolute
test filename-3.14 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ~
} absolute
test filename-3.15 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ~/foo
} absolute
test filename-3.16 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ./~foo
} relative
test filename-4.1 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split /
} {/}
test filename-4.2 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split /foo
} {/ foo}
test filename-4.3 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split /foo/bar
} {/ foo bar}
test filename-4.4 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split /foo/bar/baz
} {/ foo bar baz}
test filename-4.5 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo/bar
} {foo bar}
test filename-4.6 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ./foo/bar
} {. foo bar}
test filename-4.7 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split /foo/../././foo/bar
} {/ foo .. . . foo bar}
test filename-4.8 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../foo/bar
} {.. foo bar}
test filename-4.9 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split {}
} {}
test filename-4.10 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split .
} {.}
test filename-4.11 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../
} {..}
test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../..
} {.. ..}
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
} {/ foo}
test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo//bar
} {foo bar}
test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo
} {~foo}
test filename-4.16 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo/~bar
} {~foo ./~bar}
test filename-4.17 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo/~bar/~baz
} {~foo ./~bar ./~baz}
test filename-4.18 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo/bar~/baz
} {foo bar~ baz}
if {[tcltest::testConstraint testsetplatform]} {
testsetplatform $platform
}
test filename-4.19 {Tcl_SplitPath} {
set oldDir [pwd]
set res [catch {
cd [temporaryDirectory]
file mkdir tildetmp
set nastydir [file join tildetmp ./~tilde]
file mkdir $nastydir
set norm [file normalize $nastydir]
cd tildetmp
cd ./~tilde
glob -nocomplain *
set idx [string first tildetmp $norm]
set norm [string range $norm $idx end]
# fix path away so all platforms are the same
regsub {(.*):$} $norm {\1} norm
regsub -all ":" $norm "/" norm
# make sure we can delete the directory we created
cd $oldDir
file delete -force $nastydir
set norm
} err]
cd $oldDir
catch {file delete -force [file join [temporaryDirectory] tildetmp]}
list $res $err
} {0 tildetmp/~tilde}
test filename-6.1 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /
} {/}
test filename-6.2 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /foo
} {/ foo}
test filename-6.3 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /foo/bar
} {/ foo bar}
test filename-6.4 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /foo/bar/baz
} {/ foo bar baz}
test filename-6.5 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split foo/bar
} {foo bar}
test filename-6.6 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ./foo/bar
} {. foo bar}
test filename-6.7 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /foo/../././foo/bar
} {/ foo .. . . foo bar}
test filename-6.8 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ../foo/bar
} {.. foo bar}
test filename-6.9 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split {}
} {}
test filename-6.10 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split .
} {.}
test filename-6.11 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ../
} {..}
test filename-6.12 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ../..
} {.. ..}
test filename-6.13 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split //foo
} {/ foo}
test filename-6.14 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split foo//bar
} {foo bar}
test filename-6.15 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /\\/foo//bar
} {//foo/bar}
test filename-6.16 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /\\/foo//bar
} {//foo/bar}
test filename-6.17 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /\\/foo//bar
} {//foo/bar}
test filename-6.18 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split \\\\foo\\bar
} {//foo/bar}
test filename-6.19 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split \\\\foo\\bar/baz
} {//foo/bar baz}
test filename-6.20 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:/foo
} {c:/ foo}
test filename-6.21 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:foo
} {c: foo}
test filename-6.22 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:
} {c:}
test filename-6.23 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:\\
} {c:/}
test filename-6.24 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:/
} {c:/}
test filename-6.25 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:/./..
} {c:/ . ..}
test filename-6.26 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ~foo
} {~foo}
test filename-6.27 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ~foo/~bar
} {~foo ./~bar}
test filename-6.28 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ~foo/~bar/~baz
} {~foo ./~bar ./~baz}
test filename-6.29 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split foo/bar~/baz
} {foo bar~ baz}
test filename-6.30 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:~foo
} {c: ./~foo}
test filename-7.1 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join / a
} {/a}
test filename-7.2 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a b
} {a/b}
test filename-7.3 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /a c /b d
} {/b/d}
test filename-7.4 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /
} {/}
test filename-7.5 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a
} {a}
test filename-7.6 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join {}
} {}
test filename-7.7 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /a/ b
} {/a/b}
test filename-7.8 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /a// b
} {/a/b}
test filename-7.9 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /a/./../. b
} {/a/./.././b}
test filename-7.10 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ~ a
} {~/a}
test filename-7.11 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ~a ~b
} {~b}
test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ./~a b
} {./~a/b}
test filename-7.13 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ./~a ~b
} {~b}
test filename-7.14 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ./~a ./~b
} {./~a/~b}
test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . b
} {a/./b}
test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . ./~b
} {a/./~b}
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
} {/a/b}
test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /// a b
} {/a/b}
test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join a b
} {a/b}
test filename-9.2 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join /a b
} {/a/b}
test filename-9.3 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join /a /b
} {/b}
test filename-9.4 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join c: foo
} {c:foo}
test filename-9.5 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join c:/ foo
} {c:/foo}
test filename-9.6 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join c:\\bar foo
} {c:/bar/foo}
test filename-9.7 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join /foo c:bar
} {c:bar}
test filename-9.8 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ///host//share dir
} {//host/share/dir}
test filename-9.9 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ~ foo
} {~/foo}
test filename-9.10 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ~/~foo
} {~/~foo}
test filename-9.11 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ~ ./~foo
} {~/~foo}
test filename-9.12 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join / ~foo
} {~foo}
test filename-9.13 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ./a/ b c
} {./a/b/c}
test filename-9.14 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ./~a/ b c
} {./~a/b/c}
test filename-9.15 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join // host share path
} {/host/share/path}
test filename-9.16 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join foo . bar
} {foo/./bar}
test filename-9.17 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join foo .. bar
} {foo/../bar}
test filename-9.18 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join foo/./bar
} {foo/./bar}
test filename-9.19 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
set res {}
lappend res \
[file join {C:\foo\bar}] \
[file join C:/blah {C:\foo\bar}] \
[file join C:/blah C:/blah {C:\foo\bar}]
} {C:/foo/bar C:/foo/bar C:/foo/bar}
test filename-9.19.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
set res {}
lappend res \
[file join {foo\bar}] \
[file join C:/blah {foo\bar}] \
[file join C:/blah C:/blah {foo\bar}]
} {foo/bar C:/blah/foo/bar C:/blah/foo/bar}
test filename-9.19.2 {Tcl_JoinPath: win} {testsetplatform winOnly} {
testsetplatform win
set res {}
lappend res \
[file join {foo\bar}] \
[file join [pwd] {foo\bar}] \
[file join [pwd] [pwd] {foo\bar}]
string map [list [pwd] pwd] $res
} {foo/bar pwd/foo/bar pwd/foo/bar}
test filename-9.20 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
set res {}
lappend res \
[file join {/foo/bar}] \
[file join /x {/foo/bar}] \
[file join /x /x {/foo/bar}]
} {/foo/bar /foo/bar /foo/bar}
test filename-9.23 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
set res {}
lappend res \
[file join {foo\bar}] \
[file join C:/blah {foo\bar}] \
[file join C:/blah C:/blah {foo\bar}]
string map [list C:/blah ""] $res
} {foo/bar /foo/bar /foo/bar}
test filename-9.24 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
set res {}
lappend res \
[file join {foo/bar}] \
[file join /x {foo/bar}] \
[file join /x /x {foo/bar}]
string map [list /x ""] $res
} {foo/bar /foo/bar /foo/bar}
test filename-10.1 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform unix
list [catch {testtranslatefilename foo} msg] $msg
} {0 foo}
test filename-10.2 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform windows
list [catch {testtranslatefilename {c:/foo}} msg] $msg
} {0 {c:\foo}}
test filename-10.3 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform windows
list [catch {testtranslatefilename {c:/\\foo/}} msg] $msg
} {0 {c:\foo}}
test filename-10.6 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "/home/test"
testsetplatform unix
set result [list [catch {testtranslatefilename ~/foo} msg] $msg]
set env(HOME) $temp
set result
} {0 /home/test/foo}
test filename-10.7 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
unset env(HOME)
testsetplatform unix
set result [list [catch {testtranslatefilename ~/foo} msg] $msg]
set env(HOME) $temp
set result
} {1 {couldn't find HOME environment variable to expand path}}
test filename-10.8 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "/home/test"
testsetplatform unix
set result [list [catch {testtranslatefilename ~} msg] $msg]
set env(HOME) $temp
set result
} {0 /home/test}
test filename-10.9 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "/home/test/"
testsetplatform unix
set result [list [catch {testtranslatefilename ~} msg] $msg]
set env(HOME) $temp
set result
} {0 /home/test}
test filename-10.10 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "/home/test/"
testsetplatform unix
set result [list [catch {testtranslatefilename ~/foo} msg] $msg]
set env(HOME) $temp
set result
} {0 /home/test/foo}
test filename-10.17 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "\\home\\"
testsetplatform windows
set result [list [catch {testtranslatefilename ~/foo} msg] $msg]
set env(HOME) $temp
set result
} {0 {\home\foo}}
test filename-10.18 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "\\home\\"
testsetplatform windows
set result [list [catch {testtranslatefilename ~/foo\\bar} msg] $msg]
set env(HOME) $temp
set result
} {0 {\home\foo\bar}}
test filename-10.19 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "c:"
testsetplatform windows
set result [list [catch {testtranslatefilename ~/foo} msg] $msg]
set env(HOME) $temp
set result
} {0 c:foo}
test filename-10.20 {Tcl_TranslateFileName} {testtranslatefilename} {
list [catch {testtranslatefilename ~blorp/foo} msg] $msg
} {1 {user "blorp" doesn't exist}}
test filename-10.21 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "c:\\"
testsetplatform windows
set result [list [catch {testtranslatefilename ~/foo} msg] $msg]
set env(HOME) $temp
set result
} {0 {c:\foo}}
test filename-10.22 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform windows
list [catch {testtranslatefilename foo//bar} msg] $msg
} {0 {foo\bar}}
if {[tcltest::testConstraint testsetplatform]} {
testsetplatform $platform
}
test filename-10.23 {Tcl_TranslateFileName} {unixOnly nonPortable} {
# this test fails if ~ouster is not /home/ouster
list [catch {testtranslatefilename ~ouster} msg] $msg
} {0 /home/ouster}
test filename-10.24 {Tcl_TranslateFileName} {unixOnly nonPortable} {
# this test fails if ~ouster is not /home/ouster
list [catch {testtranslatefilename ~ouster/foo} msg] $msg
} {0 /home/ouster/foo}
test filename-11.1 {Tcl_GlobCmd} {
list [catch {glob} msg] $msg
} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}}
test filename-11.2 {Tcl_GlobCmd} {
list [catch {glob -gorp} msg] $msg
} {1 {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}}
test filename-11.3 {Tcl_GlobCmd} {
list [catch {glob -nocomplai} msg] $msg
} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}}
test filename-11.4 {Tcl_GlobCmd} {
list [catch {glob -nocomplain} msg] $msg
} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}}
test filename-11.5 {Tcl_GlobCmd} {
list [catch {glob -nocomplain ~xyqrszzz} msg] $msg
} {0 {}}
test filename-11.6 {Tcl_GlobCmd} {
list [catch {glob ~xyqrszzz} msg] $msg
} {1 {user "xyqrszzz" doesn't exist}}
test filename-11.7 {Tcl_GlobCmd} {
list [catch {glob -- -nocomplain} msg] $msg
} {1 {no files matched glob pattern "-nocomplain"}}
test filename-11.8 {Tcl_GlobCmd} {
list [catch {glob -nocomplain -- -nocomplain} msg] $msg
} {0 {}}
test filename-11.9 {Tcl_GlobCmd} {testsetplatform} {
testsetplatform unix
list [catch {glob ~\\xyqrszzz/bar} msg] $msg
} {1 {user "\xyqrszzz" doesn't exist}}
test filename-11.10 {Tcl_GlobCmd} {testsetplatform} {
testsetplatform unix
list [catch {glob -nocomplain ~\\xyqrszzz/bar} msg] $msg
} {0 {}}
test filename-11.11 {Tcl_GlobCmd} {testsetplatform} {
testsetplatform unix
list [catch {glob ~xyqrszzz\\/\\bar} msg] $msg
} {1 {user "xyqrszzz" doesn't exist}}
test filename-11.12 {Tcl_GlobCmd} {testsetplatform} {
testsetplatform unix
set home $env(HOME)
unset env(HOME)
set x [list [catch {glob ~/*} msg] $msg]
set env(HOME) $home
set x
} {1 {couldn't find HOME environment variable to expand path}}
if {[tcltest::testConstraint testsetplatform]} {
testsetplatform $platform
}
test filename-11.13 {Tcl_GlobCmd} {
list [catch {file join [lindex [glob ~] 0]} msg] $msg
} [list 0 [file join $env(HOME)]]
set oldpwd [pwd]
set oldhome $env(HOME)
cd [temporaryDirectory]
set env(HOME) [pwd]
file delete -force globTest
file mkdir globTest/a1/b1
file mkdir globTest/a1/b2
file mkdir globTest/a2/b3
file mkdir globTest/a3
close [open globTest/x1.c w]
close [open globTest/y1.c w]
close [open globTest/z1.c w]
close [open "globTest/weird name.c" w]
close [open globTest/a1/b1/x2.c w]
close [open globTest/a1/b2/y2.c w]
catch {close [open globTest/.1 w]}
catch {close [open globTest/x,z1.c w]}
test filename-11.14 {Tcl_GlobCmd} {
list [catch {glob ~/globTest} msg] $msg
} [list 0 [list [file join $env(HOME) globTest]]]
test filename-11.15 {Tcl_GlobCmd} {
list [catch {glob ~\\/globTest} msg] $msg
} [list 0 [list [file join $env(HOME) globTest]]]
test filename-11.16 {Tcl_GlobCmd} {
list [catch {glob globTest} msg] $msg
} {0 globTest}
set globname "globTest"
set horribleglobname "glob\[\{Test"
test filename-11.17 {Tcl_GlobCmd} {unixOnly} {
list [catch {lsort [glob -directory $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-11.17.1 {Tcl_GlobCmd} {pcOnly} {
list [catch {lsort [glob -directory $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
if {[string equal $tcl_platform(platform) "windows"]} {
if {[string index $tcl_platform(osVersion) 0] >= 5 \
&& ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
tcltest::testConstraint linkDirectory 1
} else {
tcltest::testConstraint linkDirectory 0
}
} else {
tcltest::testConstraint linkDirectory 1
}
if {[string equal $tcl_platform(platform) "windows"]} {
tcltest::testConstraint symbolicLinkFile 0
} else {
tcltest::testConstraint symbolicLinkFile 1
}
test filename-11.17.2 {Tcl_GlobCmd} {notRoot linkDirectory} {
set dir [pwd]
set ret "error in test"
if {[catch {
cd $globname
file link -symbolic link a1
cd $dir
set ret [list [catch {
lsort [glob -directory $globname -join * b1]
} msg] $msg]
}]} {
cd $dir
}
file delete [file join $globname link]
set ret
} [list 0 [lsort [list [file join $globname a1 b1] \
[file join $globname link b1]]]]
# Simpler version of the above test to illustrate a given bug.
test filename-11.17.3 {Tcl_GlobCmd} {notRoot linkDirectory} {
set dir [pwd]
set ret "error in test"
if {[catch {
cd $globname
file link -symbolic link a1
cd $dir
set ret [list [catch {
lsort [glob -directory $globname -type d *]
} msg] $msg]
}]} {
cd $dir
}
file delete [file join $globname link]
set ret
} [list 0 [lsort [list [file join $globname a1] \
[file join $globname a2] \
[file join $globname a3] \
[file join $globname link]]]]
# Make sure the bugfix isn't too simple. We don't want
# to break 'glob -type l'.
test filename-11.17.4 {Tcl_GlobCmd} {notRoot linkDirectory} {
set dir [pwd]
set ret "error in test"
if {[catch {
cd $globname
file link -symbolic link a1
cd $dir
set ret [list [catch {
lsort [glob -directory $globname -type l *]
} msg] $msg]
}]} {
cd $dir
}
file delete [file join $globname link]
set ret
} [list 0 [list [file join $globname link]]]
test filename-11.17.5 {Tcl_GlobCmd} {
list [catch {lsort [glob -directory $globname -tails *.c]} msg] $msg
} [list 0 [lsort [list "weird name.c" x,z1.c x1.c y1.c z1.c]]]
test filename-11.17.6 {Tcl_GlobCmd} {
list [catch {lsort [glob -directory $globname -tails *.c *.c]} msg] $msg
} [list 0 [lsort [concat [list "weird name.c" x,z1.c x1.c y1.c z1.c] \
[list "weird name.c" x,z1.c x1.c y1.c z1.c]]]]
test filename-11.17.7 {Tcl_GlobCmd: broken link and glob -l} {linkDirectory} {
set dir [pwd]
set ret "error in test"
if {[catch {
cd $globname
file mkdir nonexistent
file link -symbolic link nonexistent
file delete nonexistent
cd $dir
set ret [list [catch {
lsort [glob -nocomplain -directory $globname -type l *]
} msg] $msg]
}]} {
cd $dir
}
file delete [file join $globname link]
set ret
} [list 0 [list [file join $globname link]]]
test filename-11.17.8 {Tcl_GlobCmd: broken link and glob -l} {symbolicLinkFile} {
set dir [pwd]
set ret "error in test"
if {[catch {
cd $globname
close [open "nonexistent" w]
file link -symbolic link nonexistent
file delete nonexistent
cd $dir
set ret [list [catch {
lsort [glob -nocomplain -directory $globname -type l *]
} msg] $msg]
}]} {
cd $dir
}
file delete [file join $globname link]
set ret
} [list 0 [list [file join $globname link]]]
test filename-11.18 {Tcl_GlobCmd} {unixOnly} {
list [catch {lsort [glob -path $globname/ *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-11.18.1 {Tcl_GlobCmd} {pcOnly} {
list [catch {lsort [glob -path $globname/ *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-11.19 {Tcl_GlobCmd} {unixOnly} {
list [catch {lsort [glob -join -path \
[string range $globname 0 5] * *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-11.19.1 {Tcl_GlobCmd} {pcOnly} {
list [catch {lsort [glob -join -path \
[string range $globname 0 5] * *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-11.20 {Tcl_GlobCmd} {
list [catch {lsort [glob -type d -dir $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]]
test filename-11.21 {Tcl_GlobCmd} {
list [catch {lsort [glob -type d -path $globname *]} msg] $msg
} [list 0 [lsort [list $globname]]]
test filename-11.21.1 {Tcl_GlobCmd} {
close [open {[tcl].testremains} w]
set res [list [catch {lsort [glob -path {[tcl]} *]} msg] $msg]
file delete -force {[tcl].testremains}
set res
} [list 0 {{[tcl].testremains}}]
# Get rid of file/dir if it exists, since it will have
# been left behind by a previous failed run.
if {[file exists $horribleglobname]} {
file delete -force $horribleglobname
}
file rename globTest $horribleglobname
set globname $horribleglobname
test filename-11.22 {Tcl_GlobCmd} {unixOnly} {
list [catch {lsort [glob -dir $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-11.22.1 {Tcl_GlobCmd} {pcOnly} {
list [catch {lsort [glob -dir $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-11.23 {Tcl_GlobCmd} {unixOnly} {
list [catch {lsort [glob -path $globname/ *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-11.23.1 {Tcl_GlobCmd} {pcOnly} {
list [catch {lsort [glob -path $globname/ *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-11.24 {Tcl_GlobCmd} {unixOnly} {
list [catch {lsort [glob -join -path \
[string range $globname 0 5] * *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-11.24.1 {Tcl_GlobCmd} {pcOnly} {
list [catch {lsort [glob -join -path \
[string range $globname 0 5] * *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-11.25 {Tcl_GlobCmd} {
list [catch {lsort [glob -type d -dir $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]]
test filename-11.25.1 {Tcl_GlobCmd} {
list [catch {lsort [glob -type {d r} -dir $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]]
test filename-11.25.2 {Tcl_GlobCmd} {
list [catch {lsort [glob -type {d r w} -dir $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]]
test filename-11.26 {Tcl_GlobCmd} {
list [catch {glob -type d -path $globname *} msg] $msg
} [list 0 [list $globname]]
test filename-11.27 {Tcl_GlobCmd} {
list [catch {glob -types abcde *} msg] $msg
} {1 {bad argument to "-types": abcde}}
test filename-11.28 {Tcl_GlobCmd} {
list [catch {glob -types z *} msg] $msg
} {1 {bad argument to "-types": z}}
test filename-11.29 {Tcl_GlobCmd} {
list [catch {glob -types {abcd efgh} *} msg] $msg
} {1 {only one MacOS type or creator argument to "-types" allowed}}
test filename-11.30 {Tcl_GlobCmd} {
list [catch {glob -types {{macintosh type TEXT} \
{macintosh creator ALFA} efgh} *} msg] $msg
} {1 {only one MacOS type or creator argument to "-types" allowed}}
test filename-11.31 {Tcl_GlobCmd} {
list [catch {glob -types} msg] $msg
} {1 {missing argument to "-types"}}
test filename-11.32 {Tcl_GlobCmd} {
list [catch {glob -path hello -dir hello *} msg] $msg
} {1 {"-directory" cannot be used with "-path"}}
test filename-11.33 {Tcl_GlobCmd} {
list [catch {glob -path} msg] $msg
} {1 {missing argument to "-path"}}
test filename-11.34 {Tcl_GlobCmd} {
list [catch {glob -direct} msg] $msg
} {1 {missing argument to "-directory"}}
test filename-11.35 {Tcl_GlobCmd} {
list [catch {glob -paths *} msg] $msg
} {1 {bad option "-paths": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}}
# Test '-tails' flag to glob.
test filename-11.36 {Tcl_GlobCmd} {
list [catch {glob -tails *} msg] $msg
} {1 {"-tails" must be used with either "-directory" or "-path"}}
test filename-11.37 {Tcl_GlobCmd} {
list [catch {glob -type d -tails -path $globname *} msg] $msg
} [list 0 [list $globname]]
test filename-11.38 {Tcl_GlobCmd} {
list [catch {glob -tails -path $globname *} msg] $msg
} [list 0 [list $globname]]
test filename-11.39 {Tcl_GlobCmd} {
list [catch {glob -tails -join -path $globname *} msg] $msg
} [list 0 [list $globname]]
test filename-11.40 {Tcl_GlobCmd} {
expr {[glob -dir [pwd] -tails *] == [glob *]}
} {1}
test filename-11.41 {Tcl_GlobCmd} {
expr {[glob -dir [pwd] -tails *] != [glob -dir [pwd] *]}
} {1}
test filename-11.42 {Tcl_GlobCmd} {
set res [list]
foreach f [glob -dir [pwd] *] {
lappend res [file tail $f]
}
expr {$res == [glob *]}
} {1}
test filename-11.43 {Tcl_GlobCmd} {
list [catch {glob -t *} msg] $msg
} {1 {ambiguous option "-t": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}}
test filename-11.44 {Tcl_GlobCmd} {
list [catch {glob -tails -path hello -directory hello *} msg] $msg
} {1 {"-directory" cannot be used with "-path"}}
test filename-11.45 {Tcl_GlobCmd on root volume} {
set res1 ""
set res2 ""
catch {
set res1 [glob -dir [lindex [file volumes] 0] -tails *]
}
catch {
set tmpd [pwd]
cd [lindex [file volumes] 0]
set res2 [glob *]
cd $tmpd
}
expr {$res1 == $res2}
} {1}
test filename-11.46 {Tcl_GlobCmd} {
list [catch {glob -types abcde -dir foo *} msg] $msg
} {1 {bad argument to "-types": abcde}}
test filename-11.47 {Tcl_GlobCmd} {
list [catch {glob -types abcde -path foo *} msg] $msg
} {1 {bad argument to "-types": abcde}}
test filename-11.48 {Tcl_GlobCmd} {
list [catch {glob -types abcde -dir foo -join * *} msg] $msg
} {1 {bad argument to "-types": abcde}}
test filename-11.49 {Tcl_GlobCmd} {
list [catch {glob -types abcde -path foo -join * *} msg] $msg
} {1 {bad argument to "-types": abcde}}
file rename $horribleglobname globTest
set globname globTest
unset horribleglobname
test filename-12.1 {simple globbing} {unixOrPc} {
list [catch {glob {}} msg] $msg
} {0 .}
test filename-12.1.1 {simple globbing} {unixOrPc} {
list [catch {glob -types f {}} msg] $msg
} {1 {no files matched glob pattern ""}}
test filename-12.1.2 {simple globbing} {unixOrPc} {
list [catch {glob -types d {}} msg] $msg
} {0 .}
test filename-12.1.3 {simple globbing} {unixOnly} {
list [catch {glob -types hidden {}} msg] $msg
} {0 .}
test filename-12.1.4 {simple globbing} {pcOnly} {
list [catch {glob -types hidden {}} msg] $msg
} {1 {no files matched glob pattern ""}}
test filename-12.1.5 {simple globbing} {pcOnly} {
list [catch {glob -types hidden c:/} msg] $msg
} {1 {no files matched glob pattern "c:/"}}
test filename-12.1.6 {simple globbing} {pcOnly} {
list [catch {glob c:/} msg] $msg
} {0 c:/}
test filename-12.3 {simple globbing} {
list [catch {glob -nocomplain \{a1,a2\}} msg] $msg
} {0 {}}
set globPreResult globTest/
set x1 x1.c
set y1 y1.c
test filename-12.4 {simple globbing} {unixOrPc} {
lsort [glob globTest/x1.c globTest/y1.c globTest/foo]
} "$globPreResult$x1 $globPreResult$y1"
test filename-12.5 {simple globbing} {
list [catch {glob globTest\\/x1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-12.6 {simple globbing} {
list [catch {glob globTest\\/\\x1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-12.7 {globbing at filesystem root} {unixOnly} {
set res1 [glob -nocomplain /*]
set res2 [glob -path / *]
set equal [string equal $res1 $res2]
if {!$equal} {
lappend equal "not equal" $res1 $res2
}
set equal
} {1}
test filename-12.8 {globbing at filesystem root} {unixOnly} {
set dir [lindex [glob -type d /*] 0]
set first [string range $dir 0 1]
set res1 [glob -nocomplain ${first}*]
set res2 [glob -path $first *]
set equal [string equal $res1 $res2]
if {!$equal} {
lappend equal "not equal" $res1 $res2
}
set equal
} {1}
test filename-12.9 {globbing at filesystem root} {winOnly} {
# Can't grab just anything from 'file volumes' because we need a dir
# that has subdirs - assume that C:/ exists across Windows machines.
set dir [lindex [glob -type d C:/*] 0]
set first [string range $dir 0 3]
set res1 [glob -nocomplain ${first}*]
set res2 [glob -path $first *]
set equal [string equal $res1 $res2]
if {!$equal} {
lappend equal "not equal" $res1 $res2
}
set equal
} {1}
test filename-13.1 {globbing with brace substitution} {
list [catch {glob globTest/\{\}} msg] $msg
} "0 $globPreResult"
test filename-13.2 {globbing with brace substitution} {
list [catch {glob globTest/\{} msg] $msg
} {1 {unmatched open-brace in file name}}
test filename-13.3 {globbing with brace substitution} {
list [catch {glob globTest/\{\\\}} msg] $msg
} {1 {unmatched open-brace in file name}}
test filename-13.4 {globbing with brace substitution} {
list [catch {glob globTest/\{\\} msg] $msg
} {1 {unmatched open-brace in file name}}
test filename-13.5 {globbing with brace substitution} {
list [catch {glob globTest/\}} msg] $msg
} {1 {unmatched close-brace in file name}}
test filename-13.6 {globbing with brace substitution} {
list [catch {glob globTest/\{\}x1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.7 {globbing with brace substitution} {
list [catch {glob globTest/\{x\}1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.8 {globbing with brace substitution} {
list [catch {glob globTest/\{x\{\}\}1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.9 {globbing with brace substitution} {
list [lsort [catch {glob globTest/\{x,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
test filename-13.10 {globbing with brace substitution} {
list [lsort [catch {glob globTest/\{x,,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
test filename-13.11 {globbing with brace substitution} {unixOrPc} {
list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg
} {0 {globTest/x1.c globTest/x,z1.c globTest/z1.c}}
test filename-13.13 {globbing with brace substitution} {
lsort [glob globTest/{a,b,x,y}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
test filename-13.14 {globbing with brace substitution} {unixOrPc} {
lsort [glob {globTest/{x1,y2,weird name}.c}]
} {{globTest/weird name.c} globTest/x1.c}
test filename-13.16 {globbing with brace substitution} {unixOrPc} {
lsort [glob globTest/{x1.c,a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
test filename-13.18 {globbing with brace substitution} {unixOrPc} {
lsort [glob globTest/{x1.c,{a},a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
test filename-13.20 {globbing with brace substitution} {unixOrPc} {
lsort [glob globTest/{a,x}1/*/{x,y}*]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-13.22 {globbing with brace substitution} {
list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg
} {1 {unmatched open-brace in file name}}
test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob glo*/*.c]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
# The current directory could be anywhere; do this to stop spurious matches
file mkdir globTestContext
file rename globTest [file join globTestContext globTest]
set savepwd [pwd]
cd globTestContext
test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob */*/*/*.c]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
# Reset to where we were
cd $savepwd
file rename [file join globTestContext globTest] globTest
file delete globTestContext
test filename-14.7 {asterisks, question marks, and brackets} {unixOnly} {
lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.7.1 {asterisks, question marks, and brackets} {pcOnly} {
lsort [glob globTest/*]
} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/.*]
} {globTest/. globTest/.. globTest/.1}
test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/*/*]
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
test filename-14.13 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob {globTest/[xyab]1.*}]
} {globTest/x1.c globTest/y1.c}
test filename-14.15 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/*/]
} {globTest/a1/ globTest/a2/ globTest/a3/}
test filename-14.17 {asterisks, question marks, and brackets} {
global env
set temp $env(HOME)
set env(HOME) [file join $env(HOME) globTest]
set result [list [catch {glob ~/z*} msg] $msg]
set env(HOME) $temp
set result
} [list 0 [list [file join $env(HOME) globTest z1.c]]]
test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc} {
list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}}
test filename-14.20 {asterisks, question marks, and brackets} {
list [catch {glob -nocomplain goo/*} msg] $msg
} {0 {}}
test filename-14.21 {asterisks, question marks, and brackets} {
list [catch {glob globTest/*/gorp} msg] $msg
} {1 {no files matched glob pattern "globTest/*/gorp"}}
test filename-14.22 {asterisks, question marks, and brackets} {
list [catch {glob goo/* x*z foo?q} msg] $msg
} {1 {no files matched glob patterns "goo/* x*z foo?q"}}
test filename-14.23 {slash globbing} {unixOrPc} {
glob /
} /
test filename-14.24 {slash globbing} {pcOnly} {
glob {\\}
} /
test filename-14.25 {type specific globbing} {unixOnly} {
list [catch {lsort [glob -dir globTest -types f *]} msg] $msg
} [list 0 [lsort [list \
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
test filename-14.26 {type specific globbing} {
list [catch {glob -nocomplain -dir globTest -types {readonly} *} msg] $msg
} [list 0 {}]
test filename-14.27 {Bug 2710920} {unixOrPc} {
file tail [lindex [lsort [glob globTest/*/]] 0]
} a1
test filename-14.28 {Bug 2710920} {unixOrPc} {
file dirname [lindex [lsort [glob globTest/*/]] 0]
} globTest
test filename-14.29 {Bug 2710920} {unixOrPc} {
file extension [lindex [lsort [glob globTest/*/]] 0]
} {}
test filename-14.30 {Bug 2710920} {unixOrPc} {
file rootname [lindex [lsort [glob globTest/*/]] 0]
} globTest/a1/
test filename-14.31 {Bug 2918610} -setup {
set d [makeDirectory foo]
makeFile {} bar.soom $d
} -body {
foreach fn [glob $d/bar.soom] {
set root [file rootname $fn]
close [open $root {WRONLY CREAT}]
}
llength [glob -directory $d *]
} -cleanup {
file delete -force $d/bar
removeFile bar.soom $d
removeDirectory foo
} -result 2
unset globname
# The following tests are only valid for Unix systems.
# On some systems, like AFS, "000" protection doesn't prevent
# access by owner, so the following test is not portable.
catch {file attributes globTest/a1 -permissions 0000}
test filename-15.1 {unix specific globbing} {unixOnly nonPortable} {
string tolower [list [catch {glob globTest/a1/*} msg] $msg $errorCode]
} {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
test filename-15.2 {unix specific no complain: no errors} {unixOnly nonPortable} {
glob -nocomplain globTest/a1/*
} {}
test filename-15.3 {unix specific no complain: no errors, good result} \
{unixOnly nonPortable} {
# test fails because if an error occur , the interp's result
# is reset...
glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
} {globTest/a2 globTest/a3}
catch {file attributes globTest/a1 -permissions 0755}
test filename-15.4 {unix specific no complain: no errors, good result} \
{unixOnly nonPortable} {
# test fails because if an error occurs, the interp's result
# is reset... or you don't run at scriptics where the
# outser and welch users exists
glob -nocomplain ~ouster ~foo ~welch
} {/home/ouster /home/welch}
test filename-15.4.1 {no complain: no errors, good result} {
# test used to fail because if an error occurs, the interp's result
# is reset...
string equal [glob -nocomplain ~wontexist ~blah ~] \
[glob -nocomplain ~ ~blah ~wontexist]
} {1}
test filename-15.5 {unix specific globbing} {unixOnly nonPortable} {
glob ~ouster/.csh*
} "/home/ouster/.cshrc"
catch {close [open globTest/odd\\\[\]*?\{\}name w]}
test filename-15.6 {unix specific globbing} {unixOnly} {
global env
set temp $env(HOME)
set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name
set result [list [catch {glob ~} msg] $msg]
set env(HOME) $temp
set result
} [list 0 [list [lindex [glob ~] 0]/globTest/odd\\\[\]*?\{\}name]]
catch {file delete -force globTest/odd\\\[\]*?\{\}name}
# The following tests are only valid for Windows systems.
set oldDir [pwd]
if {$::tcltest::testConstraints(pcOnly)} {
cd c:/
file delete -force globTest
file mkdir globTest
close [open globTest/x1.BAT w]
close [open globTest/y1.Bat w]
close [open globTest/z1.bat w]
}
test filename-16.1 {windows specific globbing} {pcOnly} {
lsort [glob globTest/*.bat]
} {globTest/x1.BAT globTest/y1.Bat globTest/z1.bat}
test filename-16.2 {windows specific globbing} {pcOnly} {
glob c:
} c:
test filename-16.3 {windows specific globbing} {pcOnly} {
glob c:\\\\
} c:/
test filename-16.4 {windows specific globbing} {pcOnly} {
glob c:/
} c:/
test filename-16.5 {windows specific globbing} {pcOnly} {
glob c:*bTest
} c:globTest
test filename-16.6 {windows specific globbing} {pcOnly} {
glob c:\\\\*bTest
} c:/globTest
test filename-16.7 {windows specific globbing} {pcOnly} {
glob c:/*bTest
} c:/globTest
test filename-16.8 {windows specific globbing} {pcOnly} {
lsort [glob c:globTest/*.bat]
} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
test filename-16.9 {windows specific globbing} {pcOnly} {
lsort [glob c:/globTest/*.bat]
} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
test filename-16.10 {windows specific globbing} {pcOnly} {
lsort [glob c:globTest\\\\*.bat]
} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
test filename-16.11 {windows specific globbing} {pcOnly} {
lsort [glob c:\\\\globTest\\\\*.bat]
} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
# some tests require a shared C drive
if {[catch {cd //[info hostname]/c}]} {
set ::tcltest::testConstraints(sharedCdrive) 0
} else {
set ::tcltest::testConstraints(sharedCdrive) 1
}
test filename-16.12 {windows specific globbing} {pcOnly sharedCdrive} {
cd //[info hostname]/c
glob //[info hostname]/c/*Test
} //[info hostname]/c/globTest
test filename-16.13 {windows specific globbing} {pcOnly sharedCdrive} {
cd //[info hostname]/c
glob "\\\\\\\\[info hostname]\\\\c\\\\*Test"
} //[info hostname]/c/globTest
test filename-16.14 {windows specific globbing} {pcOnly} {
cd [lindex [glob -types d -dir C:/ *] 0]
expr {[lsearch -exact [glob {{.,*}*}] ".."] != -1}
} {1}
test filename-16.15 {windows specific globbing} {pcOnly} {
cd [lindex [glob -types d -dir C:/ *] 0]
glob ..
} {..}
test filename-16.16 {windows specific globbing} {pcOnly} {
file tail [lindex [glob "[lindex [glob -types d -dir C:/ *] 0]/.."] 0]
} {..}
test filename-17.1 {windows specific special files} {testsetplatform} {
testsetplatform win
list [file pathtype com1] [file pathtype con] [file pathtype lpt3] \
[file pathtype prn] [file pathtype nul] [file pathtype aux] \
[file pathtype foo]
} {absolute absolute absolute absolute absolute absolute relative}
test filename-17.2 {windows specific glob with executable} {winOnly} {
makeDirectory execglob
makeFile contents execglob/abc.exe
makeFile contents execglob/abc.notexecutable
set res [glob -nocomplain -dir [temporaryDirectory]/execglob \
-tails -types x *]
removeFile execglob/abc.exe
removeFile execglob/abc.notexecutable
removeDirectory execglob
set res
} {abc.exe}
test filename-17.3 {Bug 2571597} win {
set p /a
file pathtype $p
file normalize $p
file pathtype $p
} volumerelative
test fileName-18.1 {windows - split ADS name correctly} {winOnly} {
# bug 1194458
set x [file split c:/c:d]
set y [eval [linsert $x 0 file join]]
list $x $y
} {{c:/ ./c:d} c:/c:d}
test fileName-20.1 {Bug 1750300} -setup {
set d [makeDirectory foo]
makeFile {} TAGS $d
} -body {
llength [glob -nocomplain -directory $d -- TAGS one two]
} -cleanup {
removeFile TAGS $d
removeDirectory foo
} -result 1
test fileName-20.2 {Bug 1750300} -setup {
set d [makeDirectory foo]
makeFile {} TAGS $d
} -body {
llength [glob -nocomplain -directory $d -types {} -- TAGS one two]
} -cleanup {
removeFile TAGS $d
removeDirectory foo
} -result 1
test fileName-20.3 {Bug 1750300} -setup {
set d [makeDirectory foo]
makeFile {} TAGS $d
} -body {
llength [glob -nocomplain -directory $d -types {} -- *U*]
} -cleanup {
removeFile TAGS $d
removeDirectory foo
} -result 0
test fileName-20.4 {Bug 1750300} -setup {
set d [makeDirectory foo]
makeFile {} TAGS $d
} -body {
llength [glob -nocomplain -directory $d -types {} -- URGENT Urkle]
} -cleanup {
removeFile TAGS $d
removeDirectory foo
} -result 0
test fileName-20.5 {Bug 2837800} -setup {
set dd [makeDirectory isolate]
set d [makeDirectory ./~foo $dd]
makeFile {} test $d
set savewd [pwd]
cd $dd
} -body {
glob -nocomplain */test
} -cleanup {
cd $savewd
removeFile test $d
removeDirectory ./~foo $dd
removeDirectory isolate
} -result ~foo/test
test fileName-20.6 {Bug 2837800} -setup {
# Recall that we have $env(HOME) set so that references
# to ~ point to [temporaryDirectory]
makeFile {} test ~
set dd [makeDirectory isolate]
set d [makeDirectory ./~ $dd]
set savewd [pwd]
cd $dd
} -body {
glob -nocomplain */test
} -cleanup {
cd $savewd
removeDirectory ./~ $dd
removeDirectory isolate
removeFile test ~
} -result {}
test fileName-20.7 {Bug 2806250} -setup {
set d [makeDirectory isolate]
makeFile {} ./~test $d
} -body {
file exists [lindex [glob -nocomplain isolate/*] 0]
} -cleanup {
removeFile ./~test $d
removeDirectory isolate
} -result 1
test fileName-20.8 {Bug 2806250} -setup {
set d [makeDirectory isolate]
makeFile {} ./~test $d
} -body {
file tail [lindex [glob -nocomplain isolate/*] 0]
} -cleanup {
removeFile ./~test $d
removeDirectory isolate
} -result ./~test
test fileName-20.9 {} -setup {
makeFile {} test ~
set d [makeDirectory isolate]
set savewd [pwd]
cd $d
} -body {
glob -nocomplain -directory ~ test
} -cleanup {
cd $savewd
removeDirectory isolate
removeFile test ~
} -result [file normalize ~/test]
# The normalized result here is arguably buggy, but consistent
# with (some?) 8.4.* releases.
test fileName-20.10 {} -setup {
set s [makeDirectory sub ~]
makeFile {} fileName-20.10 $s
set d [makeDirectory isolate]
set savewd [pwd]
cd $d
} -body {
glob -nocomplain -directory ~ -join * fileName-20.10
} -cleanup {
cd $savewd
removeDirectory isolate
removeFile fileName-20.10 $s
removeDirectory sub ~
} -result [file normalize ~/sub/fileName-20.10]
# The normalized result here is arguably buggy, but consistent
# with (some?) 8.4.* releases.
# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
set env(HOME) $oldhome
if {[tcltest::testConstraint testsetplatform]} {
testsetplatform $platform
catch {unset platform}
}
catch {unset oldhome temp result globPreResult}
::tcltest::cleanupTests
return
tcl8.4.20/tests/lindex.test 0000644 0036047 0045461 00000027504 11737050674 014255 0 ustar dgp 771div # Commands covered: lindex
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
set lindex lindex
set minus -
# Tests of Tcl_LindexObjCmd, NOT COMPILED
test lindex-1.1 {wrong # args} {
list [catch {eval $lindex} result] $result
} "1 {wrong # args: should be \"lindex list ?index...?\"}"
# Indices that are lists or convertible to lists
test lindex-2.1 {empty index list} {
set x {}
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {{a b c} {a b c}}
test lindex-2.2 {singleton index list} {
set x { 1 }
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {b b}
test lindex-2.3 {multiple indices in list} {
set x {1 2}
list [eval [list $lindex {{a b c} {d e f}} $x]] \
[eval [list $lindex {{a b c} {d e f}} $x]]
} {f f}
test lindex-2.4 {malformed index list} {
set x \{
list [catch { eval [list $lindex {a b c} $x] } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer\ or\ end?-integer?}
# Indices that are integers or convertible to integers
test lindex-3.1 {integer -1} {
set x ${minus}1
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {{} {}}
test lindex-3.2 {integer 0} {
set x [string range 00 0 0]
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {a a}
test lindex-3.3 {integer 2} {
set x [string range 22 0 0]
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {c c}
test lindex-3.4 {integer 3} {
set x [string range 33 0 0]
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {{} {}}
test lindex-3.5 {bad octal} {
set x 08
list [catch { eval [list $lindex {a b c} $x] } result] $result
} "1 {bad index \"08\": must be integer or end?-integer? (looks like invalid octal number)}"
test lindex-3.6 {bad octal} {
set x -09
list [catch { eval [list $lindex {a b c} $x] } result] $result
} "1 {bad index \"-09\": must be integer or end?-integer? (looks like invalid octal number)}"
test lindex-3.7 {indexes don't shimmer wide ints} {
set x [expr {(wide(1)<<31) - 2}]
list $x [lindex {1 2 3} $x] [incr x] [incr x]
} {2147483646 {} 2147483647 2147483648}
# Indices relative to end
test lindex-4.1 {index = end} {
set x end
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {c c}
test lindex-4.2 {index = end--1} {
set x end--1
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {{} {}}
test lindex-4.3 {index = end-0} {
set x end-0
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {c c}
test lindex-4.4 {index = end-2} {
set x end-2
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {a a}
test lindex-4.5 {index = end-3} {
set x end-3
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {{} {}}
test lindex-4.6 {bad octal} {
set x end-08
list [catch { eval [list $lindex {a b c} $x] } result] $result
} "1 {bad index \"end-08\": must be integer or end?-integer? (looks like invalid octal number)}"
test lindex-4.7 {bad octal} {
set x end--09
list [catch { eval [list $lindex {a b c} $x] } result] $result
} "1 {bad index \"end--09\": must be integer or end?-integer?}"
test lindex-4.8 {bad integer, not octal} {
set x end-0a2
list [catch { eval [list $lindex {a b c} $x] } result] $result
} "1 {bad index \"end-0a2\": must be integer or end?-integer?}"
test lindex-4.9 {incomplete end} {
set x en
list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {c c}
test lindex-4.10 {incomplete end-} {
set x end-
list [catch { eval [list $lindex {a b c} $x] } result] $result
} "1 {bad index \"end-\": must be integer or end?-integer?}"
test lindex-5.1 {bad second index} {
list [catch { eval [list $lindex {a b c} 0 0a2] } result] $result
} "1 {bad index \"0a2\": must be integer or end?-integer?}"
test lindex-5.2 {good second index} {
eval [list $lindex {{a b c} {d e f} {g h i}} 1 2]
} f
test lindex-5.3 {three indices} {
eval [list $lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1]
} f
test lindex-6.1 {error conditions in parsing list} {
list [catch {eval [list $lindex "a \{" 2]} msg] $msg
} {1 {unmatched open brace in list}}
test lindex-6.2 {error conditions in parsing list} {
list [catch {eval [list $lindex {a {b c}d e} 2]} msg] $msg
} {1 {list element in braces followed by "d" instead of space}}
test lindex-6.3 {error conditions in parsing list} {
list [catch {eval [list $lindex {a "b c"def ghi} 2]} msg] $msg
} {1 {list element in quotes followed by "def" instead of space}}
test lindex-7.1 {quoted elements} {
eval [list $lindex {a "b c" d} 1]
} {b c}
test lindex-7.2 {quoted elements} {
eval [list $lindex {"{}" b c} 0]
} {{}}
test lindex-7.3 {quoted elements} {
eval [list $lindex {ab "c d \" x" y} 1]
} {c d " x}
test lindex-7.4 {quoted elements} {
lindex {a b {c d "e} {f g"}} 2
} {c d "e}
test lindex-8.1 {data reuse} {
set x 0
eval [list $lindex $x $x]
} {0}
test lindex-8.2 {data reuse} {
set a 0
eval [list $lindex $a $a $a]
} 0
test lindex-8.3 {data reuse} {
set a 1
eval [list $lindex $a $a $a]
} {}
test lindex-8.4 {data reuse} {
set x [list 0 0]
eval [list $lindex $x $x]
} {0}
test lindex-8.5 {data reuse} {
set x 0
eval [list $lindex $x [list $x $x]]
} {0}
test lindex-8.6 {data reuse} {
set x [list 1 1]
eval [list $lindex $x $x]
} {}
test lindex-8.7 {data reuse} {
set x 1
eval [list lindex $x [list $x $x]]
} {}
#----------------------------------------------------------------------
# Compilation tests for lindex
test lindex-9.1 {wrong # args} {
list [catch {lindex} result] $result
} "1 {wrong # args: should be \"lindex list ?index...?\"}"
# Indices that are lists or convertible to lists
test lindex-10.1 {empty index list} {
set x {}
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {{a b c} {a b c}}
test lindex-10.2 {singleton index list} {
set x { 1 }
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {b b}
test lindex-10.3 {multiple indices in list} {
set x {1 2}
catch {
list [lindex {{a b c} {d e f}} $x] [lindex {{a b c} {d e f}} $x]
} result
set result
} {f f}
test lindex-10.4 {malformed index list} {
set x \{
list [catch { lindex {a b c} $x } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer\ or\ end?-integer?}
# Indices that are integers or convertible to integers
test lindex-11.1 {integer -1} {
set x ${minus}1
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {{} {}}
test lindex-11.2 {integer 0} {
set x [string range 00 0 0]
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {a a}
test lindex-11.3 {integer 2} {
set x [string range 22 0 0]
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {c c}
test lindex-11.4 {integer 3} {
set x [string range 33 0 0]
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {{} {}}
test lindex-11.5 {bad octal} {
set x 08
list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"08\": must be integer or end?-integer? (looks like invalid octal number)}"
test lindex-11.6 {bad octal} {
set x -09
list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"-09\": must be integer or end?-integer? (looks like invalid octal number)}"
# Indices relative to end
test lindex-12.1 {index = end} {
set x end
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {c c}
test lindex-12.2 {index = end--1} {
set x end--1
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {{} {}}
test lindex-12.3 {index = end-0} {
set x end-0
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {c c}
test lindex-12.4 {index = end-2} {
set x end-2
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {a a}
test lindex-12.5 {index = end-3} {
set x end-3
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {{} {}}
test lindex-12.6 {bad octal} {
set x end-08
list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"end-08\": must be integer or end?-integer? (looks like invalid octal number)}"
test lindex-12.7 {bad octal} {
set x end--09
list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"end--09\": must be integer or end?-integer?}"
test lindex-12.8 {bad integer, not octal} {
set x end-0a2
list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"end-0a2\": must be integer or end?-integer?}"
test lindex-12.9 {incomplete end} {
set x en
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {c c}
test lindex-12.10 {incomplete end-} {
set x end-
list [catch { lindex {a b c} $x } result] $result
} "1 {bad index \"end-\": must be integer or end?-integer?}"
test lindex-13.1 {bad second index} {
list [catch { lindex {a b c} 0 0a2 } result] $result
} "1 {bad index \"0a2\": must be integer or end?-integer?}"
test lindex-13.2 {good second index} {
catch {
lindex {{a b c} {d e f} {g h i}} 1 2
} result
set result
} f
test lindex-13.3 {three indices} {
catch {
lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1
} result
set result
} f
test lindex-14.1 {error conditions in parsing list} {
list [catch { lindex "a \{" 2 } msg] $msg
} {1 {unmatched open brace in list}}
test lindex-14.2 {error conditions in parsing list} {
list [catch { lindex {a {b c}d e} 2 } msg] $msg
} {1 {list element in braces followed by "d" instead of space}}
test lindex-14.3 {error conditions in parsing list} {
list [catch { lindex {a "b c"def ghi} 2 } msg] $msg
} {1 {list element in quotes followed by "def" instead of space}}
test lindex-15.1 {quoted elements} {
catch {
lindex {a "b c" d} 1
} result
set result
} {b c}
test lindex-15.2 {quoted elements} {
catch {
lindex {"{}" b c} 0
} result
set result
} {{}}
test lindex-15.3 {quoted elements} {
catch {
lindex {ab "c d \" x" y} 1
} result
set result
} {c d " x}
test lindex-15.4 {quoted elements} {
catch {
lindex {a b {c d "e} {f g"}} 2
} result
set result
} {c d "e}
test lindex-16.1 {data reuse} {
set x 0
catch {
lindex $x $x
} result
set result
} {0}
test lindex-16.2 {data reuse} {
set a 0
catch {
lindex $a $a $a
} result
set result
} 0
test lindex-16.3 {data reuse} {
set a 1
catch {
lindex $a $a $a
} result
set result
} {}
test lindex-16.4 {data reuse} {
set x [list 0 0]
catch {
lindex $x $x
} result
set result
} {0}
test lindex-16.5 {data reuse} {
set x 0
catch {
lindex $x [list $x $x]
} result
set result
} {0}
test lindex-16.6 {data reuse} {
set x [list 1 1]
catch {
lindex $x $x
} result
set result
} {}
test lindex-16.7 {data reuse} {
set x 1
catch {
lindex $x [list $x $x]
} result
set result
} {}
catch { unset lindex}
catch { unset minus }
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/eval.test 0000644 0036047 0045461 00000003145 11737050674 013714 0 ustar dgp 771div # Commands covered: eval
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test eval-1.1 {single argument} {
eval {format 22}
} 22
test eval-1.2 {multiple arguments} {
set a {$b}
set b xyzzy
eval format $a
} xyzzy
test eval-1.3 {single argument} {
eval concat a b c d e f g
} {a b c d e f g}
test eval-2.1 {error: not enough arguments} {catch eval} 1
test eval-2.2 {error: not enough arguments} {
catch eval msg
set msg
} {wrong # args: should be "eval arg ?arg ...?"}
test eval-2.3 {error in eval'ed command} {
catch {eval {error "test error"}}
} 1
test eval-2.4 {error in eval'ed command} {
catch {eval {error "test error"}} msg
set msg
} {test error}
test eval-2.5 {error in eval'ed command: setting errorInfo} {
catch {eval {
set a 1
error "test error"
}} msg
set errorInfo
} "test error
while executing
\"error \"test error\"\"
(\"eval\" body line 3)
invoked from within
\"eval {
set a 1
error \"test error\"
}\""
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/unixInit.test 0000644 0036047 0045461 00000030745 11737050674 014602 0 ustar dgp 771div # The file tests the functions in the tclUnixInit.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
namespace import -force ::tcltest::*
unset -nocomplain path
if {[info exists env(TCL_LIBRARY)]} {
set oldlibrary $env(TCL_LIBRARY)
unset env(TCL_LIBRARY)
}
catch {set oldlang $env(LANG)}
set env(LANG) C
test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly stdio} {
set x {}
# Watch out for a race condition here. If tcltest is too slow to start
# then we'll kill it before it has a chance to set up its signal handler.
set f [open "|[list [interpreter]]" w+]
puts $f "puts hi"
flush $f
gets $f
exec kill -PIPE [pid $f]
lappend x [catch {close $f}]
set f [open "|[list [interpreter]]" w+]
puts $f "puts hi"
flush $f
gets $f
exec kill [pid $f]
lappend x [catch {close $f}]
set x
} {0 1}
# This test is really a test of code in tclUnixChan.c, but the
# channels are set up as part of initialisation of the interpreter so
# the test seems to me to fit here as well as anywhere else.
test unixInit-1.2 {initialisation: standard channel type deduction} {unixOnly stdio} {
# pipe1 is a connection to a server that reports what port it
# starts on, and delivers a constant string to the first client to
# connect to that port before exiting.
set pipe1 [open "|[list [interpreter]]" r+]
puts $pipe1 {
proc accept {channel host port} {
puts $channel {puts [fconfigure stdin -peername]; exit}
close $channel
exit
}
puts [fconfigure [socket -server accept 0] -sockname]
vwait forever \
}
# Note the backslash above; this is important to make sure that the
# whole string is read before an [exit] can happen...
flush $pipe1
set port [lindex [gets $pipe1] 2]
set sock [socket localhost $port]
# pipe2 is a connection to a Tcl interpreter that takes its orders
# from the socket we hand it (i.e. the server we create above.)
# These orders will tell it to print out the details about the
# socket it is taking instructions from, hopefully identifying it
# as a socket. Which is what this test is all about.
set pipe2 [open "|[list [interpreter] <@$sock]" r]
set result [gets $pipe2]
# Clear any pending data; stops certain kinds of (non-important) errors
fconfigure $pipe1 -blocking 0; gets $pipe1
fconfigure $pipe2 -blocking 0; gets $pipe2
# Close the pipes and the socket.
close $pipe2
close $pipe1
catch {close $sock}
# Can't use normal comparison, as hostname varies due to some
# installations having a messed up /etc/hosts file.
if {
[string equal 127.0.0.1 [lindex $result 0]] &&
[string equal $port [lindex $result 2]]
} then {
subst "OK"
} else {
subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'"
}
} {OK}
proc getlibpath [list [list program [interpreter]]] {
set f [open "|[list $program]" w+]
fconfigure $f -buffering none
puts $f {puts $tcl_libPath; exit}
set path [gets $f]
close $f
return $path
}
# Some tests require the testgetdefenc command
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \
{unixOnly testgetdefenc} {
set origDir [testgetdefenc]
testsetdefenc slappy
set path [testgetdefenc]
testsetdefenc $origDir
set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \
{unixOnly stdio} {
set path [getlibpath]
set installLib lib/tcl[info tclversion]
set developLib tcl[info patchlevel]/library
set prefix [file dirname [file dirname [interpreter]]]
set x {}
lappend x [string compare [lindex $path 0] $prefix/$installLib]
lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib]
set x
} {0 0}
test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly stdio} {
# ((str != NULL) && (str[0] != '\0'))
set env(TCL_LIBRARY) sparkly
set path [getlibpath]
unset env(TCL_LIBRARY)
lindex $path 0
} "sparkly"
test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} \
{unixOnly stdio} {
# ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))
set env(TCL_LIBRARY) /a/b/tcl1.7
set path [getlibpath]
unset env(TCL_LIBRARY)
lrange $path 0 1
} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} \
{unixOnly stdio} {
# Child process translates env variable from native encoding.
set env(TCL_LIBRARY) "\xa7"
set x [lindex [getlibpath] 0]
unset env(TCL_LIBRARY)
unset env(LANG)
set x
} "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \
{emptyTest unixOnly} {
# cannot test
} {}
test unixInit-2.6 {TclpInitLibraryPath: executable relative} \
{unixOnly stdio} {
makeDirectory tmp
makeDirectory [file join tmp sparkly]
makeDirectory [file join tmp sparkly bin]
file copy [interpreter] [file join [temporaryDirectory] tmp sparkly \
bin tcltest]
makeDirectory [file join tmp sparkly lib]
makeDirectory [file join tmp sparkly lib tcl[info tclversion]]
makeFile {} [file join tmp sparkly lib tcl[info tclversion] init.tcl]
set x [lrange [getlibpath [file join [temporaryDirectory] tmp sparkly \
bin tcltest]] 0 1]
removeFile [file join tmp sparkly lib tcl[info tclversion] init.tcl]
removeDirectory [file join tmp sparkly lib tcl[info tclversion]]
removeDirectory [file join tmp sparkly lib]
removeDirectory [file join tmp sparkly bin]
removeDirectory [file join tmp sparkly]
removeDirectory tmp
set x
} [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
{emptyTest unixOnly} {
# would need test command to get defaultLibDir and compare it to
# [lindex $auto_path end]
} {}
#
# The following two tests write to the directory /tmp/sparkly instead
# of to [temporaryDirectory]. This is because the failures tested by
# these tests need paths near the "root" of the file system to present
# themselves.
#
testConstraint noSparkly [expr {![file exists [file join /tmp sparkly]]}]
testConstraint noTmpInstall [expr {![file exists \
[file join /tmp lib tcl[info tclversion]]]}]
test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} {unix noSparkly noTmpInstall} {
# Checking for Bug 219416
# When a program that embeds the Tcl library, like tcltest, is
# installed near the "root" of the file system, there was a problem
# constructing directories relative to the executable. When a
# relative ".." went past the root, relative path names were created
# rather than absolute pathnames. In some cases, accessing past the
# root caused memory access violations too.
#
# The bug is now fixed, but here we check for it by making sure that
# the directories constructed relative to the executable are all
# absolute pathnames, even when the executable is installed near
# the root of the filesystem.
#
# The only directory near the root we are likely to have write access
# to is /tmp.
file delete -force /tmp/sparkly
file delete -force /tmp/lib/tcl[info tclversion]
file mkdir /tmp/sparkly
file copy [interpreter] /tmp/sparkly/tcltest
# Keep any existing /tmp/lib directory
set deletelib 1
if {[file exists /tmp/lib]} {
if {[file isdirectory /tmp/lib]} {
set deletelib 0
} else {
file delete -force /tmp/lib
}
}
# For a successful Tcl_Init, we need a [source]-able init.tcl in
# ../lib/tcl$version relative to the executable.
file mkdir /tmp/lib/tcl[info tclversion]
close [open /tmp/lib/tcl[info tclversion]/init.tcl w]
# Check that all directories in the library path are absolute pathnames
set allAbsolute 1
foreach dir [getlibpath /tmp/sparkly/tcltest] {
set allAbsolute [expr {$allAbsolute \
&& [string equal absolute [file pathtype $dir]]}]
}
# Clean up temporary installation
file delete -force /tmp/sparkly
file delete -force /tmp/lib/tcl[info tclversion]
if {$deletelib} {file delete -force /tmp/lib}
set allAbsolute
} 1
testConstraint noTmpBuild [expr {![file exists [file join /tmp library]]}]
test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} {unix noSparkly noTmpBuild} {
# Checking for Bug 438014
file delete -force /tmp/sparkly
file delete -force /tmp/library
file mkdir /tmp/sparkly
file copy [interpreter] /tmp/sparkly/tcltest
file mkdir /tmp/library/
close [open /tmp/library/init.tcl w]
set x [lrange [getlibpath /tmp/sparkly/tcltest] 0 4]
file delete -force /tmp/sparkly
file delete -force /tmp/library
set x
} [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \
/tmp/library /library /tcl[info patchlevel]/library]
test unixInit-2.10 {TclpInitLibraryPath: executable relative} -constraints {
unixOnly stdio
} -setup {
set tmpDir [makeDirectory tmp]
set sparklyDir [makeDirectory sparkly $tmpDir]
set execPath [file join [makeDirectory bin $sparklyDir] tcltest]
file copy [interpreter] $execPath
set libDir [makeDirectory lib $sparklyDir]
set scriptDir [makeDirectory tcl[info tclversion] $libDir]
makeFile {} init.tcl $scriptDir
set saveDir [pwd]
cd $libDir
} -body {
# Checking for Bug 832657
set x [lrange [getlibpath [file join .. bin tcltest]] 2 3]
foreach p $x {
lappend y [file normalize $p]
}
set y
} -cleanup {
cd $saveDir
unset saveDir
removeFile init.tcl $scriptDir
unset scriptDir
removeDirectory tcl[info tclversion] $libDir
unset libDir
file delete $execPath
unset execPath
removeDirectory bin $sparklyDir
removeDirectory lib $sparklyDir
unset sparklyDir
removeDirectory sparkly $tmpDir
unset tmpDir
removeDirectory tmp
unset x p y
} -result [list [file join [temporaryDirectory] tmp sparkly library] \
[file join [temporaryDirectory] tmp library] ]
test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
unixOnly stdio
} -body {
set env(LANG) C
set f [open "|[list [interpreter]]" w+]
fconfigure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
unset env(LANG)
set enc
} -match regexp -result [expr {
($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}]
test unixInit-3.2 {TclpSetInitialEncodings} {unixOnly stdio} {
set env(LANG) japanese
catch {set oldlc_all $env(LC_ALL)}
set env(LC_ALL) japanese
set f [open "|[list [interpreter]]" w+]
fconfigure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
unset env(LANG)
unset env(LC_ALL)
catch {set env(LC_ALL) $oldlc_all}
set validEncodings [list euc-jp]
if {[string match HP-UX $tcl_platform(os)]} {
# Some older HP-UX systems need us to accept this as valid
# Bug 453883 reports that newer HP-UX systems report euc-jp
# like everybody else.
lappend validEncodings shiftjis
}
expr {[lsearch -exact $validEncodings $enc] < 0}
} 0
test unixInit-4.1 {TclpSetVariables} {unixOnly} {
# just make sure they exist
set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)]
set a [list $tcl_platform(osVersion) $tcl_platform(machine)]
set tcl_platform(platform)
} "unix"
test unixInit-5.1 {Tcl_Init} {emptyTest unixOnly} {
# test initScript
} {}
test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unixOnly} {
} {}
test unixInit-7.1 {closed standard channel: Bug 772288} -constraints {
unixOnly stdio
} -body {
set tclsh [interpreter]
set crash [makeFile {puts [open /dev/null]} crash.tcl]
set crashtest [makeFile "
close stdin
[list exec $tclsh $crash]
" crashtest.tcl]
exec $tclsh $crashtest
} -cleanup {
removeFile crash.tcl
removeFile crashtest.tcl
} -returnCodes 0
# cleanup
if {[info exists oldlibrary]} {
set env(TCL_LIBRARY) $oldlibrary
}
catch {unset env(LANG)}
catch {set env(LANG) $oldlang}
unset -nocomplain path
::tcltest::cleanupTests
return
tcl8.4.20/tests/llength.test 0000644 0036047 0045461 00000002405 11737050674 014420 0 ustar dgp 771div # Commands covered: llength
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test llength-1.1 {length of list} {
llength {a b c d}
} 4
test llength-1.2 {length of list} {
llength {a b c {a b {c d}} d}
} 5
test llength-1.3 {length of list} {
llength {}
} 0
test llength-2.1 {error conditions} {
list [catch {llength} msg] $msg
} {1 {wrong # args: should be "llength list"}}
test llength-2.2 {error conditions} {
list [catch {llength 123 2} msg] $msg
} {1 {wrong # args: should be "llength list"}}
test llength-2.3 {error conditions} {
list [catch {llength "a b c \{"} msg] $msg
} {1 {unmatched open brace in list}}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/unixNotfy.test 0000644 0036047 0045461 00000006302 11737050674 014766 0 ustar dgp 771div # This file contains tests for tclUnixNotfy.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# The tests should not be run if you have a notifier which is unable to
# detect infinite vwaits, as the tests below will hang. The presence of
# the "testthread" command indicates that this is the case.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[info exists tk_version]} {
puts "When run in a Tk shell, these tests run hang. Skipping tests ..."
::tcltest::cleanupTests
return
}
set ::tcltest::testConstraints(testthread) \
[expr {[info commands testthread] != {}}]
# Darwin always uses a threaded notifier
testConstraint unthreaded [expr {
(![info exist tcl_platform(threaded)] || !$tcl_platform(threaded))
&& $tcl_platform(os) ne "Darwin"
}]
# The next two tests will hang if threads are enabled because the notifier
# will not necessarily wait for ever in this case, so it does not generate
# an error.
test unixNotfy-1.1 {Tcl_DeleteFileHandler} \
-constraints {unixOnly && unthreaded} \
-body {
catch {vwait x}
set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
list [catch {vwait x} msg] $msg
} \
-result {1 {can't wait for variable "x": would wait forever}} \
-cleanup {
catch { close $f }
catch { removeFile foo }
}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} \
-constraints {unixOnly && unthreaded} \
-body {
catch {vwait x}
set f1 [open [makeFile "" foo] w]
set f2 [open [makeFile "" foo2] w]
fileevent $f1 writable {set x 1}
fileevent $f2 writable {set y 1}
vwait x
close $f1
vwait y
close $f2
list [catch {vwait x} msg] $msg
} \
-result {1 {can't wait for variable "x": would wait forever}} \
-cleanup {
catch { close $f1 }
catch { close $f2 }
catch { removeFile foo }
catch { removeFile foo2 }
}
test unixNotfy-2.1 {Tcl_DeleteFileHandler} \
-constraints {unixOnly testthread} \
-body {
update
set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
testthread create "testthread send [testthread id] {set x ok}"
vwait x
threadReap
set x
} \
-result {ok} \
-cleanup {
catch { close $f }
catch { removeFile foo }
}
test unixNotfy-2.2 {Tcl_DeleteFileHandler} \
-constraints {unixOnly testthread} \
-body {
update
set f1 [open [makeFile "" foo] w]
set f2 [open [makeFile "" foo2] w]
fileevent $f1 writable {set x 1}
fileevent $f2 writable {set y 1}
vwait x
close $f1
vwait y
close $f2
testthread create "testthread send [testthread id] {set x ok}"
vwait x
threadReap
set x
} \
-result {ok} \
-cleanup {
catch { close $f1 }
catch { close $f2 }
catch { removeFile foo }
catch { removeFile foo2 }
}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/var.test 0000644 0036047 0045461 00000056007 11737050674 013562 0 ustar dgp 771div # This file contains tests for the tclVar.c source file. Tests appear in
# the same order as the C code that they test. The set of tests is
# currently incomplete since it currently includes only new tests for
# code changed for the addition of Tcl namespaces. Other variable-
# related tests appear in several other test files including
# namespace.test, set.test, trace.test, and upvar.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
catch {unset x}
catch {unset y}
catch {unset i}
catch {unset a}
catch {unset arr}
test var-1.1 {TclLookupVar, Array handling} {
catch {unset a}
set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd
set i 10
set arr(foo) 37
list [$x i] $i [$x arr(foo)] $arr(foo)
} {11 11 38 38}
test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} {
set x "global value"
namespace eval test_ns_var {
variable x "namespace value"
proc p {} {
global x ;# specifies TCL_GLOBAL_ONLY to get global x
return $x
}
}
test_ns_var::p
} {global value}
test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} {
namespace eval test_ns_var {
proc q {} {
variable x ;# specifies TCL_NAMESPACE_ONLY to get namespace x
return $x
}
}
test_ns_var::q
} {namespace value}
test var-1.4 {TclLookupVar, no active call frame implies global namespace var} {
set x
} {global value}
test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} {
namespace eval test_ns_var {set x}
} {namespace value}
test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} {
namespace eval test_ns_var {set ::x}
} {global value}
test var-1.7 {TclLookupVar, error finding namespace var} {
list [catch {set a:::b} msg] $msg
} {1 {can't read "a:::b": no such variable}}
test var-1.8 {TclLookupVar, error finding namespace var} {
list [catch {set ::foobarfoo} msg] $msg
} {1 {can't read "::foobarfoo": no such variable}}
test var-1.9 {TclLookupVar, create new namespace var} {
namespace eval test_ns_var {
set v hello
}
} {hello}
test var-1.10 {TclLookupVar, create new namespace var} {
catch {unset y}
namespace eval test_ns_var {
set ::y 789
}
set y
} {789}
test var-1.11 {TclLookupVar, error creating new namespace var} {
namespace eval test_ns_var {
list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg
}
} {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}}
test var-1.12 {TclLookupVar, error creating new namespace var} {
namespace eval test_ns_var {
list [catch {set ::test_ns_var::foo:: 1997} msg] $msg
}
} {1 {can't set "::test_ns_var::foo::": parent namespace doesn't exist}}
test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} {
catch {unset aNeWnAmEiNnS}
namespace eval test_ns_var {
namespace eval test_ns_var2::test_ns_var3 {
set aNeWnAmEiNnS 77777
}
# namespace which builds a name by traversing nsPtr chain to ::
namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS
}
} {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS}
test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} {
namespace eval test_ns_var {
set : 123
set v: 456
set x:y: 789
list [set :] [set v:] [set x:y:] \
${:} ${v:} ${x:y:} \
[expr {[lsearch [info vars] :] != -1}] \
[expr {[lsearch [info vars] v:] != -1}] \
[expr {[lsearch [info vars] x:y:] != -1}]
}
} {123 456 789 123 456 789 1 1 1}
test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} {
namespace eval test_ns_var {
variable foo 2
}
proc p {} {
variable ::test_ns_var::foo
lappend result [catch {set foo} msg] $msg
namespace delete ::test_ns_var
lappend result [catch {set foo 3} msg] $msg
lappend result [catch {set foo(3) 3} msg] $msg
}
p
} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}}
test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} {
namespace eval test_ns_var {
variable result
namespace eval subns {
variable foo 2
}
upvar 0 subns::foo foo
lappend result [catch {set foo} msg] $msg
namespace delete subns
lappend result [catch {set foo 3} msg] $msg
lappend result [catch {set foo(3) 3} msg] $msg
namespace delete [namespace current]
set result
}
} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}}
test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} {
namespace eval test_ns_var {
variable result
proc p {} {
array set x {1 2 3 4}
upvar 0 x(1) foo
lappend result [catch {set foo} msg] $msg
unset x
lappend result [catch {set foo 3} msg] $msg
}
set result [p]
namespace delete [namespace current]
set result
}
} {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} {
namespace eval test_ns_var {
variable result {}
variable x
array set x {1 2 3 4}
upvar 0 x(1) foo
lappend result [catch {set foo} msg] $msg
unset x
lappend result [catch {set foo 3} msg] $msg
namespace delete [namespace current]
set result
}
} {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
test var-1.19 {TclLookupVar, right error message when parsing variable name} {
list [catch {[format set] thisvar(doesntexist)} msg] $msg
} {1 {can't read "thisvar(doesntexist)": no such variable}}
test var-2.1 {Tcl_LappendObjCmd, create var if new} {
catch {unset x}
lappend x 1 2
} {1 2}
test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} {
catch {unset x}
set x 1997
proc p {} {
global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x
return $x
}
p
} {1997}
test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} {
namespace eval test_ns_var {
catch {unset v}
variable v 1998
proc p {} {
variable v ;# TCL_NAMESPACE_ONLY specified for other var x
return $v
}
p
}
} {1998}
if {[info commands testupvar] != {}} {
test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} {
catch {unset a}
set a 123321
proc p {} {
# create global xx linked to global a
testupvar 1 a {} xx global
}
list [p] $xx [set xx 789] $a
} {{} 123321 789 789}
test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} {
catch {unset a}
set a 456
namespace eval test_ns_var {
catch {unset ::test_ns_var::vv}
proc p {} {
# create namespace var vv linked to global a
testupvar 1 a {} vv namespace
}
p
}
list $test_ns_var::vv [set test_ns_var::vv 123] $a
} {456 123 123}
}
test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} {
catch {unset aaaaa}
catch {unset xxxxx}
set aaaaa 77777
upvar #0 aaaaa xxxxx
list [set xxxxx] [set aaaaa]
} {77777 77777}
test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} {
catch {unset a}
set a 121212
namespace eval test_ns_var {
upvar ::a vvv
set vvv
}
} {121212}
test var-3.7 {MakeUpvar, my var has ::s} {
catch {unset a}
set a 789789
upvar #0 a test_ns_var::lnk
namespace eval test_ns_var {
set lnk
}
} {789789}
test var-3.8 {MakeUpvar, my var already exists in global ns} {
catch {unset aaaaa}
catch {unset xxxxx}
set aaaaa 456654
set xxxxx hello
upvar #0 aaaaa xxxxx
set xxxxx
} {hello}
test var-3.9 {MakeUpvar, my var has invalid ns name} {
catch {unset aaaaa}
set aaaaa 789789
list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg
} {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}}
test var-3.10 {MakeUpvar, } {
namespace eval {} {
set bar 0
namespace eval foo upvar bar bar
set foo::bar 1
catch {list $bar $foo::bar} msg
unset ::aaaaa
set msg
}
} {1 1}
if {[info commands testgetvarfullname] != {}} {
test var-4.1 {Tcl_GetVariableName, global variable} {
catch {unset a}
set a 123
testgetvarfullname a global
} ::a
test var-4.2 {Tcl_GetVariableName, namespace variable} {
namespace eval test_ns_var {
variable george
testgetvarfullname george namespace
}
} ::test_ns_var::george
test var-4.3 {Tcl_GetVariableName, variable can't be array element} {
catch {unset a}
set a(1) foo
list [catch {testgetvarfullname a(1) global} msg] $msg
} {1 {unknown variable "a(1)"}}
}
test var-5.1 {Tcl_GetVariableFullName, global variable} {
catch {unset a}
set a bar
namespace which -variable a
} {::a}
test var-5.2 {Tcl_GetVariableFullName, namespace variable} {
namespace eval test_ns_var {
variable martha
namespace which -variable martha
}
} {::test_ns_var::martha}
test var-5.3 {Tcl_GetVariableFullName, namespace variable} {
namespace which -variable test_ns_var::martha
} {::test_ns_var::martha}
test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
namespace eval test_ns_var {
variable boeing 777
}
proc p {} {
global ::test_ns_var::boeing
set boeing
}
p
} {777}
test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
namespace eval test_ns_var {
namespace eval test_ns_nested {
variable java java
}
proc p {} {
global ::test_ns_var::test_ns_nested::java
set java
}
}
test_ns_var::p
} {java}
test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} {
set ::test_ns_var::test_ns_nested:: 24
proc p {} {
global ::test_ns_var::test_ns_nested::
set {}
}
p
} {24}
test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} {
# Test for Tcl Bug 480176
set :v broken
proc p {} {
global :v
set :v fixed
}
p
set :v
} {fixed}
test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} {
catch {namespace delete test_ns_var}
namespace eval test_ns_var {
variable one 1
}
list [info vars test_ns_var::*] [set test_ns_var::one]
} {::test_ns_var::one 1}
test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} {
set two 2222222
namespace eval test_ns_var {
variable two
}
list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg
} {0 1 {can't read "test_ns_var::two": no such variable}}
test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} {
namespace eval test_ns_var {
variable two 2
}
list [lsort [info vars test_ns_var::*]] \
[namespace eval test_ns_var {set two}]
} [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2]
test var-7.4 {Tcl_VariableObjCmd, list of vars} {
namespace eval test_ns_var {
variable three 3 four 4
}
list [lsort [info vars test_ns_var::*]] \
[namespace eval test_ns_var {expr $three+$four}]
} [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7]
test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} {
catch {unset a}
catch {unset five}
catch {unset six}
set a ""
set five 555
set six 666
namespace eval test_ns_var {
variable five 5 six
lappend a $five
}
lappend a $test_ns_var::five \
[set test_ns_var::six 6] [set test_ns_var::six] $six
catch {unset five}
catch {unset six}
set a
} {5 5 6 6 666}
catch {unset newvar}
test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} {
namespace eval test_ns_var {
variable ::newvar cheers!
}
set newvar
} {cheers!}
catch {unset newvar}
test var-7.7 {Tcl_VariableObjCmd, bad var name} {
namespace eval test_ns_var {
list [catch {variable sev:::en 7} msg] $msg
}
} {1 {can't define "sev:::en": parent namespace doesn't exist}}
test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} {
set a ""
namespace eval test_ns_var {
variable eight 8
lappend a $eight
variable eight
lappend a $eight
}
set a
} {8 8}
test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} {
catch {namespace delete test_ns_var2}
set a ""
namespace eval test_ns_var2 {
variable x 123
variable y
variable z
}
lappend a [lsort [info vars test_ns_var2::*]]
lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \
[info exists test_ns_var2::z]
lappend a [list [catch {set test_ns_var2::y} msg] $msg]
lappend a [lsort [info vars test_ns_var2::*]]
lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
lappend a [set test_ns_var2::y hello]
lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
lappend a [list [catch {unset test_ns_var2::y} msg] $msg]
lappend a [lsort [info vars test_ns_var2::*]]
lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
lappend a [list [catch {unset test_ns_var2::z} msg] $msg]
lappend a [namespace delete test_ns_var2]
set a
} [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\
{1 {can't read "test_ns_var2::y": no such variable}}\
[lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 0 0\
hello 1 0\
{0 {}}\
[lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\
{1 {can't unset "test_ns_var2::z": no such variable}}\
{}]
test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
namespace eval test_ns_var {
proc p {} {
variable eight
list [set eight] [info vars]
}
p
}
} {8 eight}
test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
proc p {} { ;# note this proc is at global :: scope
variable test_ns_var::eight
list [set eight] [info vars]
}
p
} {8 eight}
test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
namespace eval test_ns_var {
variable {} {My name is empty}
}
proc p {} { ;# note this proc is at global :: scope
variable test_ns_var::
list [set {}] [info vars]
}
p
} {{My name is empty} {{}}}
test var-7.13 {Tcl_VariableObjCmd, variable named ":"} {
namespace eval test_ns_var {
variable : {My name is ":"}
proc p {} {
variable :
list [set :] [info vars]
}
p
}
} {{My name is ":"} :}
test var-7.14 {Tcl_VariableObjCmd, array element parameter} {
catch {namespace eval test_ns_var { variable arrayvar(1) }} res
set res
} "can't define \"arrayvar(1)\": name refers to an element in an array"
test var-7.15 {Tcl_VariableObjCmd, array element parameter} {
catch {
namespace eval test_ns_var {
variable arrayvar
set arrayvar(1) x
variable arrayvar(1) y
}
} res
set res
} "can't define \"arrayvar(1)\": name refers to an element in an array"
test var-7.16 {Tcl_VariableObjCmd, no args} {
list [catch {variable} msg] $msg
} {1 {wrong # args: should be "variable ?name value...? name ?value?"}}
test var-7.17 {Tcl_VariableObjCmd, no args} {
namespace eval test_ns_var {
list [catch {variable} msg] $msg
}
} {1 {wrong # args: should be "variable ?name value...? name ?value?"}}
test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} {
catch {namespace delete test_ns_var}
catch {unset a}
namespace eval test_ns_var {
variable v 123
variable info ""
proc traceUnset {name1 name2 op} {
variable info
set info [concat $info [list $name1 $name2 $op]]
}
trace var v u [namespace code traceUnset]
}
list [unset test_ns_var::v] $test_ns_var::info
} {{} {test_ns_var::v {} u}}
if {[info commands testsetnoerr] == {}} {
puts "This application hasn't been compiled with the \"testsetnoerr\""
puts "command, so I can't test TclSetVar etc."
} else {
test var-9.1 {behaviour of TclGet/SetVar simple get/set} {
catch {unset u}; catch {unset v}
list \
[set u a; testsetnoerr u] \
[testsetnoerr v b] \
[testseterr u] \
[unset v; testseterr v b]
} [list {before get a} {before set b} {before get a} {before set b}]
test var-9.2 {behaviour of TclGet/SetVar namespace get/set} {
catch {namespace delete ns}
namespace eval ns {variable u a; variable v}
list \
[testsetnoerr ns::u] \
[testsetnoerr ns::v b] \
[testseterr ns::u] \
[unset ns::v; testseterr ns::v b]
} [list {before get a} {before set b} {before get a} {before set b}]
test var-9.3 {behaviour of TclGetVar no variable} {
catch {unset u}
list \
[catch {testsetnoerr u} res] $res \
[catch {testseterr u} res] $res
} {1 {before get} 1 {can't read "u": no such variable}}
test var-9.4 {behaviour of TclGetVar no namespace variable} {
catch {namespace delete ns}
namespace eval ns {}
list \
[catch {testsetnoerr ns::w} res] $res \
[catch {testseterr ns::w} res] $res
} {1 {before get} 1 {can't read "ns::w": no such variable}}
test var-9.5 {behaviour of TclGetVar no namespace} {
catch {namespace delete ns}
list \
[catch {testsetnoerr ns::u} res] $res \
[catch {testseterr ns::v} res] $res
} {1 {before get} 1 {can't read "ns::v": no such variable}}
test var-9.6 {behaviour of TclSetVar no namespace} {
catch {namespace delete ns}
list \
[catch {testsetnoerr ns::v 1} res] $res \
[catch {testseterr ns::v 1} res] $res
} {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}}
test var-9.7 {behaviour of TclGetVar array variable} {
catch {unset arr}
set arr(1) 1;
list \
[catch {testsetnoerr arr} res] $res \
[catch {testseterr arr} res] $res
} {1 {before get} 1 {can't read "arr": variable is array}}
test var-9.8 {behaviour of TclSetVar array variable} {
catch {unset arr}
set arr(1) 1
list \
[catch {testsetnoerr arr 2} res] $res \
[catch {testseterr arr 2} res] $res
} {1 {before set} 1 {can't set "arr": variable is array}}
test var-9.9 {behaviour of TclGetVar read trace success} {
proc resetvar {val name elem op} {upvar 1 $name v; set v $val}
catch {unset u}; catch {unset v}
set u 10
trace var u r [list resetvar 1]
trace var v r [list resetvar 2]
list \
[testsetnoerr u] \
[testseterr v]
} {{before get 1} {before get 2}}
test var-9.10 {behaviour of TclGetVar read trace error} {
proc writeonly args {error "write-only"}
set v 456
trace var v r writeonly
list \
[catch {testsetnoerr v} msg] $msg \
[catch {testseterr v} msg] $msg
} {1 {before get} 1 {can't read "v": write-only}}
test var-9.11 {behaviour of TclSetVar write trace success} {
proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]}
catch {unset u}; catch {unset v}
set v 1
trace var v w doubleval
trace var u w doubleval
list \
[testsetnoerr u 2] \
[testseterr v 3]
} {{before set 4} {before set 6}}
test var-9.12 {behaviour of TclSetVar write trace error} {
proc readonly args {error "read-only"}
set v 456
trace var v w readonly
list \
[catch {testsetnoerr v 2} msg] $msg $v \
[catch {testseterr v 3} msg] $msg $v
} {1 {before set} 2 1 {can't set "v": read-only} 3}
}
test var-10.1 {can't nest arrays with array set} {
catch {unset arr}
list [catch {array set arr(x) {a 1 b 2}} res] $res
} {1 {can't set "arr(x)": variable isn't array}}
test var-10.2 {can't nest arrays with array set} {
catch {unset arr}
list [catch {array set arr(x) {}} res] $res
} {1 {can't set "arr(x)": variable isn't array}}
test var-11.1 {array unset} {
catch {unset a}
array set a { 1,1 a 1,2 b 2,1 c 2,3 d }
array unset a 1,*
lsort -dict [array names a]
} {2,1 2,3}
test var-11.2 {array unset} {
catch {unset a}
array set a { 1,1 a 1,2 b }
array unset a
array exists a
} 0
test var-11.3 {array unset errors} {
catch {unset a}
array set a { 1,1 a 1,2 b }
list [catch {array unset a pattern too} msg] $msg
} {1 {wrong # args: should be "array unset arrayName ?pattern?"}}
test var-12.1 {TclFindCompiledLocals, {} array name} {
namespace eval n {
proc p {} {
variable {}
set (0) 0
set (1) 1
set n 2
set ($n) 2
set ($n,foo) 2
}
p
lsort -dictionary [array names {}]
}
} {0 1 2 2,foo}
test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} {
catch {unset t}
proc foo {var ind op} {
global t
set foo bar
}
namespace eval :: {
set t(1) 1
trace variable t(1) u foo
unset t
}
set x "If you see this, it worked"
} "If you see this, it worked"
test var-14.1 {array names syntax} -body {
array names foo bar baz snafu
} -returnCodes 1 -match glob -result *
test var-15.1 {segfault in [unset], [Bug 735335]} {
proc A { name } {
upvar $name var
set var $name
}
#
# Note that the variable name has to be
# unused previously for the segfault to
# be triggered.
#
namespace eval test A useSomeUnlikelyNameHere
namespace eval test unset useSomeUnlikelyNameHere
} {}
test var-16.1 {CallVarTraces: save/restore interp error state: 1038021} {
trace add variable errorCode write { ;#}
catch {error foo bar baz}
trace remove variable errorCode write { ;#}
set errorInfo
} bar
test var-17.1 {TclArraySet [Bug 1669489]} -setup {
unset -nocomplain ::a
} -body {
namespace eval :: {
set elements {1 2 3 4}
trace add variable a write {string length $elements ;#}
array set a $elements
}
} -cleanup {
unset -nocomplain ::a ::elements
} -result {}
catch {namespace delete ns}
catch {unset arr}
catch {unset v}
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {namespace delete test_ns_var2}
catch {unset xx}
catch {unset x}
catch {unset y}
catch {unset i}
catch {unset a}
catch {unset xxxxx}
catch {unset aaaaa}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/if.test 0000644 0036047 0045461 00000065436 11737050674 013376 0 ustar dgp 771div # Commands covered: if
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Basic "if" operation.
catch {unset a}
test if-1.1 {TclCompileIfCmd: missing if/elseif test} {
list [catch {if} msg] $msg
} {1 {wrong # args: no expression after "if" argument}}
test if-1.2 {TclCompileIfCmd: error in if/elseif test} {
list [catch {if {[error "error in condition"]} foo} msg] $msg
} {1 {error in condition}}
test if-1.3 {TclCompileIfCmd: error in if/elseif test} {
list [catch {if {1+}} msg] $msg $errorInfo
} {1 {syntax error in expression "1+": premature end of expression} {syntax error in expression "1+": premature end of expression
("if" test expression)
while compiling
"if {1+}"}}
test if-1.4 {TclCompileIfCmd: if/elseif test in braces} {
set a {}
if {1<2} {set a 1}
set a
} {1}
test if-1.5 {TclCompileIfCmd: if/elseif test not in braces} {
set a {}
if 1<2 {set a 1}
set a
} {1}
test if-1.6 {TclCompileIfCmd: multiline test expr} {
set a {}
if {($tcl_platform(platform) != "foobar1") && \
($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4}
set a
} 3
test if-1.7 {TclCompileIfCmd: "then" after if/elseif test} {
set a {}
if 4>3 then {set a 1}
set a
} {1}
test if-1.8 {TclCompileIfCmd: keyword other than "then" after if/elseif test} {
set a {}
catch {if 1<2 therefore {set a 1}} msg
set msg
} {invalid command name "therefore"}
test if-1.9 {TclCompileIfCmd: missing "then" body} {
set a {}
catch {if 1<2 then} msg
set msg
} {wrong # args: no script following "then" argument}
test if-1.10 {TclCompileIfCmd: error in "then" body} {
set a {}
list [catch {if {$a!="xxx"} then {set}} msg] $msg $errorInfo
} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
("if" then script line 1)
while compiling
"if {$a!="xxx"} then {set}"}}
test if-1.11 {TclCompileIfCmd: error in "then" body} {
list [catch {if 2 then {[error "error in then clause"]}} msg] $msg
} {1 {error in then clause}}
test if-1.12 {TclCompileIfCmd: "then" body in quotes} {
set a {}
if 27>17 "append a x"
set a
} {x}
test if-1.13 {TclCompileIfCmd: computed "then" body} {
catch {unset x1}
catch {unset x2}
set a {}
set x1 {append a x1}
set x2 {; append a x2}
set a {}
if 1 $x1$x2
set a
} {x1x2}
test if-1.14 {TclCompileIfCmd: taking proper branch} {
set a {}
if 1<2 {set a 1}
set a
} 1
test if-1.15 {TclCompileIfCmd: taking proper branch} {
set a {}
if 1>2 {set a 1}
set a
} {}
test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long "then" body} {
catch {unset i}
set a {}
if 1<2 {
set a 1
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 3
}
set a
} 3
test if-1.17 {TclCompileIfCmd: if/elseif test in quotes} {
set a {}
list [catch {if {"0 < 3"} {set a 1}} msg] $msg
} {1 {expected boolean value but got "0 < 3"}}
test if-2.1 {TclCompileIfCmd: "elseif" after if/elseif test} {
set a {}
if 3>4 {set a 1} elseif 1 {set a 2}
set a
} {2}
# Since "else" is optional, the "elwood" below is treated as a command.
# But then there shouldn't be any additional argument words for the "if".
test if-2.2 {TclCompileIfCmd: keyword other than "elseif"} {
set a {}
catch {if 1<2 {set a 1} elwood {set a 2}} msg
set msg
} {wrong # args: extra words after "else" clause in "if" command}
test if-2.3 {TclCompileIfCmd: missing expression after "elseif"} {
set a {}
catch {if 1<2 {set a 1} elseif} msg
set msg
} {wrong # args: no expression after "elseif" argument}
test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} {
set a {}
list [catch {if 3>4 {set a 1} elseif {1>}} msg] $msg $errorInfo
} {1 {syntax error in expression "1>": premature end of expression} {syntax error in expression "1>": premature end of expression
("if" test expression)
while compiling
"if 3>4 {set a 1} elseif {1>}"}}
test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long "elseif" body} {
catch {unset i}
set a {}
if 1>2 {
set a 1
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 3
} elseif 1<2 then { #; this if arm should be taken
set a 4
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 5
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 6
}
set a
} 6
test if-3.1 {TclCompileIfCmd: "else" clause} {
set a {}
if 3>4 {set a 1} elseif {$a == "foo"} {set a 2} else {set a 3}
set a
} 3
# Since "else" is optional, the "elsex" below is treated as a command.
# But then there shouldn't be any additional argument words for the "if".
test if-3.2 {TclCompileIfCmd: keyword other than "else"} {
set a {}
catch {if 1<2 then {set a 1} elsex {set a 2}} msg
set msg
} {wrong # args: extra words after "else" clause in "if" command}
test if-3.3 {TclCompileIfCmd: missing body after "else"} {
set a {}
catch {if 2<1 {set a 1} else} msg
set msg
} {wrong # args: no script following "else" argument}
test if-3.4 {TclCompileIfCmd: error compiling body after "else"} {
set a {}
catch {if 2<1 {set a 1} else {set}} msg
set errorInfo
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
("if" else script line 1)
while compiling
"if 2<1 {set a 1} else {set}"}
test if-3.5 {TclCompileIfCmd: extra arguments after "else" argument} {
set a {}
catch {if 2<1 {set a 1} else {set a 2} or something} msg
set msg
} {wrong # args: extra words after "else" clause in "if" command}
# The following test also checks whether contained loops and other
# commands are properly relocated because a short jump must be replaced
# by a "long distance" one.
test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long "else" clause} {
catch {unset i}
set a {}
if 1>2 {
set a 1
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 3
} elseif 1==2 then { #; this if arm should be taken
set a 4
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 5
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 6
} else {
set a 7
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 8
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 9
}
set a
} 9
test if-4.1 {TclCompileIfCmd: "if" command result} {
set a {}
set a [if 3<4 {set i 27}]
set a
} 27
test if-4.2 {TclCompileIfCmd: "if" command result} {
set a {}
set a [if 3>4 {set i 27}]
set a
} {}
test if-4.3 {TclCompileIfCmd: "if" command result} {
set a {}
set a [if 0 {set i 1} elseif 1 {set i 2}]
set a
} 2
test if-4.4 {TclCompileIfCmd: "if" command result} {
set a {}
set a [if 0 {set i 1} elseif 0 {set i 2} elseif 2>5 {set i 3} else {set i 4}]
set a
} 4
test if-4.5 {TclCompileIfCmd: return value} {
if 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi}
} def
# Check "if" and computed command names.
catch {unset a}
test if-5.1 {if cmd with computed command names: missing if/elseif test} {
set z if
list [catch {$z} msg] $msg
} {1 {wrong # args: no expression after "if" argument}}
test if-5.2 {if cmd with computed command names: error in if/elseif test} {
set z if
list [catch {$z {[error "error in condition"]} foo} msg] $msg
} {1 {error in condition}}
test if-5.3 {if cmd with computed command names: error in if/elseif test} {
set z if
list [catch {$z {1+}} msg] $msg $errorInfo
} {1 {syntax error in expression "1+": premature end of expression} {syntax error in expression "1+": premature end of expression
while executing
"$z {1+}"}}
test if-5.4 {if cmd with computed command names: if/elseif test in braces} {
set z if
set a {}
$z {1<2} {set a 1}
set a
} {1}
test if-5.5 {if cmd with computed command names: if/elseif test not in braces} {
set z if
set a {}
$z 1<2 {set a 1}
set a
} {1}
test if-5.6 {if cmd with computed command names: multiline test expr} {
set z if
set a {}
$z {($tcl_platform(platform) != "foobar1") && \
($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4}
set a
} 3
test if-5.7 {if cmd with computed command names: "then" after if/elseif test} {
set z if
set a {}
$z 4>3 then {set a 1}
set a
} {1}
test if-5.8 {if cmd with computed command names: keyword other than "then" after if/elseif test} {
set z if
set a {}
catch {$z 1<2 therefore {set a 1}} msg
set msg
} {invalid command name "therefore"}
test if-5.9 {if cmd with computed command names: missing "then" body} {
set z if
set a {}
catch {$z 1<2 then} msg
set msg
} {wrong # args: no script following "then" argument}
test if-5.10 {if cmd with computed command names: error in "then" body} {
set z if
set a {}
list [catch {$z {$a!="xxx"} then {set}} msg] $msg $errorInfo
} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
invoked from within
"$z {$a!="xxx"} then {set}"}}
test if-5.11 {if cmd with computed command names: error in "then" body} {
set z if
list [catch {$z 2 then {[error "error in then clause"]}} msg] $msg
} {1 {error in then clause}}
test if-5.12 {if cmd with computed command names: "then" body in quotes} {
set z if
set a {}
$z 27>17 "append a x"
set a
} {x}
test if-5.13 {if cmd with computed command names: computed "then" body} {
set z if
catch {unset x1}
catch {unset x2}
set a {}
set x1 {append a x1}
set x2 {; append a x2}
set a {}
$z 1 $x1$x2
set a
} {x1x2}
test if-5.14 {if cmd with computed command names: taking proper branch} {
set z if
set a {}
$z 1<2 {set a 1}
set a
} 1
test if-5.15 {if cmd with computed command names: taking proper branch} {
set z if
set a {}
$z 1>2 {set a 1}
set a
} {}
test if-5.16 {if cmd with computed command names: test jumpFalse instruction replacement after long "then" body} {
set z if
catch {unset i}
set a {}
$z 1<2 {
set a 1
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 3
}
set a
} 3
test if-5.17 {if cmd with computed command names: if/elseif test in quotes} {
set z if
set a {}
list [catch {$z {"0 < 3"} {set a 1}} msg] $msg
} {1 {expected boolean value but got "0 < 3"}}
test if-6.1 {if cmd with computed command names: "elseif" after if/elseif test} {
set z if
set a {}
$z 3>4 {set a 1} elseif 1 {set a 2}
set a
} {2}
# Since "else" is optional, the "elwood" below is treated as a command.
# But then there shouldn't be any additional argument words for the "if".
test if-6.2 {if cmd with computed command names: keyword other than "elseif"} {
set z if
set a {}
catch {$z 1<2 {set a 1} elwood {set a 2}} msg
set msg
} {wrong # args: extra words after "else" clause in "if" command}
test if-6.3 {if cmd with computed command names: missing expression after "elseif"} {
set z if
set a {}
catch {$z 1<2 {set a 1} elseif} msg
set msg
} {wrong # args: no expression after "elseif" argument}
test if-6.4 {if cmd with computed command names: error in expression after "elseif"} {
set z if
set a {}
list [catch {$z 3>4 {set a 1} elseif {1>}} msg] $msg $errorInfo
} {1 {syntax error in expression "1>": premature end of expression} {syntax error in expression "1>": premature end of expression
while executing
"$z 3>4 {set a 1} elseif {1>}"}}
test if-6.5 {if cmd with computed command names: test jumpFalse instruction replacement after long "elseif" body} {
set z if
catch {unset i}
set a {}
$z 1>2 {
set a 1
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 3
} elseif 1<2 then { #; this if arm should be taken
set a 4
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 5
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 6
}
set a
} 6
test if-7.1 {if cmd with computed command names: "else" clause} {
set z if
set a {}
$z 3>4 {set a 1} elseif {$a == "foo"} {set a 2} else {set a 3}
set a
} 3
# Since "else" is optional, the "elsex" below is treated as a command.
# But then there shouldn't be any additional argument words for the "if".
test if-7.2 {if cmd with computed command names: keyword other than "else"} {
set z if
set a {}
catch {$z 1<2 then {set a 1} elsex {set a 2}} msg
set msg
} {wrong # args: extra words after "else" clause in "if" command}
test if-7.3 {if cmd with computed command names: missing body after "else"} {
set z if
set a {}
catch {$z 2<1 {set a 1} else} msg
set msg
} {wrong # args: no script following "else" argument}
test if-7.4 {if cmd with computed command names: error compiling body after "else"} {
set z if
set a {}
catch {$z 2<1 {set a 1} else {set}} msg
set errorInfo
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
invoked from within
"$z 2<1 {set a 1} else {set}"}
test if-7.5 {if cmd with computed command names: extra arguments after "else" argument} {
set z if
set a {}
catch {$z 2<1 {set a 1} else {set a 2} or something} msg
set msg
} {wrong # args: extra words after "else" clause in "if" command}
# The following test also checks whether contained loops and other
# commands are properly relocated because a short jump must be replaced
# by a "long distance" one.
test if-7.6 {if cmd with computed command names: test jumpFalse instruction replacement after long "else" clause} {
set z if
catch {unset i}
set a {}
$z 1>2 {
set a 1
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 3
} elseif 1==2 then { #; this if arm should be taken
set a 4
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 5
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 6
} else {
set a 7
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 8
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
set i [expr $i-1]
}
}
set a 9
}
set a
} 9
test if-8.1 {if cmd with computed command names: "if" command result} {
set z if
set a {}
set a [$z 3<4 {set i 27}]
set a
} 27
test if-8.2 {if cmd with computed command names: "if" command result} {
set z if
set a {}
set a [$z 3>4 {set i 27}]
set a
} {}
test if-8.3 {if cmd with computed command names: "if" command result} {
set z if
set a {}
set a [$z 0 {set i 1} elseif 1 {set i 2}]
set a
} 2
test if-8.4 {if cmd with computed command names: "if" command result} {
set z if
set a {}
set a [$z 0 {set i 1} elseif 0 {set i 2} elseif 2>5 {set i 3} else {set i 4}]
set a
} 4
test if-8.5 {if cmd with computed command names: return value} {
set z if
$z 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi}
} def
test if-9.1 {if cmd with namespace qualifiers} {
::if {1} {set x 4}
} 4
# Test for incorrect "double evaluation semantics"
test if-10.1 {delayed substitution of then body} {
set j 0
set if if
# this is not compiled
$if {[incr j] == 1} "
set result $j
"
# this will be compiled
proc p {} {
set j 0
if {[incr j]} "
set result $j
"
set result
}
append result [p]
} {00}
test if-10.2 {delayed substitution of elseif expression} {
set j 0
set if if
# this is not compiled
$if {[incr j] == 0} {
set result badthen
} elseif "$j == 1" {
set result badelseif
} else {
set result 0
}
# this will be compiled
proc p {} {
set j 0
if {[incr j] == 0} {
set result badthen
} elseif "$j == 1" {
set result badelseif
} else {
set result 0
}
set result
}
append result [p]
} {00}
test if-10.3 {delayed substitution of elseif body} {
set j 0
set if if
# this is not compiled
$if {[incr j] == 0} {
set result badthen
} elseif {1} "
set result $j
"
# this will be compiled
proc p {} {
set j 0
if {[incr j] == 0} {
set result badthen
} elseif {1} "
set result $j
"
}
append result [p]
} {00}
test if-10.4 {delayed substitution of else body} {
set j 0
if {[incr j] == 0} {
set result badthen
} else "
set result $j
"
set result
} {0}
test if-10.5 {substituted control words} {
set then then; proc then {} {return badthen}
set else else; proc else {} {return badelse}
set elseif elseif; proc elseif {} {return badelseif}
list [catch {if 1 $then {if 0 {} $elseif 1 {if 0 {} $else {list ok}}}} a] $a
} {0 ok}
test if-10.6 {double invocation of variable traces} {
set iftracecounter 0
proc iftraceproc {args} {
upvar #0 iftracecounter counter
set argc [llength $args]
set extraargs [lrange $args 0 [expr {$argc - 4}]]
set name [lindex $args [expr {$argc - 3}]]
upvar 1 $name var
if {[incr counter] % 2 == 1} {
set var "$counter oops [concat $extraargs]"
} else {
set var "$counter + [concat $extraargs]"
}
}
trace variable iftracevar r [list iftraceproc 10]
list [catch {if "$iftracevar + 20" {}} a] $a \
[catch {if "$iftracevar + 20" {}} b] $b \
[unset iftracevar iftracecounter]
} {1 {syntax error in expression "1 oops 10 + 20": extra tokens at end of expression} 0 {} {}}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/utf.test 0000644 0036047 0045461 00000025017 11737050674 013565 0 ustar dgp 771div # This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\x00"
} [bytestring "\xc0\x80"]
test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\xe0"
} [bytestring "\xc3\xa0"]
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} {
set x "\u4e4e"
} [bytestring "\xe4\xb9\x8e"]
test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} {
format %c 0x110000
} [bytestring "\xef\xbf\xbd"]
test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} {
format %c -1
} [bytestring "\xef\xbf\xbd"]
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
} {3}
test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} {
string length [bytestring "\x82\x83\x84"]
} {3}
test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} {
string length [bytestring "\xC2"]
} {1}
test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} {
string length [bytestring "\xC2\xa2"]
} {1}
test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} {
string length [bytestring "\xE2"]
} {1}
test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} {
string length [bytestring "\xE2\xA2"]
} {2}
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} {
string length [bytestring "\xE4\xb9\x8e"]
} {1}
test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} {
string length [bytestring "\xF4\xA2\xA2\xA2"]
} {4}
test utf-3.1 {Tcl_UtfCharComplete} {
} {}
testConstraint testnumutfchars [llength [info commands testnumutfchars]]
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
testnumutfchars ""
} {0}
test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars {
testnumutfchars [bytestring "\xC2\xA2"]
} {1}
test utf-4.3 {Tcl_NumUtfChars: long string} testnumutfchars {
testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"]
} {7}
test utf-4.4 {Tcl_NumUtfChars: #u0000} testnumutfchars {
testnumutfchars [bytestring "\xC0\x80"]
} {1}
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars {
testnumutfchars "" 1
} {0}
test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} testnumutfchars {
testnumutfchars [bytestring "\xC2\xA2"] 1
} {1}
test utf-4.7 {Tcl_NumUtfChars: long string, calc len} testnumutfchars {
testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1
} {7}
test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} testnumutfchars {
testnumutfchars [bytestring "\xC0\x80"] 1
} {1}
test utf-5.1 {Tcl_UtfFindFirsts} {
} {}
test utf-6.1 {Tcl_UtfNext} {
} {}
test utf-7.1 {Tcl_UtfPrev} {
} {}
test utf-8.1 {Tcl_UniCharAtIndex: index = 0} {
string index abcd 0
} {a}
test utf-8.2 {Tcl_UniCharAtIndex: index = 0} {
string index \u4e4e\u25a 0
} "\u4e4e"
test utf-8.3 {Tcl_UniCharAtIndex: index > 0} {
string index abcd 2
} {c}
test utf-8.4 {Tcl_UniCharAtIndex: index > 0} {
string index \u4e4e\u25a\xff\u543 2
} "\uff"
test utf-9.1 {Tcl_UtfAtIndex: index = 0} {
string range abcd 0 2
} {abc}
test utf-9.2 {Tcl_UtfAtIndex: index > 0} {
string range \u4e4e\u25a\xff\u543klmnop 1 5
} "\u25a\xff\u543kl"
test utf-10.1 {Tcl_UtfBackslash: dst == NULL} {
set x \n
} {
}
test utf-10.2 {Tcl_UtfBackslash: \u subst} {
set x \ua2
} [bytestring "\xc2\xa2"]
test utf-10.3 {Tcl_UtfBackslash: longer \u subst} {
set x \u4e21
} [bytestring "\xe4\xb8\xa1"]
test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} {
set x \u4e2k
} "[bytestring \xd3\xa2]k"
test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} {
set x \u4e216
} "[bytestring \xe4\xb8\xa1]6"
proc bsCheck {char num} {
global errNum
test utf-10.$errNum {backslash substitution} {
scan $char %c value
set value
} $num
incr errNum
}
set errNum 6
bsCheck \b 8
bsCheck \e 101
bsCheck \f 12
bsCheck \n 10
bsCheck \r 13
bsCheck \t 9
bsCheck \v 11
bsCheck \{ 123
bsCheck \} 125
bsCheck \[ 91
bsCheck \] 93
bsCheck \$ 36
bsCheck \ 32
bsCheck \; 59
bsCheck \\ 92
bsCheck \Ca 67
bsCheck \Ma 77
bsCheck \CMa 67
# prior to 8.3, this returned 8, as \8 as accepted as an
# octal value - but it isn't! [Bug: 3975]
bsCheck \8a 56
bsCheck \14 12
bsCheck \141 97
bsCheck b\0 98
bsCheck \x 120
bsCheck \xa 10
bsCheck \xA 10
bsCheck \x41 65
bsCheck \x541 65
bsCheck \u 117
bsCheck \uk 117
bsCheck \u41 65
bsCheck \ua 10
bsCheck \uA 10
bsCheck \340 224
bsCheck \ua1 161
bsCheck \u4e21 20001
test utf-11.1 {Tcl_UtfToUpper} {
string toupper {}
} {}
test utf-11.2 {Tcl_UtfToUpper} {
string toupper abc
} ABC
test utf-11.3 {Tcl_UtfToUpper} {
string toupper \u00e3ab
} \u00c3AB
test utf-11.4 {Tcl_UtfToUpper} {
string toupper \u01e3ab
} \u01e2AB
test utf-12.1 {Tcl_UtfToLower} {
string tolower {}
} {}
test utf-12.2 {Tcl_UtfToLower} {
string tolower ABC
} abc
test utf-12.3 {Tcl_UtfToLower} {
string tolower \u00c3AB
} \u00e3ab
test utf-12.4 {Tcl_UtfToLower} {
string tolower \u01e2AB
} \u01e3ab
test utf-13.1 {Tcl_UtfToTitle} {
string totitle {}
} {}
test utf-13.2 {Tcl_UtfToTitle} {
string totitle abc
} Abc
test utf-13.3 {Tcl_UtfToTitle} {
string totitle \u00e3ab
} \u00c3ab
test utf-13.4 {Tcl_UtfToTitle} {
string totitle \u01f3ab
} \u01f2ab
test utf-14.1 {Tcl_UtfNcasecmp} {
string compare -nocase a b
} -1
test utf-14.2 {Tcl_UtfNcasecmp} {
string compare -nocase b a
} 1
test utf-14.3 {Tcl_UtfNcasecmp} {
string compare -nocase B a
} 1
test utf-14.4 {Tcl_UtfNcasecmp} {
string compare -nocase aBcB abca
} 1
test utf-15.1 {Tcl_UniCharToUpper, negative delta} {
string toupper aA
} AA
test utf-15.2 {Tcl_UniCharToUpper, positive delta} {
string toupper \u0178\u00ff
} \u0178\u0178
test utf-15.3 {Tcl_UniCharToUpper, no delta} {
string toupper !
} !
test utf-16.1 {Tcl_UniCharToLower, negative delta} {
string tolower aA
} aa
test utf-16.2 {Tcl_UniCharToLower, positive delta} {
string tolower \u0178\u00ff\uA78D\u01c5
} \u00ff\u00ff\u0265\u01c6
test utf-17.1 {Tcl_UniCharToLower, no delta} {
string tolower !
} !
test utf-18.1 {Tcl_UniCharToTitle, add one for title} {
string totitle \u01c4
} \u01c5
test utf-18.2 {Tcl_UniCharToTitle, subtract one for title} {
string totitle \u01c6
} \u01c5
test utf-18.3 {Tcl_UniCharToTitle, subtract delta for title (positive)} {
string totitle \u017f
} \u0053
test utf-18.4 {Tcl_UniCharToTitle, subtract delta for title (negative)} {
string totitle \u00ff
} \u0178
test utf-18.5 {Tcl_UniCharToTitle, no delta} {
string totitle !
} !
test utf-19.1 {TclUniCharLen} {
list [regexp \\d abc456def foo] $foo
} {1 4}
test utf-20.1 {TclUniCharNcmp} {
} {}
test utf-21.1 {TclUniCharIsAlnum} {
# this returns 1 with Unicode 6 compliance
string is alnum \u1040\u021f\u0220
} {1}
test utf-21.2 {unicode alnum char in regc_locale.c} {
# this returns 1 with Unicode 6 compliance
list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220]
} {1 1}
test utf-21.4 {TclUniCharIsGraph} {
# [Bug 3464428]
string is graph \u0120
} {1}
test utf-21.5 {unicode graph char in regc_locale.c} {
# [Bug 3464428]
regexp {^[[:graph:]]+$} \u0120
} {1}
test utf-21.6 {TclUniCharIsGraph} {
# [Bug 3464428]
string is graph \u00a0
} {0}
test utf-21.7 {unicode graph char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:graph:]]} \u0020\u00a0\u2028\u2029
} {0}
test utf-21.8 {TclUniCharIsPrint} {
# [Bug 3464428]
string is print \u0009
} {0}
test utf-21.9 {unicode print char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:print:]]} \u0009
} {0}
test utf-21.10 {unicode print char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:print:]]} \u0009
} {0}
test utf-21.11 {TclUniCharIsControl} {
# [Bug 3464428]
string is control \u00ad
} {1}
test utf-21.12 {unicode control char in regc_locale.c} {
# [Bug 3464428]
regexp {^[[:cntrl:]]$} \u00ad
} {1}
test utf-22.1 {TclUniCharIsWordChar} {
string wordend "xyz123_bar fg" 0
} 10
test utf-22.2 {TclUniCharIsWordChar} {
string wordend "x\u5080z123_bar\u203c fg" 0
} 10
test utf-23.1 {TclUniCharIsAlpha} {
# this returns 1 with Unicode 6 compliance
string is alpha \u021f\u0220
} {1}
test utf-23.2 {unicode alpha char in regc_locale.c} {
# this returns 1 with Unicode 6 compliance
regexp {^[[:alpha:]]+$} \u021f\u0220
} {1}
test utf-24.1 {TclUniCharIsDigit} {
# this returns 1 with Unicode 6 compliance
string is digit \u1040\uabf0
} {1}
test utf-24.2 {unicode digit char in regc_locale.c} {
# this returns 1 with Unicode 6 compliance
list [regexp {^[[:digit:]]+$} \u1040\uabf0] [regexp {^\d+$} \u1040\uabf0]
} {1 1}
test utf-24.3 {TclUniCharIsSpace} {
# this returns 1 with Unicode 6 compliance
string is space \u1680\u180e
} {1}
test utf-24.4 {unicode space char in regc_locale.c} {
# this returns 1 with Unicode 6 compliance
list [regexp {^[[:space:]]+$} \u1680\u180e] [regexp {^\s+$} \u1680\u180e]
} {1 1}
testConstraint teststringobj [llength [info commands teststringobj]]
test utf-25.1 {Tcl_UniCharNcasecmp} teststringobj {
testobj freeallvars
teststringobj set 1 a
teststringobj set 2 b
teststringobj getunicode 1
teststringobj getunicode 2
string compare -nocase [teststringobj get 1] [teststringobj get 2]
} -1
test utf-25.2 {Tcl_UniCharNcasecmp} teststringobj {
testobj freeallvars
teststringobj set 1 b
teststringobj set 2 a
teststringobj getunicode 1
teststringobj getunicode 2
string compare -nocase [teststringobj get 1] [teststringobj get 2]
} 1
test utf-25.3 {Tcl_UniCharNcasecmp} teststringobj {
testobj freeallvars
teststringobj set 1 B
teststringobj set 2 a
teststringobj getunicode 1
teststringobj getunicode 2
string compare -nocase [teststringobj get 1] [teststringobj get 2]
} 1
test utf-25.4 {Tcl_UniCharNcasecmp} teststringobj {
testobj freeallvars
teststringobj set 1 aBcB
teststringobj set 2 abca
teststringobj getunicode 1
teststringobj getunicode 2
string compare -nocase [teststringobj get 1] [teststringobj get 2]
} 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
tcl8.4.20/tests/set-old.test 0000644 0036047 0045461 00000073344 11737050674 014344 0 ustar dgp 771div # Commands covered: set, unset, array
#
# This file includes the original set of tests for Tcl's set command.
# Since the set command is now compiled, a new set of tests covering
# the new implementation is in the file "set.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
proc ignore args {}
# Simple variable operations.
catch {unset a}
test set-old-1.1 {basic variable setting and unsetting} {
set a 22
} 22
test set-old-1.2 {basic variable setting and unsetting} {
set a 123
set a
} 123
test set-old-1.3 {basic variable setting and unsetting} {
set a xxx
format %s $a
} xxx
test set-old-1.4 {basic variable setting and unsetting} {
set a 44
unset a
list [catch {set a} msg] $msg
} {1 {can't read "a": no such variable}}
# Basic array operations.
catch {unset a}
set a(xyz) 2
set a(44) 3
set {a(a long name)} test
test set-old-2.1 {basic array operations} {
lsort [array names a]
} {44 {a long name} xyz}
test set-old-2.2 {basic array operations} {
set a(44)
} 3
test set-old-2.3 {basic array operations} {
set a(xyz)
} 2
test set-old-2.4 {basic array operations} {
set "a(a long name)"
} test
test set-old-2.5 {basic array operations} {
list [catch {set a(other)} msg] $msg
} {1 {can't read "a(other)": no such element in array}}
test set-old-2.6 {basic array operations} {
list [catch {set a} msg] $msg
} {1 {can't read "a": variable is array}}
test set-old-2.7 {basic array operations} {
format %s $a(44)
} 3
test set-old-2.8 {basic array operations} {
format %s $a(a long name)
} test
unset a(44)
test set-old-2.9 {basic array operations} {
lsort [array names a]
} {{a long name} xyz}
test set-old-2.10 {basic array operations} {
catch {unset b}
list [catch {set b(123)} msg] $msg
} {1 {can't read "b(123)": no such variable}}
test set-old-2.11 {basic array operations} {
catch {unset b}
set b 44
list [catch {set b(123)} msg] $msg
} {1 {can't read "b(123)": variable isn't array}}
test set-old-2.12 {basic array operations} {
list [catch {set a 14} msg] $msg
} {1 {can't set "a": variable is array}}
unset a
test set-old-2.13 {basic array operations} {
list [catch {set a(xyz)} msg] $msg
} {1 {can't read "a(xyz)": no such variable}}
# Test the set commands, and exercise the corner cases of the code
# that parses array references into two parts.
test set-old-3.1 {set command} {
list [catch {set} msg] $msg
} {1 {wrong # args: should be "set varName ?newValue?"}}
test set-old-3.2 {set command} {
list [catch {set x y z} msg] $msg
} {1 {wrong # args: should be "set varName ?newValue?"}}
test set-old-3.3 {set command} {
catch {unset a}
list [catch {set a} msg] $msg
} {1 {can't read "a": no such variable}}
test set-old-3.4 {set command} {
catch {unset a}
set a(14) 83
list [catch {set a 22} msg] $msg
} {1 {can't set "a": variable is array}}
# Test the corner-cases of parsing array names, using set and unset.
test set-old-4.1 {parsing array names} {
catch {unset a}
set a(()) 44
list [catch {array names a} msg] $msg
} {0 ()}
test set-old-4.2 {parsing array names} {
catch {unset a a(abcd}
set a(abcd 33
info exists a(abcd
} 1
test set-old-4.3 {parsing array names} {
catch {unset a a(abcd}
set a(abcd 33
list [catch {array names a} msg] $msg
} {0 {}}
test set-old-4.4 {parsing array names} {
catch {unset a abcd)}
set abcd) 33
info exists abcd)
} 1
test set-old-4.5 {parsing array names} {
set a(bcd yyy
catch {unset a}
list [catch {set a(bcd} msg] $msg
} {0 yyy}
test set-old-4.6 {parsing array names} {
catch {unset a}
set a 44
list [catch {set a(bcd test} msg] $msg
} {0 test}
# Errors in reading variables
test set-old-5.1 {errors in reading variables} {
catch {unset a}
list [catch {set a} msg] $msg
} {1 {can't read "a": no such variable}}
test set-old-5.2 {errors in reading variables} {
catch {unset a}
set a 44
list [catch {set a(18)} msg] $msg
} {1 {can't read "a(18)": variable isn't array}}
test set-old-5.3 {errors in reading variables} {
catch {unset a}
set a(6) 44
list [catch {set a(18)} msg] $msg
} {1 {can't read "a(18)": no such element in array}}
test set-old-5.4 {errors in reading variables} {
catch {unset a}
set a(6) 44
list [catch {set a} msg] $msg
} {1 {can't read "a": variable is array}}
# Errors and other special cases in writing variables
test set-old-6.1 {creating array during write} {
catch {unset a}
trace var a rwu ignore
list [catch {set a(14) 186} msg] $msg [array names a]
} {0 186 14}
test set-old-6.2 {errors in writing variables} {
catch {unset a}
set a xxx
list [catch {set a(14) 186} msg] $msg
} {1 {can't set "a(14)": variable isn't array}}
test set-old-6.3 {errors in writing variables} {
catch {unset a}
set a(100) yyy
list [catch {set a 2} msg] $msg
} {1 {can't set "a": variable is array}}
test set-old-6.4 {expanding variable size} {
catch {unset a}
list [set a short] [set a "longer name"] [set a "even longer name"] \
[set a "a much much truly longer name"]
} {short {longer name} {even longer name} {a much much truly longer name}}
# Unset command, Tcl_UnsetVar procedures
test set-old-7.1 {unset command} {
catch {unset a}; catch {unset b}; catch {unset c}; catch {unset d}
set a 44
set b 55
set c 66
set d 77
unset a b c
list [catch {set a(0) 0}] [catch {set b(0) 0}] [catch {set c(0) 0}] \
[catch {set d(0) 0}]
} {0 0 0 1}
test set-old-7.2 {unset command} {
list [catch {unset} msg] $msg
} {0 {}}
# Used to return:
#{1 {wrong # args: should be "unset ?-nocomplain? ?--? ?varName varName ...?"}}
test set-old-7.3 {unset command} {
catch {unset a}
list [catch {unset a} msg] $msg
} {1 {can't unset "a": no such variable}}
test set-old-7.4 {unset command} {
catch {unset a}
set a 44
list [catch {unset a(14)} msg] $msg
} {1 {can't unset "a(14)": variable isn't array}}
test set-old-7.5 {unset command} {
catch {unset a}
set a(0) xx
list [catch {unset a(14)} msg] $msg
} {1 {can't unset "a(14)": no such element in array}}
test set-old-7.6 {unset command} {
catch {unset a}; catch {unset b}; catch {unset c}
set a foo
set c gorp
list [catch {unset a a a(14)} msg] $msg [info exists c]
} {1 {can't unset "a": no such variable} 1}
test set-old-7.7 {unsetting globals from within procedures} {
set y 0
proc p1 {} {
global y
set z [p2]
return [list $z [catch {set y} msg] $msg]
}
proc p2 {} {global y; unset y; list [catch {set y} msg] $msg}
p1
} {{1 {can't read "y": no such variable}} 1 {can't read "y": no such variable}}
test set-old-7.8 {unsetting globals from within procedures} {
set y 0
proc p1 {} {
global y
p2
return [list [catch {set y 44} msg] $msg]
}
proc p2 {} {global y; unset y}
concat [p1] [list [catch {set y} msg] $msg]
} {0 44 0 44}
test set-old-7.9 {unsetting globals from within procedures} {
set y 0
proc p1 {} {
global y
unset y
return [list [catch {set y 55} msg] $msg]
}
concat [p1] [list [catch {set y} msg] $msg]
} {0 55 0 55}
test set-old-7.10 {unset command} {
catch {unset a}
set a(14) 22
unset a(14)
list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2
} {1 {can't read "a(14)": no such element in array} 0 {}}
test set-old-7.11 {unset command} {
catch {unset a}
set a(14) 22
unset a
list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2
} {1 {can't read "a(14)": no such variable} 0 {}}
test set-old-7.12 {unset command, -nocomplain} {
catch {unset a}
list [info exists a] [catch {unset -nocomplain a}] [info exists a]
} {0 0 0}
test set-old-7.13 {unset command, -nocomplain} {
set -nocomplain abc
list [info exists -nocomplain] [catch {unset -nocomplain}] \
[info exists -nocomplain] [catch {unset -- -nocomplain}] \
[info exists -nocomplain]
} {1 0 1 0 0}
test set-old-7.14 {unset command, --} {
set -- abc
list [info exists --] [catch {unset --}] \
[info exists --] [catch {unset -- --}] \
[info exists --]
} {1 0 1 0 0}
test set-old-7.15 {unset command, -nocomplain} {
set -nocomplain abc
set -- abc
list [info exists -nocomplain] [catch {unset -- -nocomplain}] \
[info exists -nocomplain] [info exists --] \
[catch {unset -- -nocomplain}] [info exists --] \
[catch {unset -- --}] [info exists --]
} {1 0 0 1 1 1 0 0}
test set-old-7.16 {unset command, -nocomplain} {
set -nocomplain abc
set var abc
list [info exists bogus] [catch {unset -nocomplain bogus var bogus}] \
[info exists -nocomplain] [info exists var] \
[catch {unset -nocomplain -nocomplain}] [info exists -nocomplain]
} {0 0 1 0 0 0}
test set-old-7.17 {unset command, -nocomplain (no abbreviation)} {
set -nocomp abc
list [info exists -nocomp] [catch {unset -nocomp}] [info exists -nocomp]
} {1 0 0}
test set-old-7.18 {unset command, -nocomplain (no abbreviation)} {
catch {unset -nocomp}
list [info exists -nocomp] [catch {unset -nocomp}]
} {0 1}
# Array command.
test set-old-8.1 {array command} {
list [catch {array} msg] $msg
} {1 {wrong # args: should be "array option arrayName ?arg ...?"}}
test set-old-8.2 {array command} {
list [catch {array a} msg] $msg
} {1 {wrong # args: should be "array option arrayName ?arg ...?"}}
test set-old-8.3 {array command} {
catch {unset a}
list [catch {array anymore a b} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.4 {array command} {
catch {unset a}
set a 44
list [catch {array anymore a b} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.5 {array command} {
proc foo {} {
set a 44
upvar 0 a x
list [catch {array anymore x b} msg] $msg
}
foo
} {1 {"x" isn't an array}}
test set-old-8.6 {array command} {
catch {unset a}
set a(22) 3
list [catch {array gorp a} msg] $msg
} {1 {bad option "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}}
test set-old-8.7 {array command, anymore option} {
catch {unset a}
list [catch {array anymore a x} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array anymore a x]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.9 {array command, donesearch option} {
catch {unset a}
list [catch {array donesearch a x} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.10 {array command, donesearch option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array donesearch a x]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.11 {array command, exists option} {
list [catch {array exists a b} msg] $msg
} {1 {wrong # args: should be "array exists arrayName"}}
test set-old-8.12 {array command, exists option} {
catch {unset a}
array exists a
} {0}
test set-old-8.13 {array command, exists option} {
catch {unset a}
set a(0) 1
array exists a
} {1}
test set-old-8.14 {array command, exists option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array exists a]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {0 0}
test set-old-8.15 {array command, get option} {
list [catch {array get} msg] $msg
} {1 {wrong # args: should be "array option arrayName ?arg ...?"}}
test set-old-8.16 {array command, get option} {
list [catch {array get a b c} msg] $msg
} {1 {wrong # args: should be "array get arrayName ?pattern?"}}
test set-old-8.17 {array command, get option} {
catch {unset a}
array get a
} {}
test set-old-8.18 {array command, get option} {
catch {unset a}
set a(22) 3
set {a(long name)} {}
lsort [array get a]
} {{} 22 3 {long name}}
test set-old-8.19 {array command, get option (unset variable)} {
catch {unset a}
set a(x) 3
trace var a(y) w ignore
array get a
} {x 3}
test set-old-8.20 {array command, get option, with pattern} {
catch {unset a}
set a(x1) 3
set a(x2) 4
set a(x3) 5
set a(b1) 24
set a(b2) 25
lsort [array get a x*]
} {3 4 5 x1 x2 x3}
test set-old-8.21 {array command, get option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array get a]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {0 {}}
test set-old-8.22 {array command, names option} {
catch {unset a}
set a(22) 3
list [catch {array names a 4 5} msg] $msg
} {1 {bad option "4": must be -exact, -glob, or -regexp}}
test set-old-8.23 {array command, names option} {
catch {unset a}
array names a
} {}
test set-old-8.24 {array command, names option} {
catch {unset a}
set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
list [catch {lsort [array names a]} msg] $msg
} {0 {22 Textual_name {name with spaces}}}
test set-old-8.25 {array command, names option} {
catch {unset a}
set a(22) 3; set a(33) 44;
trace var a(xxx) w ignore
list [catch {lsort [array names a]} msg] $msg
} {0 {22 33}}
test set-old-8.26 {array command, names option} {
catch {unset a}
set a(22) 3; set a(33) 44;
trace var a(xxx) w ignore
set a(xxx) value
list [catch {lsort [array names a]} msg] $msg
} {0 {22 33 xxx}}
test set-old-8.27 {array command, names option} {
catch {unset a}
set a(axy) 3
set a(bxy) 44
set a(no) yes
set a(xxx) value
list [lsort [array names a *xy]] [lsort [array names a]]
} {{axy bxy} {axy bxy no xxx}}
test set-old-8.28 {array command, names option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array names a]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {0 {}}
test set-old-8.29 {array command, nextelement option} {
list [catch {array nextelement a} msg] $msg
} {1 {wrong # args: should be "array nextelement arrayName searchId"}}
test set-old-8.30 {array command, nextelement option} {
catch {unset a}
list [catch {array nextelement a b} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.31 {array command, nextelement option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array nextelement a b]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.32 {array command, set option} {
list [catch {array set a} msg] $msg
} {1 {wrong # args: should be "array set arrayName list"}}
test set-old-8.33 {array command, set option} {
list [catch {array set a 1 2} msg] $msg
} {1 {wrong # args: should be "array set arrayName list"}}
test set-old-8.34 {array command, set option} {
list [catch {array set a "a \{ c"} msg] $msg
} {1 {unmatched open brace in list}}
test set-old-8.35 {array command, set option} {
catch {unset a}
set a 44
list [catch {array set a {a b c d}} msg] $msg
} {1 {can't set "a(a)": variable isn't array}}
test set-old-8.36 {array command, set option} {
catch {unset a}
set a(xx) yy
array set a {b c d e}
lsort [array get a]
} {b c d e xx yy}
test set-old-8.37 {array command, set option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array set a {x 0}]
}
set a(x)
}
list [catch {foo 1} msg] $msg
} {0 {}}
test set-old-8.38 {array command, set option} {
catch {unset aVaRnAmE}
array set aVaRnAmE {}
list [info exists aVaRnAmE] [catch {set aVaRnAmE} msg] $msg
} {1 1 {can't read "aVaRnAmE": variable is array}}
test set-old-8.38.1 {array command, set scalar} {
catch {unset aVaRnAmE}
set aVaRnAmE 1
list [catch {array set aVaRnAmE {}} msg] $msg
} {1 {can't array set "aVaRnAmE": variable isn't array}}
test set-old-8.38.2 {array command, set alias} {
catch {unset aVaRnAmE}
upvar 0 aVaRnAmE anAliAs
array set anAliAs {}
list [array exists aVaRnAmE] [catch {set anAliAs} msg] $msg
} {1 1 {can't read "anAliAs": variable is array}}
test set-old-8.38.3 {array command, set element alias} {
catch {unset aVaRnAmE}
list [catch {upvar 0 aVaRnAmE(elem) elemAliAs}] \
[catch {array set elemAliAs {}} msg] $msg
} {0 1 {can't array set "elemAliAs": variable isn't array}}
test set-old-8.38.4 {array command, empty set with populated array} {
catch {unset aVaRnAmE}
array set aVaRnAmE [list e1 v1 e2 v2]
array set aVaRnAmE {}
array set aVaRnAmE [list e3 v3]
list [lsort [array names aVaRnAmE]] [catch {set aVaRnAmE(e2)} msg] $msg
} {{e1 e2 e3} 0 v2}
test set-old-8.38.5 {array command, set with non-existent namespace} {
list [catch {array set bogusnamespace::var {}} msg] $msg
} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}}
test set-old-8.38.6 {array command, set with non-existent namespace} {
list [catch {array set bogusnamespace::var {a b}} msg] $msg
} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}}
test set-old-8.38.7 {array command, set with non-existent namespace} {
list [catch {array set bogusnamespace::var(0) {a b}} msg] $msg
} {1 {can't set "bogusnamespace::var(0)": variable isn't array}}
test set-old-8.39 {array command, size option} {
catch {unset a}
array size a
} {0}
test set-old-8.40 {array command, size option} {
list [catch {array size a 4} msg] $msg
} {1 {wrong # args: should be "array size arrayName"}}
test set-old-8.41 {array command, size option} {
catch {unset a}
array size a
} {0}
test set-old-8.42 {array command, size option} {
catch {unset a}
set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
list [catch {array size a} msg] $msg
} {0 3}
test set-old-8.43 {array command, size option} {
catch {unset a}
set a(22) 3; set a(xx) 44; set a(y) xxx
unset a(22) a(y) a(xx)
list [catch {array size a} msg] $msg
} {0 0}
test set-old-8.44 {array command, size option} {
catch {unset a}
set a(22) 3;
trace var a(33) rwu ignore
list [catch {array size a} msg] $msg
} {0 1}
test set-old-8.45 {array command, size option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array size a]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {0 0}
test set-old-8.46 {array command, startsearch option} {
list [catch {array startsearch a b} msg] $msg
} {1 {wrong # args: should be "array startsearch arrayName"}}
test set-old-8.47 {array command, startsearch option} {
catch {unset a}
list [catch {array startsearch a} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.48 {array command, startsearch option, array doesn't exist yet but has compiler-allocated procedure slot} {
catch {rename p ""}
proc p {x} {
if {$x==1} {
return [array startsearch a]
}
set a(x) 123
}
list [catch {p 1} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.49 {array command, statistics option} {
catch {unset a}
set a(abc) 1
set a(def) 2
set a(ghi) 3
set a(jkl) 4
set a(mno) 5
set a(pqr) 6
set a(stu) 7
set a(vwx) 8
set a(yz) 9
array statistics a
} "9 entries in table, 4 buckets
number of buckets with 0 entries: 0
number of buckets with 1 entries: 0
number of buckets with 2 entries: 3
number of buckets with 3 entries: 1
number of buckets with 4 entries: 0
number of buckets with 5 entries: 0
number of buckets with 6 entries: 0
number of buckets with 7 entries: 0
number of buckets with 8 entries: 0
number of buckets with 9 entries: 0
number of buckets with 10 or more entries: 0
average search distance for entry: 1.7"
test set-old-8.50 {array command, array names -exact on glob pattern} {
catch {unset a}
set a(1*2) 1
list [catch {array names a -exact 1*2} msg] $msg
} {0 1*2}
test set-old-8.51 {array command, array names -glob on glob pattern} {
catch {unset a}
set a(1*2) 1
set a(12) 1
set a(11) 1
list [catch {lsort [array names a -glob 1*2]} msg] $msg
} {0 {1*2 12}}
test set-old-8.52 {array command, array names -regexp on regexp pattern} {
catch {unset a}
set a(1*2) 1
set a(12) 1
set a(11) 1
list [catch {lsort [array names a -regexp ^1]} msg] $msg
} {0 {1*2 11 12}}
test set-old-8.53 {array command, array names -regexp} {
catch {unset a}
set a(-glob) 1
set a(-regexp) 1
set a(-exact) 1
list [catch {array names a -regexp} msg] $msg
} {0 -regexp}
test set-old-8.54 {array command, array names -exact} {
catch {unset a}
set a(-glob) 1
set a(-regexp) 1
set a(-exact) 1
list [catch {array names a -exact} msg] $msg
} {0 -exact}
test set-old-8.55 {array command, array names -glob} {
catch {unset a}
set a(-glob) 1
set a(-regexp) 1
set a(-exact) 1
list [catch {array names a -glob} msg] $msg
} {0 -glob}
test set-old-8.56 {array command, array statistics on a non-array} {
catch {unset a}
list [catch {array statistics a} msg] $msg
} [list 1 "\"a\" isn't an array"]
test set-old-9.1 {ids for array enumeration} {
catch {unset a}
set a(a) 1
list [array star a] [array star a] [array done a s-1-a; array star a] \
[array done a s-2-a; array d a s-3-a; array start a]
} {s-1-a s-2-a s-3-a s-1-a}
test set-old-9.2 {array enumeration} {
catch {unset a}
set a(a) 1
set a(b) 1
set a(c) 1
set x [array startsearch a]
lsort [list [array nextelement a $x] [array ne a $x] [array next a $x] \
[array next a $x] [array next a $x]]
} {{} {} a b c}
test set-old-9.3 {array enumeration} {
catch {unset a}
set a(a) 1
set a(b) 1
set a(c) 1
set x [array startsearch a]
set y [array startsearch a]
set z [array startsearch a]
lsort [list [array nextelement a $x] [array ne a $x] \
[array next a $y] [array next a $z] [array next a $y] \
[array next a $z] [array next a $y] [array next a $z] \
[array next a $y] [array next a $z] [array next a $x] \
[array next a $x]]
} {{} {} {} a a a b b b c c c}
test set-old-9.4 {array enumeration: stopping searches} {
catch {unset a}
set a(a) 1
set a(b) 1
set a(c) 1
set x [array startsearch a]
set y [array startsearch a]
set z [array startsearch a]
lsort [list [array next a $x] [array next a $x] [array next a $y] \
[array done a $z; array next a $x] \
[array done a $x; array next a $y] [array next a $y]]
} {a a b b c c}
test set-old-9.5 {array enumeration: stopping searches} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
array done a $x
list [catch {array next a $x} msg] $msg
} {1 {couldn't find search "s-1-a"}}
test set-old-9.6 {array enumeration: searches automatically stopped} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
set y [array startsearch a]
set a(b) 1
list [catch {array next a $x} msg] $msg \
[catch {array next a $y} msg2] $msg2
} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}}
test set-old-9.7 {array enumeration: searches automatically stopped} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
set y [array startsearch a]
set a(a) 2
list [catch {array next a $x} msg] $msg \
[catch {array next a $y} msg2] $msg2
} {0 a 0 a}
test set-old-9.8 {array enumeration: searches automatically stopped} {
catch {unset a}
set a(a) 1
set a(c) 2
set x [array startsearch a]
set y [array startsearch a]
catch {unset a(c)}
list [catch {array next a $x} msg] $msg \
[catch {array next a $y} msg2] $msg2
} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}}
test set-old-9.9 {array enumeration: searches automatically stopped} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
set y [array startsearch a]
catch {unset a(c)}
list [catch {array next a $x} msg] $msg \
[catch {array next a $y} msg2] $msg2
} {0 a 0 a}
test set-old-9.10 {array enumeration: searches automatically stopped} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
set y [array startsearch a]
trace var a(b) r {}
list [catch {array next a $x} msg] $msg \
[catch {array next a $y} msg2] $msg2
} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}}
test set-old-9.11 {array enumeration: searches automatically stopped} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
set y [array startsearch a]
trace var a(a) r {}
list [catch {array next a $x} msg] $msg \
[catch {array next a $y} msg2] $msg2
} {0 a 0 a}
test set-old-9.12 {array enumeration with traced undefined elements} {
catch {unset a}
set a(a) 1
trace var a(b) r {}
set x [array startsearch a]
lsort [list [array next a $x] [array next a $x]]
} {{} a}
test set-old-10.1 {array enumeration errors} {
list [catch {array start} msg] $msg
} {1 {wrong # args: should be "array option arrayName ?arg ...?"}}
test set-old-10.2 {array enumeration errors} {
list [catch {array start a b} msg] $msg
} {1 {wrong # args: should be "array startsearch arrayName"}}
test set-old-10.3 {array enumeration errors} {
catch {unset a}
list [catch {array start a} msg] $msg
} {1 {"a" isn't an array}}
test set-old-10.4 {array enumeration errors} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
list [catch {array next a} msg] $msg
} {1 {wrong # args: should be "array nextelement arrayName searchId"}}
test set-old-10.5 {array enumeration errors} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
list [catch {array next a b c} msg] $msg
} {1 {wrong # args: should be "array nextelement arrayName searchId"}}
test set-old-10.6 {array enumeration errors} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
list [catch {array next a a-1-a} msg] $msg
} {1 {illegal search identifier "a-1-a"}}
test set-old-10.7 {array enumeration errors} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
list [catch {array next a sx1-a} msg] $msg
} {1 {illegal search identifier "sx1-a"}}
test set-old-10.8 {array enumeration errors} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
list [catch {array next a s--a} msg] $msg
} {1 {illegal search identifier "s--a"}}
test set-old-10.9 {array enumeration errors} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
list [catch {array next a s-1-b} msg] $msg
} {1 {search identifier "s-1-b" isn't for variable "a"}}
test set-old-10.10 {array enumeration errors} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
list [catch {array next a s-1ba} msg] $msg
} {1 {illegal search identifier "s-1ba"}}
test set-old-10.11 {array enumeration errors} {
catch {unset a}
set a(a) 1
set x [array startsearch a]
list [catch {array next a s-2-a} msg] $msg
} {1 {couldn't find search "s-2-a"}}
test set-old-10.12 {array enumeration errors} {
list [catch {array done a} msg] $msg
} {1 {wrong # args: should be "array donesearch arrayName searchId"}}
test set-old-10.13 {array enumeration errors} {
list [catch {array done a b c} msg] $msg
} {1 {wrong # args: should be "array donesearch arrayName searchId"}}
test set-old-10.14 {array enumeration errors} {
list [catch {array done a b} msg] $msg
} {1 {illegal search identifier "b"}}
test set-old-10.15 {array enumeration errors} {
list [catch {array anymore a} msg] $msg
} {1 {wrong # args: should be "array anymore arrayName searchId"}}
test set-old-10.16 {array enumeration errors} {
list [catch {array any a b c} msg] $msg
} {1 {wrong # args: should be "array anymore arrayName searchId"}}
test set-old-10.17 {array enumeration errors} {
catch {unset a}
set a(0) 44
list [catch {array any a bogus} msg] $msg
} {1 {illegal search identifier "bogus"}}
# Array enumeration with "anymore" option
test set-old-11.1 {array anymore option} {
catch {unset a}
set a(a) 1
set a(b) 2
set a(c) 3
array startsearch a
lsort [list [array anymore a s-1-a] [array next a s-1-a] \
[array anymore a s-1-a] [array next a s-1-a] \
[array anymore a s-1-a] [array next a s-1-a] \
[array anymore a s-1-a] [array next a s-1-a]]
} {{} 0 1 1 1 a b c}
test set-old-11.2 {array anymore option} {
catch {unset a}
set a(a) 1
set a(b) 2
set a(c) 3
array startsearch a
lsort [list [array next a s-1-a] [array next a s-1-a] \
[array anymore a s-1-a] [array next a s-1-a] \
[array next a s-1-a] [array anymore a s-1-a]]
} {{} 0 1 a b c}
# Special check to see that the value of a variable is handled correctly
# if it is returned as the result of a procedure (must not free the variable
# string while deleting the call frame). Errors will only be detected if
# a memory consistency checker such as Purify is being used.
test set-old-12.1 {cleanup on procedure return} {
proc foo {} {
set x 12345
}
foo
} 12345
test set-old-12.2 {cleanup on procedure return} {
proc foo {} {
set x(1) 23456
}
foo
} 23456
# Must delete variables when done, since these arrays get used as
# scalars by other tests.
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset aVaRnAmE}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/socket.test 0000644 0036047 0045461 00000130105 12052456744 014251 0 ustar dgp 771div # Commands tested in this file: socket.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1994-1996 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.
# Running socket tests with a remote server:
# ------------------------------------------
#
# Some tests in socket.test depend on the existence of a remote server to
# which they connect. The remote server must be an instance of tcltest and it
# must run the script found in the file "remote.tcl" in this directory. You
# can start the remote server on any machine reachable from the machine on
# which you want to run the socket tests, by issuing:
#
# tcltest remote.tcl -port 2048 # Or choose another port number.
#
# If the machine you are running the remote server on has several IP
# interfaces, you can choose which interface the server listens on for
# connections by specifying the -address command line flag, so:
#
# tcltest remote.tcl -address your.machine.com
#
# These options can also be set by environment variables. On Unix, you can
# type these commands to the shell from which the remote server is started:
#
# shell% setenv serverPort 2048
# shell% setenv serverAddress your.machine.com
#
# and subsequently you can start the remote server with:
#
# tcltest remote.tcl
#
# to have it listen on port 2048 on the interface your.machine.com.
#
# When the server starts, it prints out a detailed message containing its
# configuration information, and it will block until killed with a Ctrl-C.
# Once the remote server exists, you can run the tests in socket.test with
# the server by setting two Tcl variables:
#
# % set remoteServerIP
# % set remoteServerPort 2048
#
# These variables are also settable from the environment. On Unix, you can:
#
# shell% setenv remoteServerIP machine.where.server.runs
# shell% senetv remoteServerPort 2048
#
# The preamble of the socket.test file checks to see if the variables are set
# either in Tcl or in the environment; if they are, it attempts to connect to
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
package require tcltest 2
namespace import -force ::tcltest::*
# Some tests require the testthread and exec commands
testConstraint testthread [llength [info commands testthread]]
testConstraint exec [llength [info commands exec]]
# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
#
if {![info exists remoteServerIP]} {
if {[info exists env(remoteServerIP)]} {
set remoteServerIP $env(remoteServerIP)
}
}
if {![info exists remoteServerPort]} {
if {[info exists env(remoteServerIP)]} {
set remoteServerPort $env(remoteServerPort)
} else {
if {[info exists remoteServerIP]} {
set remoteServerPort 2048
}
}
}
#
# Check if we're supposed to do tests against the remote server
#
set doTestsWithRemoteServer 1
if {![info exists remoteServerIP]} {
set remoteServerIP 127.0.0.1
}
if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
set remoteServerPort 2048
}
# Attempt to connect to a remote server if one is already running. If it
# is not running or for some other reason the connect fails, attempt to
# start the remote server on the local host listening on port 2048. This
# is only done on platforms that support exec (i.e. not on the Mac). On
# platforms that do not support exec, the remote server must be started
# by the user before running the tests.
set remoteProcChan ""
set commandSocket ""
if {$doTestsWithRemoteServer} {
catch {close $commandSocket}
if {[catch {set commandSocket [socket $remoteServerIP \
$remoteServerPort]}] != 0} {
if {[info commands exec] == ""} {
set noRemoteTestReason "can't exec"
set doTestsWithRemoteServer 0
} else {
set remoteServerIP 127.0.0.1
# Be *extra* careful in case this file is sourced from
# a directory other than the current one...
set remoteFile [file join [pwd] [file dirname [info script]] \
remote.tcl]
if {[catch {set remoteProcChan \
[open "|[list [interpreter] $remoteFile \
-serverIsSilent \
-port $remoteServerPort \
-address $remoteServerIP]" \
w+]} \
msg] == 0} {
after 1000
if {[catch {set commandSocket [socket $remoteServerIP \
$remoteServerPort]} msg] == 0} {
fconfigure $commandSocket -translation crlf -buffering line
} else {
set noRemoteTestReason $msg
set doTestsWithRemoteServer 0
}
} else {
set noRemoteTestReason "$msg [interpreter]"
set doTestsWithRemoteServer 0
}
}
} else {
fconfigure $commandSocket -translation crlf -buffering line
}
}
# Some tests are run only if we are doing testing against a remote server.
set ::tcltest::testConstraints(doTestsWithRemoteServer) $doTestsWithRemoteServer
if {$doTestsWithRemoteServer == 0} {
if {[string first s $::tcltest::verbose] != -1} {
puts "Skipping tests with remote server. See tests/socket.test for"
puts "information on how to run remote server."
puts "Reason for not doing remote tests: $noRemoteTestReason"
}
}
#
# If we do the tests, define a command to send a command to the
# remote server.
#
if {$doTestsWithRemoteServer == 1} {
proc sendCommand {c} {
global commandSocket
if {[eof $commandSocket]} {
error "remote server disappeared"
}
if {[catch {puts $commandSocket $c} msg]} {
error "remote server disappaered: $msg"
}
if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} {
error "remote server disappeared: $msg"
}
set resp ""
while {1} {
set line [gets $commandSocket]
if {[eof $commandSocket]} {
error "remote server disappaered"
}
if {[string compare $line "--Marker--Marker--Marker--"] == 0} {
if {[string compare [lindex $resp 0] error] == 0} {
error [lindex $resp 1]
} else {
return [lindex $resp 1]
}
} else {
append resp $line "\n"
}
}
}
}
test socket-1.1 {arg parsing for socket command} {socket} {
list [catch {socket -server} msg] $msg
} {1 {no argument given for -server option}}
test socket-1.2 {arg parsing for socket command} {socket} {
list [catch {socket -server foo} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.3 {arg parsing for socket command} {socket} {
list [catch {socket -myaddr} msg] $msg
} {1 {no argument given for -myaddr option}}
test socket-1.4 {arg parsing for socket command} {socket} {
list [catch {socket -myaddr 127.0.0.1} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.5 {arg parsing for socket command} {socket} {
list [catch {socket -myport} msg] $msg
} {1 {no argument given for -myport option}}
test socket-1.6 {arg parsing for socket command} {socket} {
list [catch {socket -myport xxxx} msg] $msg
} {1 {expected integer but got "xxxx"}}
test socket-1.7 {arg parsing for socket command} {socket} {
list [catch {socket -myport 2522} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.8 {arg parsing for socket command} {socket} {
list [catch {socket -froboz} msg] $msg
} {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}}
test socket-1.9 {arg parsing for socket command} {socket} {
list [catch {socket -server foo -myport 2521 3333} msg] $msg
} {1 {Option -myport is not valid for servers}}
test socket-1.10 {arg parsing for socket command} {socket} {
list [catch {socket host 2528 -junk} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.11 {arg parsing for socket command} {socket} {
list [catch {socket -server callback 2520 --} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.12 {arg parsing for socket command} {socket} {
list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}
test socket-1.13 {arg parsing for socket command} {socket} {
list [catch {socket -async -server} msg] $msg
} {1 {cannot set -async option for server sockets}}
test socket-1.14 {arg parsing for socket command} {socket} {
list [catch {socket -server foo -async} msg] $msg
} {1 {cannot set -async option for server sockets}}
set path(script) [makeFile {} script]
test socket-2.1 {tcp connection} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timed_out"]
set f [socket -server accept 0]
proc accept {file addr port} {
global x
set x done
close $file
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
puts $x
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
gets $f listen
if {[catch {socket 127.0.0.1 $listen} msg]} {
set x $msg
} else {
lappend x [gets $f]
close $msg
}
lappend x [gets $f]
close $f
set x
} {ready done {}}
if [info exists port] {
incr port
} else {
set port [expr 2048 + [pid]%1024]
}
test socket-2.2 {tcp connection with client port specified} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file] $port"
close $file
set x done
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
gets $f listen
global port
if {[catch {socket -myport $port 127.0.0.1 $listen} sock]} {
set x $sock
close [socket 127.0.0.1 $listen]
puts stderr $sock
} else {
puts $sock hello
flush $sock
lappend x [gets $f]
close $sock
}
close $f
set x
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 2000 "set x done"]
set f [socket -server accept 2830]
proc accept {file addr port} {
global x
puts "[gets $file] $addr"
close $file
set x done
}
puts ready
vwait x
after cancel $timer
close $f
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} {
set x $sock
} else {
puts $sock hello
flush $sock
lappend x [gets $f]
close $sock
}
close $f
set x
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 2000 "set x done"]
set f [socket -server accept -myaddr 127.0.0.1 0]
proc accept {file addr port} {
global x
puts "[gets $file]"
close $file
set x done
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
gets $f listen
if {[catch {socket 127.0.0.1 $listen} sock]} {
set x $sock
} else {
puts $sock hello
flush $sock
lappend x [gets $f]
close $sock
}
close $f
set x
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file]"
close $file
set x done
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
gets $f listen
if {[catch {socket 127.0.0.1 $listen} sock]} {
set x $sock
} else {
puts $sock hello
flush $sock
lappend x [gets $f]
close $sock
}
close $f
set x
} {ready hello}
test socket-2.6 {tcp connection} {socket} {
set status ok
if {![catch {set sock [socket 127.0.0.1 2833]}]} {
if {![catch {gets $sock}]} {
set status broken
}
close $sock
}
set status
} ok
test socket-2.7 {echo server, one line} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
set f [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -translation lf -buffering line
}
proc echo {s} {
set l [gets $s]
if {[eof $s]} {
global x
close $s
set x done
} else {
puts $s $l
}
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
puts $x
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
gets $f listen
set s [socket 127.0.0.1 $listen]
fconfigure $s -buffering line -translation lf
puts $s "hello abcdefghijklmnop"
after 1000
set x [gets $s]
close $s
set y [gets $f]
close $f
list $x $y
} {{hello abcdefghijklmnop} done}
removeFile script
test socket-2.8 {echo server, loop 50 times, single connection} -constraints {socket stdio} -setup {
set path(script) [makeFile {
set f [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
}
proc echo {s} {
global i
set l [gets $s]
if {[eof $s]} {
global x
close $s
set x done
} else {
incr i
puts $s $l
}
}
set i 0
puts ready
puts [lindex [fconfigure $f -sockname] 2]
set timer [after 20000 "set x done"]
vwait x
after cancel $timer
close $f
puts "done $i"
} script]
} -body {
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
gets $f listen
set s [socket 127.0.0.1 $listen]
fconfigure $s -buffering line
catch {
for {set x 0} {$x < 50} {incr x} {
puts $s "hello abcdefghijklmnop"
gets $s
}
}
close $s
catch {set x [gets $f]}
close $f
set x
} -cleanup {
removeFile script
} -result {done 50}
set path(script) [makeFile {} script]
test socket-2.9 {socket conflict} {socket stdio} {
set s [socket -server accept 0]
file delete $path(script)
set f [open $path(script) w]
puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
after 100
set x [list [catch {close $f} msg]]
regsub "\n.*$" $msg {} msg ; # cut part of the error message containing the port number
lappend x $msg
close $s
set x
} {1 {couldn't open socket: address already in use}}
test socket-2.10 {close on accept, accepted socket lives} {socket} {
set done 0
set timer [after 20000 "set done timed_out"]
set ss [socket -server accept 0]
proc accept {s a p} {
global ss
close $ss
fileevent $s readable "readit $s"
fconfigure $s -trans lf
}
proc readit {s} {
global done
gets $s
close $s
set done 1
}
set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
puts $cs hello
close $cs
vwait done
after cancel $timer
set done
} 1
test socket-2.11 {detecting new data} {socket} {
proc accept {s a p} {
global sock
set sock $s
}
set s [socket -server accept 0]
set sock ""
set s2 [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
vwait sock
puts $s2 one
flush $s2
after 500
fconfigure $sock -blocking 0
set result a:[gets $sock]
lappend result b:[gets $sock]
fconfigure $sock -blocking 1
puts $s2 two
flush $s2
after 500
fconfigure $sock -blocking 0
lappend result c:[gets $sock]
fconfigure $sock -blocking 1
close $s2
close $s
close $sock
set result
} {a:one b: c:two}
test socket-3.1 {socket conflict} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set f [socket -server accept 0]
puts ready
puts [lindex [fconfigure $f -sockname] 2]
gets stdin
close $f
}
close $f
set f [open "|[list [interpreter] $path(script)]" r+]
gets $f
gets $f listen
set x [list [catch {socket -server accept $listen} msg] \
$msg]
puts $f bye
close $f
set x
} {1 {couldn't open socket: address already in use}}
test socket-3.2 {server with several clients} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set t1 [after 30000 "set x timed_out"]
set t2 [after 31000 "set x timed_out"]
set t3 [after 32000 "set x timed_out"]
set counter 0
set s [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
}
proc echo {s} {
global x
set l [gets $s]
if {[eof $s]} {
close $s
set x done
} else {
puts $s $l
}
}
puts ready
puts [lindex [fconfigure $s -sockname] 2]
vwait x
after cancel $t1
vwait x
after cancel $t2
vwait x
after cancel $t3
close $s
puts $x
}
close $f
set f [open "|[list [interpreter] $path(script)]" r+]
set x [gets $f]
gets $f listen
set s1 [socket 127.0.0.1 $listen]
fconfigure $s1 -buffering line
set s2 [socket 127.0.0.1 $listen]
fconfigure $s2 -buffering line
set s3 [socket 127.0.0.1 $listen]
fconfigure $s3 -buffering line
for {set i 0} {$i < 100} {incr i} {
puts $s1 hello,s1
gets $s1
puts $s2 hello,s2
gets $s2
puts $s3 hello,s3
gets $s3
}
close $s1
close $s2
close $s3
lappend x [gets $f]
close $f
set x
} {ready done}
test socket-4.1 {server with several clients} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set port [gets stdin]
set s [socket 127.0.0.1 $port]
fconfigure $s -buffering line
for {set i 0} {$i < 100} {incr i} {
puts $s hello
gets $s
}
close $s
puts bye
gets stdin
}
close $f
set p1 [open "|[list [interpreter] $path(script)]" r+]
fconfigure $p1 -buffering line
set p2 [open "|[list [interpreter] $path(script)]" r+]
fconfigure $p2 -buffering line
set p3 [open "|[list [interpreter] $path(script)]" r+]
fconfigure $p3 -buffering line
proc accept {s a p} {
fconfigure $s -buffering line
fileevent $s readable [list echo $s]
}
proc echo {s} {
global x
set l [gets $s]
if {[eof $s]} {
close $s
set x done
} else {
puts $s $l
}
}
set t1 [after 30000 "set x timed_out"]
set t2 [after 31000 "set x timed_out"]
set t3 [after 32000 "set x timed_out"]
set s [socket -server accept 0]
set listen [lindex [fconfigure $s -sockname] 2]
puts $p1 $listen
puts $p2 $listen
puts $p3 $listen
vwait x
vwait x
vwait x
after cancel $t1
after cancel $t2
after cancel $t3
close $s
set l ""
lappend l [list p1 [gets $p1] $x]
lappend l [list p2 [gets $p2] $x]
lappend l [list p3 [gets $p3] $x]
puts $p1 bye
puts $p2 bye
puts $p3 bye
close $p1
close $p2
close $p3
set l
} {{p1 bye done} {p2 bye done} {p3 bye done}}
test socket-4.2 {byte order problems, socket numbers, htons} {socket} {
set x ok
if {[catch {socket -server dodo 0x3000} msg]} {
set x $msg
} else {
close $msg
}
set x
} ok
test socket-5.1 {byte order problems, socket numbers, htons} \
{socket unixOnly notRoot} {
set x {couldn't open socket: not owner}
if {![catch {socket -server dodo 0x1} msg]} {
set x {htons problem, should be disallowed, are you running as SU?}
close $msg
}
set x
} {couldn't open socket: not owner}
test socket-5.2 {byte order problems, socket numbers, htons} {socket} {
set x {couldn't open socket: port number too high}
if {![catch {socket -server dodo 0x10000} msg]} {
set x {port resolution problem, should be disallowed}
close $msg
}
set x
} {couldn't open socket: port number too high}
test socket-5.3 {byte order problems, socket numbers, htons} \
{socket unixOnly notRoot} {
set x {couldn't open socket: not owner}
if {![catch {socket -server dodo 21} msg]} {
set x {htons problem, should be disallowed, are you running as SU?}
close $msg
}
set x
} {couldn't open socket: not owner}
test socket-6.1 {accept callback error} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
gets stdin port
socket 127.0.0.1 $port
}
close $f
set f [open "|[list [interpreter] $path(script)]" r+]
proc bgerror args {
global x
set x $args
}
proc accept {s a p} {expr 10 / 0}
set s [socket -server accept 0]
puts $f [lindex [fconfigure $s -sockname] 2]
close $f
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
close $s
rename bgerror {}
set x
} {{divide by zero}}
test socket-7.1 {testing socket specific options} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set ss [socket -server accept 0]
proc accept args {
global x
set x done
}
puts ready
puts [lindex [fconfigure $ss -sockname] 2]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
gets $f listen
set s [socket 127.0.0.1 $listen]
set p [fconfigure $s -peername]
close $s
close $f
set l ""
lappend l [string compare [lindex $p 0] 127.0.0.1]
lappend l [string compare [lindex $p 2] $listen]
lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set ss [socket -server accept 2821]
proc accept args {
global x
set x done
}
puts ready
puts [lindex [fconfigure $ss -sockname] 2]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
gets $f listen
set s [socket 127.0.0.1 $listen]
set p [fconfigure $s -sockname]
close $s
close $f
list [llength $p] \
[regexp {^(127\.0\.0\.1|0\.0\.0\.0)$} [lindex $p 0]] \
[expr {[lindex $p 2] == $listen}]
} {3 1 0}
test socket-7.3 {testing socket specific options} {socket} {
set s [socket -server accept 0]
set l [fconfigure $s]
close $s
update
llength $l
} 14
test socket-7.4 {testing socket specific options} {socket} {
set s [socket -server accept 0]
proc accept {s a p} {
global x
set x [fconfigure $s -sockname]
close $s
}
set listen [lindex [fconfigure $s -sockname] 2]
set s1 [socket [info hostname] $listen]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
close $s
close $s1
set l ""
lappend l [expr {[lindex $x 2] == $listen}] [llength $x]
} {1 3}
test socket-7.5 {testing socket specific options} {socket unixOrPc} {
set s [socket -server accept 0]
proc accept {s a p} {
global x
set x [fconfigure $s -sockname]
close $s
}
set listen [lindex [fconfigure $s -sockname] 2]
set s1 [socket 127.0.0.1 $listen]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
close $s
close $s1
set l ""
lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x]
} {127.0.0.1 1 3}
test socket-8.1 {testing -async flag on sockets} {socket} {
# NOTE: This test may fail on some Solaris 2.4 systems. If it does,
# check that you have these patches installed (using showrev -p):
#
# 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
# 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
# 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
# 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
# 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01,
# 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03
#
# If after installing these patches you are still experiencing a
# problem, please email jyl@eng.sun.com. We have not observed this
# failure on Solaris 2.5, so another option (instead of installing
# these patches) is to upgrade to Solaris 2.5.
set s [socket -server accept 0]
proc accept {s a p} {
global x
puts $s bye
close $s
set x done
}
set s1 [socket -async [info hostname] [lindex [fconfigure $s -sockname] 2]]
vwait x
set z [gets $s1]
close $s
close $s1
set z
} bye
test socket-9.1 {testing spurious events} {socket} {
set len 0
set spurious 0
set done 0
proc readlittle {s} {
global spurious done len
set l [read $s 1]
if {[string length $l] == 0} {
if {![eof $s]} {
incr spurious
} else {
close $s
set done 1
}
} else {
incr len [string length $l]
}
}
proc accept {s a p} {
fconfigure $s -buffering none -blocking off
fileevent $s readable [list readlittle $s]
}
set s [socket -server accept 0]
set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
puts -nonewline $c 01234567890123456789012345678901234567890123456789
close $c
set timer [after 10000 "set done timed_out"]
vwait done
after cancel $timer
close $s
list $spurious $len
} {0 50}
test socket-9.2 {testing async write, fileevents, flush on close} {socket} {
set firstblock ""
for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
set secondblock ""
for {set i 0} {$i < 16} {incr i} {
set secondblock "b$secondblock$secondblock"
}
set l [socket -server accept 0]
proc accept {s a p} {
fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
-buffering line
fileevent $s readable "readable $s"
}
proc readable {s} {
set l [gets $s]
fileevent $s readable {}
after 1000 respond $s
}
proc respond {s} {
global firstblock
puts -nonewline $s $firstblock
after 1000 writedata $s
}
proc writedata {s} {
global secondblock
puts -nonewline $s $secondblock
close $s
}
set s [socket [info hostname] [lindex [fconfigure $l -sockname] 2]]
fconfigure $s -blocking 0 -trans lf -buffering line
set count 0
puts $s hello
proc readit {s} {
global count done
set l [read $s]
incr count [string length $l]
if {[eof $s]} {
close $s
set done 1
}
}
fileevent $s readable "readit $s"
set timer [after 10000 "set done timed_out"]
vwait done
after cancel $timer
close $l
set count
} 65566
test socket-9.3 {testing EOF stickyness} {socket} {
proc count_to_eof {s} {
global count done timer
set l [gets $s]
if {[eof $s]} {
incr count
if {$count > 9} {
close $s
set done true
set count {eof is sticky}
after cancel $timer
}
}
}
proc timerproc {} {
global done count c
set done true
set count {timer went off, eof is not sticky}
close $c
}
set count 0
set done false
proc write_then_close {s} {
puts $s bye
close $s
}
proc accept {s a p} {
fconfigure $s -buffering line -translation lf
fileevent $s writable "write_then_close $s"
}
set s [socket -server accept 0]
set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
fconfigure $c -blocking off -buffering line -translation lf
fileevent $c readable "count_to_eof $c"
set timer [after 1000 timerproc]
vwait done
close $s
set count
} {eof is sticky}
removeFile script
test socket-10.1 {testing socket accept callback error handling} {socket} {
set goterror 0
proc bgerror args {global goterror; set goterror 1}
set s [socket -server accept 0]
proc accept {s a p} {close $s; error}
set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
vwait goterror
close $s
close $c
set goterror
} 1
test socket-11.1 {tcp connection} {socket doTestsWithRemoteServer} {
sendCommand {
set socket9_1_test_server [socket -server accept 2834]
proc accept {s a p} {
puts $s done
close $s
}
}
set s [socket $remoteServerIP 2834]
set r [gets $s]
close $s
sendCommand {close $socket9_1_test_server}
set r
} done
test socket-11.2 {client specifies its port} {socket doTestsWithRemoteServer} {
if {[info exists port]} {
incr port
} else {
set port [expr 2048 + [pid]%1024]
}
sendCommand {
set socket9_2_test_server [socket -server accept 2835]
proc accept {s a p} {
puts $s $p
close $s
}
}
set s [socket -myport $port $remoteServerIP 2835]
set r [gets $s]
close $s
sendCommand {close $socket9_2_test_server}
if {$r == $port} {
set result ok
} else {
set result broken
}
set result
} ok
test socket-11.3 {trying to connect, no server} {socket doTestsWithRemoteServer} {
set status ok
if {![catch {set s [socket $remoteServerIp 2836]}]} {
if {![catch {gets $s}]} {
set status broken
}
close $s
}
set status
} ok
test socket-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} {
sendCommand {
set socket10_6_test_server [socket -server accept 2836]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line -translation crlf
}
proc echo {s} {
set l [gets $s]
if {[eof $s]} {
close $s
} else {
puts $s $l
}
}
}
set f [socket $remoteServerIP 2836]
fconfigure $f -translation crlf -buffering line
puts $f hello
set r [gets $f]
close $f
sendCommand {close $socket10_6_test_server}
set r
} hello
test socket-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} {
sendCommand {
set socket10_7_test_server [socket -server accept 2836]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line -translation crlf
}
proc echo {s} {
set l [gets $s]
if {[eof $s]} {
close $s
} else {
puts $s $l
}
}
}
set f [socket $remoteServerIP 2836]
fconfigure $f -translation crlf -buffering line
for {set cnt 0} {$cnt < 50} {incr cnt} {
puts $f "hello, $cnt"
if {[string compare [gets $f] "hello, $cnt"] != 0} {
break
}
}
close $f
sendCommand {close $socket10_7_test_server}
set cnt
} 50
test socket-11.6 {socket conflict} {socket doTestsWithRemoteServer} {
set s1 [socket -server accept 2836]
if {[catch {set s2 [socket -server accept 2836]} msg]} {
set result [list 1 $msg]
} else {
set result [list 0 [lindex [fconfigure $s2 -sockname] 2]]
close $s2
}
close $s1
set result
} {1 {couldn't open socket: address already in use}}
test socket-11.7 {server with several clients} {socket doTestsWithRemoteServer} {
sendCommand {
set socket10_9_test_server [socket -server accept 2836]
proc accept {s a p} {
fconfigure $s -buffering line
fileevent $s readable [list echo $s]
}
proc echo {s} {
set l [gets $s]
if {[eof $s]} {
close $s
} else {
puts $s $l
}
}
}
set s1 [socket $remoteServerIP 2836]
fconfigure $s1 -buffering line
set s2 [socket $remoteServerIP 2836]
fconfigure $s2 -buffering line
set s3 [socket $remoteServerIP 2836]
fconfigure $s3 -buffering line
for {set i 0} {$i < 100} {incr i} {
puts $s1 hello,s1
gets $s1
puts $s2 hello,s2
gets $s2
puts $s3 hello,s3
gets $s3
}
close $s1
close $s2
close $s3
sendCommand {close $socket10_9_test_server}
set i
} 100
test socket-11.8 {client with several servers} {socket doTestsWithRemoteServer} {
sendCommand {
set s1 [socket -server "accept 4003" 4003]
set s2 [socket -server "accept 4004" 4004]
set s3 [socket -server "accept 4005" 4005]
proc accept {mp s a p} {
puts $s $mp
close $s
}
}
set s1 [socket $remoteServerIP 4003]
set s2 [socket $remoteServerIP 4004]
set s3 [socket $remoteServerIP 4005]
set l ""
lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \
[gets $s3] [gets $s3] [eof $s3]
close $s1
close $s2
close $s3
sendCommand {
close $s1
close $s2
close $s3
}
set l
} {4003 {} 1 4004 {} 1 4005 {} 1}
test socket-11.9 {accept callback error} {socket doTestsWithRemoteServer} {
set s [socket -server accept 2836]
proc accept {s a p} {expr 10 / 0}
proc bgerror args {
global x
set x $args
}
if {[catch {sendCommand {
set peername [fconfigure $callerSocket -peername]
set s [socket [lindex $peername 0] 2836]
close $s
}} msg]} {
close $s
error $msg
}
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
close $s
rename bgerror {}
set x
} {{divide by zero}}
test socket-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} {
sendCommand {
set socket10_12_test_server [socket -server accept 2836]
proc accept {s a p} {close $s}
}
set s [socket $remoteServerIP 2836]
set p [fconfigure $s -peername]
set n [fconfigure $s -sockname]
set l ""
lappend l [lindex $p 2] [llength $p] [llength $p]
close $s
sendCommand {close $socket10_12_test_server}
set l
} {2836 3 3}
test socket-11.11 {testing spurious events} {socket doTestsWithRemoteServer} {
sendCommand {
set socket10_13_test_server [socket -server accept 2836]
proc accept {s a p} {
fconfigure $s -translation "auto lf"
after 100 writesome $s
}
proc writesome {s} {
for {set i 0} {$i < 100} {incr i} {
puts $s "line $i from remote server"
}
close $s
}
}
set len 0
set spurious 0
set done 0
proc readlittle {s} {
global spurious done len
set l [read $s 1]
if {[string length $l] == 0} {
if {![eof $s]} {
incr spurious
} else {
close $s
set done 1
}
} else {
incr len [string length $l]
}
}
set c [socket $remoteServerIP 2836]
fileevent $c readable "readlittle $c"
set timer [after 40000 "set done timed_out"]
vwait done
after cancel $timer
sendCommand {close $socket10_13_test_server}
list $spurious $len $done
} {0 2690 1}
test socket-11.12 {testing EOF stickyness} {socket doTestsWithRemoteServer} {
set counter 0
set done 0
proc count_up {s} {
global counter done after_id
set l [gets $s]
if {[eof $s]} {
incr counter
if {$counter > 9} {
set done {EOF is sticky}
after cancel $after_id
close $s
}
}
}
proc timed_out {} {
global c done
set done {timed_out, EOF is not sticky}
close $c
}
sendCommand {
set socket10_14_test_server [socket -server accept 2836]
proc accept {s a p} {
after 100 close $s
}
}
set c [socket $remoteServerIP 2836]
fileevent $c readable [list count_up $c]
set after_id [after 1000 timed_out]
vwait done
sendCommand {close $socket10_14_test_server}
set done
} {EOF is sticky}
test socket-11.13 {testing async write, async flush, async close} \
{socket doTestsWithRemoteServer} {
proc readit {s} {
global count done
set l [read $s]
incr count [string length $l]
if {[eof $s]} {
close $s
set done 1
}
}
sendCommand {
set firstblock ""
for {set i 0} {$i < 5} {incr i} {
set firstblock "a$firstblock$firstblock"
}
set secondblock ""
for {set i 0} {$i < 16} {incr i} {
set secondblock "b$secondblock$secondblock"
}
set l [socket -server accept 2845]
proc accept {s a p} {
fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
-buffering line
fileevent $s readable "readable $s"
}
proc readable {s} {
set l [gets $s]
fileevent $s readable {}
after 1000 respond $s
}
proc respond {s} {
global firstblock
puts -nonewline $s $firstblock
after 1000 writedata $s
}
proc writedata {s} {
global secondblock
puts -nonewline $s $secondblock
close $s
}
}
set s [socket $remoteServerIP 2845]
fconfigure $s -blocking 0 -trans lf -buffering line
set count 0
puts $s hello
fileevent $s readable "readit $s"
set timer [after 10000 "set done timed_out"]
vwait done
after cancel $timer
sendCommand {close $l}
set count
} 65566
set path(script1) [makeFile {} script1]
set path(script2) [makeFile {} script2]
test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} {
file delete $path(script1)
file delete $path(script2)
# Script1 is just a 10 second delay. If the server socket
# is inherited, it will be held open for 10 seconds
set f [open $path(script1) w]
puts $f {
after 10000 exit
vwait forever
}
close $f
# Script2 creates the server socket, launches script1,
# waits a second, and exits. The server socket will now
# be closed unless script1 inherited it.
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts -nonewline $f {
set f [socket -server accept 0]
puts [lindex [fconfigure $f -sockname] 2]
proc accept { file addr port } {
close $file
}
exec $tcltest }
puts $f [list $path(script1) &]
puts $f {
close $f
after 1000 exit
vwait forever
}
close $f
# Launch script2 and wait 5 seconds
### exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" r]
gets $p listen
after 5000 { set ok_to_proceed 1 }
vwait ok_to_proceed
# If we can still connect to the server, the socket got inherited.
if {[catch {socket 127.0.0.1 $listen} msg]} {
set x {server socket was not inherited}
} else {
close $msg
set x {server socket was inherited}
}
close $p
set x
} {server socket was not inherited}
test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} {
file delete $path(script1)
file delete $path(script2)
# Script1 is just a 20 second delay. If the server socket
# is inherited, it will be held open for 10 seconds
set f [open $path(script1) w]
puts $f {
after 20000 exit
vwait forever
}
close $f
# Script2 opens the client socket and writes to it. It then
# launches script1 and exits. If the child process inherited the
# client socket, the socket will still be open.
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts -nonewline $f {
gets stdin port
set f [socket 127.0.0.1 $port]
exec $tcltest }
puts $f [list $path(script1) &]
puts $f {
puts $f testing
flush $f
after 1000 exit
vwait forever
}
close $f
# Create the server socket
set server [socket -server accept 0]
proc accept { file host port } {
# When the client connects, establish the read handler
global server
close $server
fileevent $file readable [list getdata $file]
fconfigure $file -buffering line -blocking 0
return
}
proc getdata { file } {
# Read handler on the accepted socket.
global x
global failed
set status [catch {read $file} data]
if {$status != 0} {
set x {read failed, error was $data}
catch { close $file }
} elseif {[string compare {} $data]} {
} elseif {[fblocked $file]} {
} elseif {[eof $file]} {
if {$failed} {
set x {client socket was inherited}
} else {
set x {client socket was not inherited}
}
catch { close $file }
} else {
set x {impossible case}
catch { close $file }
}
return
}
# If the socket doesn't hit end-of-file in 10 seconds, the
# script1 process must have inherited the client.
set failed 0
after 10000 [list set failed 1]
# Launch the script2 process
### exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" w]
puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
vwait x
if {!$failed} {
vwait failed
}
close $p
set x
} {client socket was not inherited}
test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} {
file delete $path(script1)
file delete $path(script2)
set f [open $path(script1) w]
puts $f {
after 10000 exit
vwait forever
}
close $f
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts -nonewline $f {
set server [socket -server accept 0]
puts stdout [lindex [fconfigure $server -sockname] 2]
proc accept { file host port } }
puts $f \{
puts -nonewline $f {
global tcltest
puts $file {test data on socket}
exec $tcltest }
puts $f [list $path(script1) &]
puts $f {
after 1000 exit
}
puts $f \}
puts $f {
vwait forever
}
close $f
# Launch the script2 process and connect to it. See how long
# the socket stays open
## exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" r]
gets $p listen
after 1000 set ok_to_proceed 1
vwait ok_to_proceed
set f [socket 127.0.0.1 $listen]
fconfigure $f -buffering full -blocking 0
fileevent $f readable [list getdata $f]
# If the socket is still open after 5 seconds, the script1 process
# must have inherited the accepted socket.
set failed 0
after 5000 set failed 1
proc getdata { file } {
# Read handler on the client socket.
global x
global failed
set status [catch {read $file} data]
if {$status != 0} {
set x {read failed, error was $data}
catch { close $file }
} elseif {[string compare {} $data]} {
} elseif {[fblocked $file]} {
} elseif {[eof $file]} {
if {$failed} {
set x {accepted socket was inherited}
} else {
set x {accepted socket was not inherited}
}
catch { close $file }
} else {
set x {impossible case}
catch { close $file }
}
return
}
vwait x
close $p
set x
} {accepted socket was not inherited}
test socket-13.1 {Testing use of shared socket between two threads} \
-constraints {socket testthread} -setup {
threadReap
set path(script) [makeFile {
set f [socket -server accept 0]
set listen [lindex [fconfigure $f -sockname] 2]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
}
proc echo {s} {
global i
set l [gets $s]
if {[eof $s]} {
global x
close $s
set x done
} else {
incr i
puts $s $l
}
}
set i 0
vwait x
close $f
# thread cleans itself up.
testthread exit
} script]
} -body {
# create a thread
set serverthread [testthread create [list source $path(script) ] ]
update
set port [testthread send $serverthread {set listen}]
update
after 1000
set s [socket 127.0.0.1 $port]
fconfigure $s -buffering line
catch {
puts $s "hello"
gets $s result
}
close $s
update
after 2000
lappend result [threadReap]
} -cleanup {
removeFile script
} -result {hello 1}
removeFile script1
removeFile script2
# cleanup
if {[string match sock* $commandSocket] == 1} {
puts $commandSocket exit
flush $commandSocket
}
catch {close $commandSocket}
catch {close $remoteProcChan}
::tcltest::cleanupTests
flush stdout
return
tcl8.4.20/tests/timer.test 0000644 0036047 0045461 00000033611 11737050674 014106 0 ustar dgp 771div # This file contains a collection of tests for the procedures in the
# file tclTimer.c, which includes the "after" Tcl command. Sourcing
# this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
test timer-1.1 {Tcl_CreateTimerHandler procedure} {
foreach i [after info] {
after cancel $i
}
set x ""
foreach i {100 200 1000 50 150} {
after $i lappend x $i
}
after 200
update
set x
} {50 100 150 200}
test timer-2.1 {Tcl_DeleteTimerHandler procedure} {
foreach i [after info] {
after cancel $i
}
set x ""
foreach i {100 200 300 50 150} {
after $i lappend x $i
}
after cancel lappend x 150
after cancel lappend x 50
after 200
update
set x
} {100 200}
# No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested
# above.
test timer-3.1 {TimerHandlerEventProc procedure: event masks} {
set x start
after 100 { set x fired }
update idletasks
set result $x
after 200
update
lappend result $x
} {start fired}
test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} {
foreach i [after info] {
after cancel $i
}
foreach i {200 600 1000} {
after $i lappend x $i
}
after 200
set result ""
set x ""
update
lappend result $x
after 400
update
lappend result $x
after 400
update
lappend result $x
} {200 {200 600} {200 600 1000}}
test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} {
foreach i [after info] {
after cancel $i
}
set x {}
after 100 lappend x 100
set i [after 300 lappend x 300]
after 200 after cancel $i
after 400
update
set x
} 100
test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} {
foreach i [after info] {
after cancel $i
}
set x {}
after 100 lappend x a
after 200 lappend x b
after 300 lappend x c
after 300
vwait x
set x
} {a b c}
test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
foreach i [after info] {
after cancel $i
}
set x {}
after 100 {lappend x a; after 0 lappend x b}
after 100
vwait x
set x
} a
test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
foreach i [after info] {
after cancel $i
}
set x {}
after 100 {lappend x a; after 100 lappend x b; after 100}
after 100
vwait x
set result $x
vwait x
lappend result $x
} {a {a b}}
# No tests for Tcl_DoWhenIdle: it's already tested by other tests
# below.
test timer-4.1 {Tcl_CancelIdleCall procedure} {
foreach i [after info] {
after cancel $i
}
set x before
set y before
set z before
after idle set x after1
after idle set y after2
after idle set z after3
after cancel set y after2
update idletasks
concat $x $y $z
} {after1 before after3}
test timer-4.2 {Tcl_CancelIdleCall procedure} {
foreach i [after info] {
after cancel $i
}
set x before
set y before
set z before
after idle set x after1
after idle set y after2
after idle set z after3
after cancel set x after1
update idletasks
concat $x $y $z
} {before after2 after3}
test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} {
foreach i [after info] {
after cancel $i
}
set x 1
set y 23
after idle {incr x; after idle {incr x; after idle {incr x}}}
after idle {incr y}
vwait x
set result "$x $y"
update idletasks
lappend result $x
} {2 24 4}
test timer-6.1 {Tcl_AfterCmd procedure, basics} {
list [catch {after} msg] $msg
} {1 {wrong # args: should be "after option ?arg arg ...?"}}
test timer-6.2 {Tcl_AfterCmd procedure, basics} {
list [catch {after 2x} msg] $msg
} {1 {expected integer but got "2x"}}
test timer-6.3 {Tcl_AfterCmd procedure, basics} {
list [catch {after gorp} msg] $msg
} {1 {bad argument "gorp": must be cancel, idle, info, or a number}}
test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
set x before
after 400 {set x after}
after 200
update
set y $x
after 400
update
list $y $x
} {before after}
test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
set x before
after 300 set x after
after 200
update
set y $x
after 200
update
list $y $x
} {before after}
test timer-6.6 {Tcl_AfterCmd procedure, cancel option} {
list [catch {after cancel} msg] $msg
} {1 {wrong # args: should be "after cancel id|command"}}
test timer-6.7 {Tcl_AfterCmd procedure, cancel option} {
after cancel after#1
} {}
test timer-6.8 {Tcl_AfterCmd procedure, cancel option} {
after cancel {foo bar}
} {}
test timer-6.9 {Tcl_AfterCmd procedure, cancel option} {
foreach i [after info] {
after cancel $i
}
set x before
set y [after 100 set x after]
after cancel $y
after 200
update
set x
} {before}
test timer-6.10 {Tcl_AfterCmd procedure, cancel option} {
foreach i [after info] {
after cancel $i
}
set x before
after 100 set x after
after cancel {set x after}
after 200
update
set x
} {before}
test timer-6.11 {Tcl_AfterCmd procedure, cancel option} {
foreach i [after info] {
after cancel $i
}
set x before
after 100 set x after
set id [after 300 set x after]
after cancel $id
after 200
update
set y $x
set x cleared
after 200
update
list $y $x
} {after cleared}
test timer-6.12 {Tcl_AfterCmd procedure, cancel option} {
foreach i [after info] {
after cancel $i
}
set x first
after idle lappend x second
after idle lappend x third
set i [after idle lappend x fourth]
after cancel {lappend x second}
after cancel $i
update idletasks
set x
} {first third}
test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} {
foreach i [after info] {
after cancel $i
}
set x first
after idle lappend x second
after idle lappend x third
set i [after idle lappend x fourth]
after cancel lappend x second
after cancel $i
update idletasks
set x
} {first third}
test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} {
foreach i [after info] {
after cancel $i
}
set id [
after 100 {
set x done
after cancel $id
}
]
vwait x
} {}
test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} {
foreach i [after info] {
after cancel $i
}
interp create x
x eval {set a before; set b before; after idle {set a a-after};
after idle {set b b-after}}
set result [llength [x eval after info]]
lappend result [llength [after info]]
after cancel {set b b-after}
set a aaa
set b bbb
x eval {after cancel set a a-after}
update idletasks
lappend result $a $b [x eval {list $a $b}]
interp delete x
set result
} {2 0 aaa bbb {before b-after}}
test timer-6.16 {Tcl_AfterCmd procedure, idle option} {
list [catch {after idle} msg] $msg
} {1 {wrong # args: should be "after idle script script ..."}}
test timer-6.17 {Tcl_AfterCmd procedure, idle option} {
set x before
after idle {set x after}
set y $x
update idletasks
list $y $x
} {before after}
test timer-6.18 {Tcl_AfterCmd procedure, idle option} {
set x before
after idle set x after
set y $x
update idletasks
list $y $x
} {before after}
set event1 [after idle event 1]
set event2 [after 1000 event 2]
interp create x
set childEvent [x eval {after idle event in child}]
test timer-6.19 {Tcl_AfterCmd, info option} {
lsort [after info]
} [lsort "$event1 $event2"]
test timer-6.20 {Tcl_AfterCmd, info option} {
list [catch {after info a b} msg] $msg
} {1 {wrong # args: should be "after info ?id?"}}
test timer-6.21 {Tcl_AfterCmd, info option} {
list [catch {after info $childEvent} msg] $msg
} "1 {event \"$childEvent\" doesn't exist}"
test timer-6.22 {Tcl_AfterCmd, info option} {
list [after info $event1] [after info $event2]
} {{{event 1} idle} {{event 2} timer}}
after cancel $event1
after cancel $event2
interp delete x
test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after 1 "set x ab\0cd"
after 10
update
string length $x
} {5}
test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after 1 set x ab\0cd
after 10
update
string length $x
} {5}
test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after 1 set x ab\0cd
after cancel "set x ab\0ef"
set x [llength [after info]]
foreach i [after info] {
after cancel $i
}
set x
} {1}
test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after 1 set x ab\0cd
after cancel set x ab\0ef
set y [llength [after info]]
foreach i [after info] {
after cancel $i
}
set y
} {1}
test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after idle "set x ab\0cd"
update
string length $x
} {5}
test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after idle set x ab\0cd
update
string length $x
} {5}
test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
set id junk
set id [after 10 set x ab\0cd]
update
set y [string length [lindex [lindex [after info $id] 0] 2]]
foreach i [after info] {
after cancel $i
}
set y
} {5}
set event [after idle foo bar]
scan $event after#%d id
test timer-7.1 {GetAfterEvent procedure} {
list [catch {after info xfter#$id} msg] $msg
} "1 {event \"xfter#$id\" doesn't exist}"
test timer-7.2 {GetAfterEvent procedure} {
list [catch {after info afterx$id} msg] $msg
} "1 {event \"afterx$id\" doesn't exist}"
test timer-7.3 {GetAfterEvent procedure} {
list [catch {after info after#ab} msg] $msg
} {1 {event "after#ab" doesn't exist}}
test timer-7.4 {GetAfterEvent procedure} {
list [catch {after info after#} msg] $msg
} {1 {event "after#" doesn't exist}}
test timer-7.5 {GetAfterEvent procedure} {
list [catch {after info after#${id}x} msg] $msg
} "1 {event \"after#${id}x\" doesn't exist}"
test timer-7.6 {GetAfterEvent procedure} {
list [catch {after info afterx[expr $id+1]} msg] $msg
} "1 {event \"afterx[expr $id+1]\" doesn't exist}"
after cancel $event
test timer-8.1 {AfterProc procedure} {
set x before
proc foo {} {
set x untouched
after 100 {set x after}
after 200
update
return $x
}
list [foo] $x
} {untouched after}
test timer-8.2 {AfterProc procedure} {
catch {rename bgerror {}}
proc bgerror msg {
global x errorInfo
set x [list $msg $errorInfo]
}
set x empty
after 100 {error "After error"}
after 200
set y $x
update
catch {rename bgerror {}}
list $y $x
} {empty {{After error} {After error
while executing
"error "After error""
("after" script)}}}
test timer-8.3 {AfterProc procedure, deleting handler from itself} {
foreach i [after info] {
after cancel $i
}
proc foo {} {
global x
set x {}
foreach i [after info] {
lappend x [after info $i]
}
after cancel foo
}
after idle foo
after 1000 {error "I shouldn't ever have executed"}
update idletasks
set x
} {{{error "I shouldn't ever have executed"} timer}}
test timer-8.4 {AfterProc procedure, deleting handler from itself} {
foreach i [after info] {
after cancel $i
}
proc foo {} {
global x
set x {}
foreach i [after info] {
lappend x [after info $i]
}
after cancel foo
}
after 1000 {error "I shouldn't ever have executed"}
after idle foo
update idletasks
set x
} {{{error "I shouldn't ever have executed"} timer}}
foreach i [after info] {
after cancel $i
}
# No test for FreeAfterPtr, since it is already tested above.
test timer-9.1 {AfterCleanupProc procedure} {
catch {interp delete x}
interp create x
x eval {after 200 {
lappend x after
puts "part 1: this message should not appear"
}}
after 200 {lappend x after2}
x eval {after 200 {
lappend x after3
puts "part 2: this message should not appear"
}}
after 200 {lappend x after4}
x eval {after 200 {
lappend x after5
puts "part 3: this message should not appear"
}}
interp delete x
set x before
after 300
update
set x
} {before after2 after4}
test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup {
interp create slave
slave eval namespace export after
slave eval namespace eval foo namespace import ::after
} -body {
slave eval foo::after 1
slave eval namespace origin foo::after
} -cleanup {
# Bug will cause crash here; would cause failure otherwise
interp delete slave
} -result ::after
test timer-11.2 {Bug 1350293: [after] negative argument} \
-body {
set l {}
after 100 {lappend l 100; set done 1}
after -1 {lappend l -1}
vwait done
set l
} \
-result {-1 100}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/lreplace.test 0000644 0036047 0045461 00000010171 11737050674 014551 0 ustar dgp 771div # Commands covered: lreplace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test lreplace-1.1 {lreplace command} {
lreplace {1 2 3 4 5} 0 0 a
} {a 2 3 4 5}
test lreplace-1.2 {lreplace command} {
lreplace {1 2 3 4 5} 1 1 a
} {1 a 3 4 5}
test lreplace-1.3 {lreplace command} {
lreplace {1 2 3 4 5} 2 2 a
} {1 2 a 4 5}
test lreplace-1.4 {lreplace command} {
lreplace {1 2 3 4 5} 3 3 a
} {1 2 3 a 5}
test lreplace-1.5 {lreplace command} {
lreplace {1 2 3 4 5} 4 4 a
} {1 2 3 4 a}
test lreplace-1.6 {lreplace command} {
lreplace {1 2 3 4 5} 4 5 a
} {1 2 3 4 a}
test lreplace-1.7 {lreplace command} {
lreplace {1 2 3 4 5} -1 -1 a
} {a 1 2 3 4 5}
test lreplace-1.8 {lreplace command} {
lreplace {1 2 3 4 5} 2 end a b c d
} {1 2 a b c d}
test lreplace-1.9 {lreplace command} {
lreplace {1 2 3 4 5} 0 3
} {5}
test lreplace-1.10 {lreplace command} {
lreplace {1 2 3 4 5} 0 4
} {}
test lreplace-1.11 {lreplace command} {
lreplace {1 2 3 4 5} 0 1
} {3 4 5}
test lreplace-1.12 {lreplace command} {
lreplace {1 2 3 4 5} 2 3
} {1 2 5}
test lreplace-1.13 {lreplace command} {
lreplace {1 2 3 4 5} 3 end
} {1 2 3}
test lreplace-1.14 {lreplace command} {
lreplace {1 2 3 4 5} -1 4 a b c
} {a b c}
test lreplace-1.15 {lreplace command} {
lreplace {a b "c c" d e f} 3 3
} {a b {c c} e f}
test lreplace-1.16 {lreplace command} {
lreplace { 1 2 3 4 5} 0 0 a
} {a 2 3 4 5}
test lreplace-1.17 {lreplace command} {
lreplace {1 2 3 4 "5 6"} 4 4 a
} {1 2 3 4 a}
test lreplace-1.18 {lreplace command} {
lreplace {1 2 3 4 {5 6}} 4 4 a
} {1 2 3 4 a}
test lreplace-1.19 {lreplace command} {
lreplace {1 2 3 4} 2 end x y z
} {1 2 x y z}
test lreplace-1.20 {lreplace command} {
lreplace {1 2 3 4} end end a
} {1 2 3 a}
test lreplace-1.21 {lreplace command} {
lreplace {1 2 3 4} end 3 a
} {1 2 3 a}
test lreplace-1.22 {lreplace command} {
lreplace {1 2 3 4} end end
} {1 2 3}
test lreplace-1.23 {lreplace command} {
lreplace {1 2 3 4} 2 -1 xy
} {1 2 xy 3 4}
test lreplace-1.24 {lreplace command} {
lreplace {1 2 3 4} end -1 z
} {1 2 3 z 4}
test lreplace-1.25 {lreplace command} {
concat \"[lreplace {\}\ hello} end end]\"
} {"\}\ "}
test lreplace-1.26 {lreplace command} {
catch {unset foo}
set foo {a b}
list [set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]]
} {a {} {}}
test lreplace-2.1 {lreplace errors} {
list [catch lreplace msg] $msg
} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}}
test lreplace-2.2 {lreplace errors} {
list [catch {lreplace a b} msg] $msg
} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}}
test lreplace-2.3 {lreplace errors} {
list [catch {lreplace x a 10} msg] $msg
} {1 {bad index "a": must be integer or end?-integer?}}
test lreplace-2.4 {lreplace errors} {
list [catch {lreplace x 10 x} msg] $msg
} {1 {bad index "x": must be integer or end?-integer?}}
test lreplace-2.5 {lreplace errors} {
list [catch {lreplace x 10 1x} msg] $msg
} {1 {bad index "1x": must be integer or end?-integer?}}
test lreplace-2.6 {lreplace errors} {
list [catch {lreplace x 3 2} msg] $msg
} {1 {list doesn't contain element 3}}
test lreplace-2.7 {lreplace errors} {
list [catch {lreplace x 1 1} msg] $msg
} {1 {list doesn't contain element 1}}
test lreplace-3.1 {lreplace won't modify shared argument objects} {
proc p {} {
lreplace "a b c" 1 1 "x y"
return "a b c"
}
p
} "a b c"
# cleanup
catch {unset foo}
::tcltest::cleanupTests
return
tcl8.4.20/tests/source.test 0000644 0036047 0045461 00000014171 12052456744 014265 0 ustar dgp 771div # Commands covered: source
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
# Contributions from Don Porter, NIST, 2003. (not subject to US copyright)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
namespace eval ::tcl::test::source {
namespace import ::tcltest::test
namespace import ::tcltest::testConstraint
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::customMatch
test source-1.1 {source command} -setup {
set x "old x value"
set y "old y value"
set z "old z value"
set sourcefile [makeFile {
set x 22
set y 33
set z 44
} source.file]
} -body {
source $sourcefile
list $x $y $z
} -cleanup {
removeFile source.file
} -result {22 33 44}
test source-1.2 {source command} -setup {
set sourcefile [makeFile {list result} source.file]
} -body {
source $sourcefile
} -cleanup {
removeFile source.file
} -result result
test source-1.3 {source command} -setup {
set sourcefile [makeFile {} source.file]
set fd [open $sourcefile w]
fconfigure $fd -translation lf
puts $fd "list a b c \\"
puts $fd "d e f"
close $fd
} -body {
source $sourcefile
} -cleanup {
removeFile source.file
} -result {a b c d e f}
proc ListGlobMatch {expected actual} {
if {[llength $expected] != [llength $actual]} {
return 0
}
foreach e $expected a $actual {
if {![string match $e $a]} {
return 0
}
}
return 1
}
customMatch listGlob [namespace which ListGlobMatch]
test source-2.3 {source error conditions} -setup {
set sourcefile [makeFile {
set x 146
error "error in sourced file"
set y $x
} source.file]
} -body {
list [catch {source $sourcefile} msg] $msg $::errorInfo
} -cleanup {
removeFile source.file
} -match listGlob -result [list 1 {error in sourced file} \
{error in sourced file
while executing
"error "error in sourced file""
(file "*source.file" line 3)
invoked from within
"source $sourcefile"}]
test source-2.4 {source error conditions} -setup {
set sourcefile [makeFile {break} source.file]
} -body {
source $sourcefile
} -cleanup {
removeFile source.file
} -returnCodes break
test source-2.5 {source error conditions} -setup {
set sourcefile [makeFile {continue} source.file]
} -body {
source $sourcefile
} -cleanup {
removeFile source.file
} -returnCodes continue
test source-2.6 {source error conditions} -setup {
set sourcefile [makeFile {} _non_existent_]
removeFile _non_existent_
} -body {
list [catch {source $sourcefile} msg] $msg $::errorCode
} -match listGlob -result [list 1 \
{couldn't read file "*_non_existent_": no such file or directory} \
{POSIX ENOENT {no such file or directory}}]
test source-2.7 {utf-8 with BOM} -setup {
set sourcefile [makeFile {} source.file]
set saveencoding [encoding system]
} -body {
encoding system utf-8
set out [open $sourcefile w]
puts $out "\ufeffset y new-y"
close $out
set y old-y
source $sourcefile
return $y
} -cleanup {
removeFile $sourcefile
encoding system $saveencoding
} -result {new-y}
test source-3.1 {return in middle of source file} -setup {
set sourcefile [makeFile {
set x new-x
return allDone
set y new-y
} source.file]
} -body {
set x old-x
set y old-y
set z [source $sourcefile]
list $x $y $z
} -cleanup {
removeFile source.file
} -result {new-x old-y allDone}
test source-3.2 {return with special code etc.} -setup {
set sourcefile [makeFile {
set x new-x
return -code break "Silly result"
set y new-y
} source.file]
} -body {
source $sourcefile
} -cleanup {
removeFile source.file
} -returnCodes break -result {Silly result}
test source-3.3 {return with special code etc.} -setup {
set sourcefile [makeFile {
set x new-x
return -code error "Simulated error"
set y new-y
} source.file]
} -body {
list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode
} -cleanup {
removeFile source.file
} -result {1 {Simulated error} {Simulated error
while executing
"source $sourcefile"} NONE}
test source-3.4 {return with special code etc.} -setup {
set sourcefile [makeFile {
set x new-x
return -code error -errorinfo "Simulated errorInfo stuff"
set y new-y
} source.file]
} -body {
list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode
} -cleanup {
removeFile source.file
} -result {1 {} {Simulated errorInfo stuff
invoked from within
"source $sourcefile"} NONE}
test source-3.5 {return with special code etc.} -setup {
set sourcefile [makeFile {
set x new-x
return -code error -errorinfo "Simulated errorInfo stuff" \
-errorcode {a b c}
set y new-y
} source.file]
} -body {
list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode
} -cleanup {
removeFile source.file
} -result {1 {} {Simulated errorInfo stuff
invoked from within
"source $sourcefile"} {a b c}}
test source-6.1 {source is binary ok} -setup {
# Note [makeFile] writes in the system encoding.
# [source] defaults to reading in the system encoding.
set sourcefile [makeFile [list set x "a b\0c"] source.file]
} -body {
set x {}
source $sourcefile
string length $x
} -cleanup {
removeFile source.file
} -result 5
test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} -setup {
set sourcefile [makeFile "set x ab\32c" source.file]
} -body {
set x {}
source $sourcefile
string length $x
} -cleanup {
removeFile source.file
} -result 2
cleanupTests
}
namespace delete ::tcl::test::source
return
tcl8.4.20/tests/httpold.test 0000644 0036047 0045461 00000017264 11737050674 014452 0 ustar dgp 771div # Commands covered: http_config, http_get, http_wait, http_reset
#
# This file contains a collection of tests for the http script library.
# Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {[catch {package require http 1.0}]} {
if {[info exists httpold]} {
catch {puts "Cannot load http 1.0 package"}
::tcltest::cleanupTests
return
} else {
catch {puts "Running http 1.0 tests in slave interp"}
set interp [interp create httpold]
$interp eval [list set httpold "running"]
$interp eval [list set argv $argv]
$interp eval [list source [info script]]
interp delete $interp
::tcltest::cleanupTests
return
}
}
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}
##
## The httpd script implement a stub http server
##
source [file join [file dirname [info script]] httpd]
set port 8010
if [catch {httpd_init $port} listen] {
puts "Cannot start http server, http test skipped"
unset port
::tcltest::cleanupTests
return
}
test httpold-1.1 {http_config} {
http_config
} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}
test httpold-1.2 {http_config} {
http_config -proxyfilter
} httpProxyRequired
test httpold-1.3 {http_config} {
catch {http_config -junk}
} 1
test httpold-1.4 {http_config} {
http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
set x [http_config]
http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \
-useragent "Tcl http client package 1.0"
set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
test httpold-1.5 {http_config} {
catch {http_config -proxyhost {} -junk 8080}
} 1
test httpold-2.1 {http_reset} {
catch {http_reset http#1}
} 0
test httpold-3.1 {http_get} {
catch {http_get -bogus flag}
} 1
test httpold-3.2 {http_get} {
catch {http_get http:junk} err
set err
} {Unsupported URL: http:junk}
set url [info hostname]:$port
test httpold-3.3 {http_get} {
set token [http_get $url]
http_data $token
} "HTTP/1.0 TEST
Hello, World!
GET /
"
set tail /a/b/c
set url [info hostname]:$port/a/b/c
set binurl [info hostname]:$port/binary
test httpold-3.4 {http_get} {
set token [http_get $url]
http_data $token
} "HTTP/1.0 TEST
Hello, World!
GET $tail
"
proc selfproxy {host} {
global port
return [list [info hostname] $port]
}
test httpold-3.5 {http_get} {
http_config -proxyfilter selfproxy
set token [http_get $url]
http_config -proxyfilter httpProxyRequired
http_data $token
} "HTTP/1.0 TEST
Hello, World!
GET http://$url
"
test httpold-3.6 {http_get} {
http_config -proxyfilter bogus
set token [http_get $url]
http_config -proxyfilter httpProxyRequired
http_data $token
} "HTTP/1.0 TEST
Hello, World!
GET $tail
"
test httpold-3.7 {http_get} {
set token [http_get $url -headers {Pragma no-cache}]
http_data $token
} "HTTP/1.0 TEST
Hello, World!
GET $tail
"
test httpold-3.8 {http_get} {
set token [http_get $url -query Name=Value&Foo=Bar]
http_data $token
} "HTTP/1.0 TEST
Hello, World!
POST $tail
Query
- Name
- Value
- Foo
- Bar
"
test httpold-3.9 {http_get} {
set token [http_get $url -validate 1]
http_code $token
} "HTTP/1.0 200 OK"
test httpold-4.1 {httpEvent} {
set token [http_get $url]
upvar #0 $token data
array set meta $data(meta)
expr ($data(totalsize) == $meta(Content-Length))
} 1
test httpold-4.2 {httpEvent} {
set token [http_get $url]
upvar #0 $token data
array set meta $data(meta)
string compare $data(type) [string trim $meta(Content-Type)]
} 0
test httpold-4.3 {httpEvent} {
set token [http_get $url]
http_code $token
} {HTTP/1.0 200 Data follows}
test httpold-4.4 {httpEvent} {
set testfile [makeFile "" testfile]
set out [open $testfile w]
set token [http_get $url -channel $out]
close $out
set in [open $testfile]
set x [read $in]
close $in
removeFile $testfile
set x
} "HTTP/1.0 TEST
Hello, World!
GET $tail
"
test httpold-4.5 {httpEvent} {
set testfile [makeFile "" testfile]
set out [open $testfile w]
set token [http_get $url -channel $out]
close $out
upvar #0 $token data
removeFile $testfile
expr $data(currentsize) == $data(totalsize)
} 1
test httpold-4.6 {httpEvent} {
set testfile [makeFile "" testfile]
set out [open $testfile w]
set token [http_get $binurl -channel $out]
close $out
set in [open $testfile]
fconfigure $in -translation binary
set x [read $in]
close $in
removeFile $testfile
set x
} "$bindata$binurl"
proc myProgress {token total current} {
global progress httpLog
if {[info exists httpLog] && $httpLog} {
puts "progress $total $current"
}
set progress [list $total $current]
}
if 0 {
# This test hangs on Windows95 because the client never gets EOF
set httpLog 1
test httpold-4.6 {httpEvent} {
set token [http_get $url -blocksize 50 -progress myProgress]
set progress
} {111 111}
}
test httpold-4.7 {httpEvent} {
set token [http_get $url -progress myProgress]
set progress
} {111 111}
test httpold-4.8 {httpEvent} {
set token [http_get $url]
http_status $token
} {ok}
test httpold-4.9 {httpEvent} {
set token [http_get $url -progress myProgress]
http_code $token
} {HTTP/1.0 200 Data follows}
test httpold-4.10 {httpEvent} {
set token [http_get $url -progress myProgress]
http_size $token
} {111}
test httpold-4.11 {httpEvent} {
set token [http_get $url -timeout 1 -command {#}]
http_reset $token
http_status $token
} {reset}
test httpold-4.12 {httpEvent} {
update
set x {}
after 500 {lappend x ok}
set token [http_get $url -timeout 1 -command {lappend x fail}]
vwait x
list [http_status $token] $x
} {timeout ok}
test httpold-5.1 {http_formatQuery} {
http_formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value+two}
test httpold-5.2 {http_formatQuery} {
http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
} {name1=%7ebwelch&name2=%a1%a2%a2}
test httpold-5.3 {http_formatQuery} {
http_formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}
test httpold-6.1 {httpProxyRequired} {
update
http_config -proxyhost [info hostname] -proxyport $port
set token [http_get $url]
http_wait $token
http_config -proxyhost {} -proxyport {}
upvar #0 $token data
set data(body)
} "HTTP/1.0 TEST
Hello, World!
GET http://$url
"
# cleanup
catch {unset url}
catch {unset port}
catch {unset data}
close $listen
::tcltest::cleanupTests
return
tcl8.4.20/tests/obj.test 0000644 0036047 0045461 00000056735 11737050674 013554 0 ustar dgp 771div # Functionality covered: this file contains a collection of tests for the
# procedures in tclObj.c that implement Tcl's basic type support and the
# type managers for the types boolean, double, and integer.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
puts "command, so I can't test the Tcl type and object support."
::tcltest::cleanupTests
return
}
# Procedure to determine the integer range of the machine
proc int_range {} {
for { set MIN_INT 1 } { $MIN_INT > 0 } {} {
set MIN_INT [expr { $MIN_INT << 1 }]
}
set MAX_INT [expr { ~ $MIN_INT }]
return [list $MIN_INT $MAX_INT]
}
# Procedure to determine the range of wide integers on the machine.
proc wide_range {} {
for { set MIN_WIDE [expr { wide(1) }] } { $MIN_WIDE > wide(0) } {} {
set MIN_WIDE [expr { $MIN_WIDE << 1 }]
}
set MAX_WIDE [expr { ~ $MIN_WIDE }]
return [list $MIN_WIDE $MAX_WIDE]
}
foreach { MIN_INT MAX_INT } [int_range] break
foreach { MIN_WIDE MAX_WIDE } [wide_range] break
::tcltest::testConstraint 32bit \
[expr { $MAX_INT == 0x7fffffff }]
::tcltest::testConstraint wideBiggerThanInt \
[expr { $MAX_WIDE > wide($MAX_INT) }]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {
set r 1
foreach {t} {
{array search}
boolean
bytearray
bytecode
double
end-offset
index
int
list
nsName
procbody
string
} {
set first [string first $t [testobj types]]
set r [expr {$r && ($first != -1)}]
}
set result $r
} {1}
test obj-2.1 {Tcl_GetObjType error} {
list [testintobj set 1 0] [catch {testobj convert 1 foo} msg] $msg
} {0 1 {no type foo found}}
test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} {
set result ""
lappend result [testobj freeallvars]
lappend result [testintobj set 1 12]
lappend result [testobj convert 1 double]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 12 12 double 3}
test obj-3.1 {Tcl_ConvertToType error} {
list [testdoubleobj set 1 12.34] [catch {testobj convert 1 int} msg] $msg
} {12.34 1 {expected integer but got "12.34"}}
test obj-3.2 {Tcl_ConvertToType error, "empty string" object} {
list [testobj newobj 1] [catch {testobj convert 1 int} msg] $msg
} {{} 1 {expected integer but got ""}}
test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} {
set result ""
lappend result [testobj freeallvars]
lappend result [testobj newobj 1]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} {} string 2}
test obj-5.1 {Tcl_FreeObj} {
set result ""
lappend result [testintobj set 1 12345]
lappend result [testobj freeallvars]
lappend result [catch {testintobj get 1} msg]
lappend result $msg
} {12345 {} 1 {variable 1 is unset (NULL)}}
test obj-6.1 {Tcl_DuplicateObj, object has internal rep} {
set result ""
lappend result [testobj freeallvars]
lappend result [testintobj set 1 47]
lappend result [testobj duplicate 1 2]
lappend result [testintobj get 2]
lappend result [testobj refcount 1]
lappend result [testobj refcount 2]
} {{} 47 47 47 2 3}
test obj-6.2 {Tcl_DuplicateObj, "empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testobj newobj 1]
lappend result [testobj duplicate 1 2]
lappend result [testintobj get 2]
lappend result [testobj refcount 1]
lappend result [testobj refcount 2]
} {{} {} {} {} 2 3}
test obj-7.1 {Tcl_GetString, return existing string rep} {
set result ""
lappend result [testintobj set 1 47]
lappend result [testintobj get2 1]
} {47 47}
test obj-7.2 {Tcl_GetString, "empty string" object} {
set result ""
lappend result [testobj newobj 1]
lappend result [teststringobj append 1 abc -1]
lappend result [teststringobj get2 1]
} {{} abc abc}
test obj-7.3 {Tcl_GetString, returns string internal rep (DString)} {
set result ""
lappend result [teststringobj set 1 xyz]
lappend result [teststringobj append 1 abc -1]
lappend result [teststringobj get2 1]
} {xyz xyzabc xyzabc}
test obj-7.4 {Tcl_GetString, recompute string rep from internal rep} {
set result ""
lappend result [testintobj set 1 77]
lappend result [testintobj mult10 1]
lappend result [teststringobj get2 1]
} {77 770 770}
test obj-8.1 {Tcl_GetStringFromObj, return existing string rep} {
set result ""
lappend result [testintobj set 1 47]
lappend result [testintobj get 1]
} {47 47}
test obj-8.2 {Tcl_GetStringFromObj, "empty string" object} {
set result ""
lappend result [testobj newobj 1]
lappend result [teststringobj append 1 abc -1]
lappend result [teststringobj get 1]
} {{} abc abc}
test obj-8.3 {Tcl_GetStringFromObj, returns string internal rep (DString)} {
set result ""
lappend result [teststringobj set 1 xyz]
lappend result [teststringobj append 1 abc -1]
lappend result [teststringobj get 1]
} {xyz xyzabc xyzabc}
test obj-8.4 {Tcl_GetStringFromObj, recompute string rep from internal rep} {
set result ""
lappend result [testintobj set 1 77]
lappend result [testintobj mult10 1]
lappend result [teststringobj get 1]
} {77 770 770}
test obj-9.1 {Tcl_NewBooleanObj} {
set result ""
lappend result [testobj freeallvars]
lappend result [testbooleanobj set 1 0]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 0 boolean 2}
test obj-10.1 {Tcl_SetBooleanObj, existing "empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testobj newobj 1]
lappend result [testbooleanobj set 1 0] ;# makes existing obj boolean
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} {} 0 boolean 2}
test obj-10.2 {Tcl_SetBooleanObj, existing non-"empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testintobj set 1 98765]
lappend result [testbooleanobj set 1 1] ;# makes existing obj boolean
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 98765 1 boolean 2}
test obj-11.1 {Tcl_GetBooleanFromObj, existing boolean object} {
set result ""
lappend result [testbooleanobj set 1 1]
lappend result [testbooleanobj not 1] ;# gets existing boolean rep
} {1 0}
test obj-11.2 {Tcl_GetBooleanFromObj, convert to boolean} {
set result ""
lappend result [testintobj set 1 47]
lappend result [testbooleanobj not 1] ;# must convert to bool
lappend result [testobj type 1]
} {47 0 boolean}
test obj-11.3 {Tcl_GetBooleanFromObj, error converting to boolean} {
set result ""
lappend result [teststringobj set 1 abc]
lappend result [catch {testbooleanobj not 1} msg]
lappend result $msg
} {abc 1 {expected boolean value but got "abc"}}
test obj-11.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} {
set result ""
lappend result [testobj newobj 1]
lappend result [catch {testbooleanobj not 1} msg]
lappend result $msg
} {{} 1 {expected boolean value but got ""}}
test obj-11.5 {Tcl_GetBooleanFromObj, convert hex to boolean} {
set result ""
lappend result [teststringobj set 1 0xac]
lappend result [testbooleanobj not 1]
lappend result [testobj type 1]
} {0xac 0 boolean}
test obj-11.6 {Tcl_GetBooleanFromObj, convert float to boolean} {
set result ""
lappend result [teststringobj set 1 5.42]
lappend result [testbooleanobj not 1]
lappend result [testobj type 1]
} {5.42 0 boolean}
test obj-12.1 {DupBooleanInternalRep} {
set result ""
lappend result [testbooleanobj set 1 1]
lappend result [testobj duplicate 1 2] ;# uses DupBooleanInternalRep
lappend result [testbooleanobj get 2]
} {1 1 1}
test obj-13.1 {SetBooleanFromAny, int to boolean special case} {
set result ""
lappend result [testintobj set 1 1234]
lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny
lappend result [testobj type 1]
} {1234 0 boolean}
test obj-13.2 {SetBooleanFromAny, double to boolean special case} {
set result ""
lappend result [testdoubleobj set 1 3.14159]
lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny
lappend result [testobj type 1]
} {3.14159 0 boolean}
test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} {
set result ""
foreach s {yes no true false on off} {
teststringobj set 1 $s
lappend result [testbooleanobj not 1]
}
lappend result [testobj type 1]
} {0 1 0 1 0 1 boolean}
test obj-13.4 {SetBooleanFromAny, recompute string rep then parse it} {
set result ""
lappend result [testintobj set 1 456]
lappend result [testintobj div10 1]
lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny
lappend result [testobj type 1]
} {456 45 0 boolean}
test obj-13.5 {SetBooleanFromAny, error parsing string} {
set result ""
lappend result [teststringobj set 1 abc]
lappend result [catch {testbooleanobj not 1} msg]
lappend result $msg
} {abc 1 {expected boolean value but got "abc"}}
test obj-13.6 {SetBooleanFromAny, error parsing string} {
set result ""
lappend result [teststringobj set 1 x1.0]
lappend result [catch {testbooleanobj not 1} msg]
lappend result $msg
} {x1.0 1 {expected boolean value but got "x1.0"}}
test obj-13.7 {SetBooleanFromAny, error converting from "empty string"} {
set result ""
lappend result [testobj newobj 1]
lappend result [catch {testbooleanobj not 1} msg]
lappend result $msg
} {{} 1 {expected boolean value but got ""}}
test obj-13.8 {SetBooleanFromAny, unicode strings} {
set result ""
lappend result [teststringobj set 1 1\u7777]
lappend result [catch {testbooleanobj not 1} msg]
lappend result $msg
} "1\u7777 1 {expected boolean value but got \"1\u7777\"}"
test obj-14.1 {UpdateStringOfBoolean} {
set result ""
lappend result [testbooleanobj set 1 0]
lappend result [testbooleanobj not 1]
lappend result [testbooleanobj get 1] ;# must update string rep
} {0 1 1}
test obj-15.1 {Tcl_NewDoubleObj} {
set result ""
lappend result [testobj freeallvars]
lappend result [testdoubleobj set 1 3.1459]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 3.1459 double 2}
test obj-16.1 {Tcl_SetDoubleObj, existing "empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testobj newobj 1]
lappend result [testdoubleobj set 1 0.123] ;# makes existing obj boolean
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} {} 0.123 double 2}
test obj-16.2 {Tcl_SetDoubleObj, existing non-"empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testintobj set 1 98765]
lappend result [testdoubleobj set 1 27.56] ;# makes existing obj double
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 98765 27.56 double 2}
test obj-17.1 {Tcl_GetDoubleFromObj, existing double object} {
set result ""
lappend result [testdoubleobj set 1 16.1]
lappend result [testdoubleobj mult10 1] ;# gets existing double rep
} {16.1 161.0}
test obj-17.2 {Tcl_GetDoubleFromObj, convert to double} {
set result ""
lappend result [testintobj set 1 477]
lappend result [testdoubleobj div10 1] ;# must convert to bool
lappend result [testobj type 1]
} {477 47.7 double}
test obj-17.3 {Tcl_GetDoubleFromObj, error converting to double} {
set result ""
lappend result [teststringobj set 1 abc]
lappend result [catch {testdoubleobj mult10 1} msg]
lappend result $msg
} {abc 1 {expected floating-point number but got "abc"}}
test obj-17.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} {
set result ""
lappend result [testobj newobj 1]
lappend result [catch {testdoubleobj div10 1} msg]
lappend result $msg
} {{} 1 {expected floating-point number but got ""}}
test obj-18.1 {DupDoubleInternalRep} {
set result ""
lappend result [testdoubleobj set 1 17.1]
lappend result [testobj duplicate 1 2] ;# uses DupDoubleInternalRep
lappend result [testdoubleobj get 2]
} {17.1 17.1 17.1}
test obj-19.1 {SetDoubleFromAny, int to double special case} {
set result ""
lappend result [testintobj set 1 1234]
lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny
lappend result [testobj type 1]
} {1234 12340.0 double}
test obj-19.2 {SetDoubleFromAny, boolean to double special case} {
set result ""
lappend result [testbooleanobj set 1 1]
lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny
lappend result [testobj type 1]
} {1 10.0 double}
test obj-19.3 {SetDoubleFromAny, recompute string rep then parse it} {
set result ""
lappend result [testintobj set 1 456]
lappend result [testintobj div10 1]
lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny
lappend result [testobj type 1]
} {456 45 450.0 double}
test obj-19.4 {SetDoubleFromAny, error parsing string} {
set result ""
lappend result [teststringobj set 1 abc]
lappend result [catch {testdoubleobj mult10 1} msg]
lappend result $msg
} {abc 1 {expected floating-point number but got "abc"}}
test obj-19.5 {SetDoubleFromAny, error parsing string} {
set result ""
lappend result [teststringobj set 1 x1.0]
lappend result [catch {testdoubleobj mult10 1} msg]
lappend result $msg
} {x1.0 1 {expected floating-point number but got "x1.0"}}
test obj-19.6 {SetDoubleFromAny, error converting from "empty string"} {
set result ""
lappend result [testobj newobj 1]
lappend result [catch {testdoubleobj div10 1} msg]
lappend result $msg
} {{} 1 {expected floating-point number but got ""}}
test obj-20.1 {UpdateStringOfDouble} {
set result ""
lappend result [testdoubleobj set 1 3.14159]
lappend result [testdoubleobj mult10 1]
lappend result [testdoubleobj get 1] ;# must update string rep
} {3.14159 31.4159 31.4159}
test obj-21.1 {Tcl_NewIntObj} {
set result ""
lappend result [testobj freeallvars]
lappend result [testintobj set 1 55]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 55 int 2}
test obj-22.1 {Tcl_SetIntObj, existing "empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testobj newobj 1]
lappend result [testintobj set 1 77] ;# makes existing obj int
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} {} 77 int 2}
test obj-22.2 {Tcl_SetIntObj, existing non-"empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testdoubleobj set 1 12.34]
lappend result [testintobj set 1 77] ;# makes existing obj int
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 12.34 77 int 2}
test obj-23.1 {Tcl_GetIntFromObj, existing int object} {
set result ""
lappend result [testintobj set 1 22]
lappend result [testintobj mult10 1] ;# gets existing int rep
} {22 220}
test obj-23.2 {Tcl_GetIntFromObj, convert to int} {
set result ""
lappend result [testintobj set 1 477]
lappend result [testintobj div10 1] ;# must convert to bool
lappend result [testobj type 1]
} {477 47 int}
test obj-23.3 {Tcl_GetIntFromObj, error converting to int} {
set result ""
lappend result [teststringobj set 1 abc]
lappend result [catch {testintobj mult10 1} msg]
lappend result $msg
} {abc 1 {expected integer but got "abc"}}
test obj-23.4 {Tcl_GetIntFromObj, error converting from "empty string"} {
set result ""
lappend result [testobj newobj 1]
lappend result [catch {testintobj div10 1} msg]
lappend result $msg
} {{} 1 {expected integer but got ""}}
test obj-23.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {nonPortable} {
set result ""
lappend result [testobj newobj 1]
lappend result [testintobj inttoobigtest 1]
} {{} 1}
test obj-24.1 {DupIntInternalRep} {
set result ""
lappend result [testintobj set 1 23]
lappend result [testobj duplicate 1 2] ;# uses DupIntInternalRep
lappend result [testintobj get 2]
} {23 23 23}
test obj-25.1 {SetIntFromAny, int to int special case} {
set result ""
lappend result [testintobj set 1 1234]
lappend result [testintobj mult10 1] ;# converts with SetIntFromAny
lappend result [testobj type 1]
} {1234 12340 int}
test obj-25.2 {SetIntFromAny, boolean to int special case} {
set result ""
lappend result [testbooleanobj set 1 1]
lappend result [testintobj mult10 1] ;# converts with SetIntFromAny
lappend result [testobj type 1]
} {1 10 int}
test obj-25.3 {SetIntFromAny, recompute string rep then parse it} {
set result ""
lappend result [testintobj set 1 456]
lappend result [testintobj div10 1]
lappend result [testintobj mult10 1] ;# converts with SetIntFromAny
lappend result [testobj type 1]
} {456 45 450 int}
test obj-25.4 {SetIntFromAny, error parsing string} {
set result ""
lappend result [teststringobj set 1 abc]
lappend result [catch {testintobj mult10 1} msg]
lappend result $msg
} {abc 1 {expected integer but got "abc"}}
test obj-25.5 {SetIntFromAny, error parsing string} {
set result ""
lappend result [teststringobj set 1 x17]
lappend result [catch {testintobj mult10 1} msg]
lappend result $msg
} {x17 1 {expected integer but got "x17"}}
test obj-25.6 {SetIntFromAny, integer too large} {nonPortable} {
set result ""
lappend result [teststringobj set 1 123456789012345678901]
lappend result [catch {testintobj mult10 1} msg]
lappend result $msg
} {123456789012345678901 1 {integer value too large to represent}}
test obj-25.7 {SetIntFromAny, error converting from "empty string"} {
set result ""
lappend result [testobj newobj 1]
lappend result [catch {testintobj div10 1} msg]
lappend result $msg
} {{} 1 {expected integer but got ""}}
test obj-26.1 {UpdateStringOfInt} {
set result ""
lappend result [testintobj set 1 512]
lappend result [testintobj mult10 1]
lappend result [testintobj get 1] ;# must update string rep
} {512 5120 5120}
test obj-27.1 {Tcl_NewLongObj} {
set result ""
lappend result [testobj freeallvars]
testintobj setmaxlong 1
lappend result [testintobj ismaxlong 1]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 1 int 1}
test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testobj newobj 1]
lappend result [testintobj setlong 1 77] ;# makes existing obj long int
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} {} 77 int 2}
test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testdoubleobj set 1 12.34]
lappend result [testintobj setlong 1 77] ;# makes existing obj long int
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 12.34 77 int 2}
test obj-29.1 {Tcl_GetLongFromObj, existing long integer object} {
set result ""
lappend result [testintobj setlong 1 22]
lappend result [testintobj mult10 1] ;# gets existing long int rep
} {22 220}
test obj-29.2 {Tcl_GetLongFromObj, convert to long} {
set result ""
lappend result [testintobj setlong 1 477]
lappend result [testintobj div10 1] ;# must convert to bool
lappend result [testobj type 1]
} {477 47 int}
test obj-29.3 {Tcl_GetLongFromObj, error converting to long integer} {
set result ""
lappend result [teststringobj set 1 abc]
lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int
lappend result $msg
} {abc 1 {expected integer but got "abc"}}
test obj-29.4 {Tcl_GetLongFromObj, error converting from "empty string"} {
set result ""
lappend result [testobj newobj 1]
lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int
lappend result $msg
} {{} 1 {expected integer but got ""}}
test obj-30.1 {Ref counting and object deletion, simple types} {
set result ""
lappend result [testobj freeallvars]
lappend result [testintobj set 1 1024]
lappend result [testobj assign 1 2] ;# vars 1 and 2 share the int obj
lappend result [testobj type 2]
lappend result [testobj refcount 1]
lappend result [testobj refcount 2]
lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs
lappend result [testobj type 2]
lappend result [testobj refcount 1]
lappend result [testobj refcount 2]
} {{} 1024 1024 int 4 4 0 boolean 3 2}
test obj-31.1 {regenerate string rep of "end"} {
testobj freeallvars
teststringobj set 1 end
testobj convert 1 end-offset
testobj invalidateStringRep 1
} end
test obj-31.2 {regenerate string rep of "end-1"} {
testobj freeallvars
teststringobj set 1 end-0x1
testobj convert 1 end-offset
testobj invalidateStringRep 1
} end-1
test obj-31.3 {regenerate string rep of "end--1"} {
testobj freeallvars
teststringobj set 1 end--0x1
testobj convert 1 end-offset
testobj invalidateStringRep 1
} end--1
test obj-31.4 {regenerate string rep of "end-bigInteger"} {
testobj freeallvars
teststringobj set 1 end-0x7fffffff
testobj convert 1 end-offset
testobj invalidateStringRep 1
} end-2147483647
test obj-31.5 {regenerate string rep of "end--bigInteger"} {
testobj freeallvars
teststringobj set 1 end--0x7fffffff
testobj convert 1 end-offset
testobj invalidateStringRep 1
} end--2147483647
test obj-31.6 {regenerate string rep of "end--bigInteger"} {nonPortable} {
testobj freeallvars
teststringobj set 1 end--0x80000000
testobj convert 1 end-offset
testobj invalidateStringRep 1
} end--2147483648
test obj-32.1 {integer overflow on input} {32bit wideBiggerThanInt} {
set x 0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
test obj-32.2 {integer overflow on input} {32bit wideBiggerThanInt} {
set x 0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
test obj-32.3 {integer overflow on input} {32bit wideBiggerThanInt} {
set x 0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {0 4294967296}
test obj-32.4 {integer overflow on input} {32bit wideBiggerThanInt} {
set x -0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
test obj-32.5 {integer overflow on input} {32bit wideBiggerThanInt} {
set x -0x8000; append x 0001
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
test obj-32.6 {integer overflow on input} {32bit wideBiggerThanInt} {
set x -0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
test obj-32.7 {integer overflow on input} {32bit wideBiggerThanInt} {
set x -0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {0 -4294967296}
testobj freeallvars
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
tcl8.4.20/tests/load.test 0000644 0036047 0045461 00000020774 12052456744 013712 0 ustar dgp 771div # Commands covered: load
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Figure out what extension is used for shared libraries on this
# platform.
# Tests require the existence of one of the DLLs in the dltest directory.
set ext [info sharedlibextension]
set testDir [file join [file dirname [info nameofexecutable]] dltest]
set x [file join $testDir pkga$ext]
set dll "[file tail $x]Required"
::tcltest::testConstraint $dll [file readable $x]
# Tests also require that this DLL has not already been loaded.
set loaded "[file tail $x]Loaded"
set alreadyLoaded [info loaded]
::tcltest::testConstraint $loaded \
[expr {![string match *pkga* $alreadyLoaded]}]
set alreadyTotalLoaded [info loaded]
# Certain tests require the 'teststaticpkg' command from tcltest
::tcltest::testConstraint teststaticpkg \
[string compare {} [info commands teststaticpkg]]
# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest
::tcltest::testConstraint testsimplefilesystem \
[string compare {} [info commands testsimplefilesystem]]
test load-1.1 {basic errors} {} {
list [catch {load} msg] $msg
} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
test load-1.2 {basic errors} {} {
list [catch {load a b c d} msg] $msg
} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
test load-1.3 {basic errors} {} {
list [catch {load a b foobar} msg] $msg
} {1 {could not find interpreter "foobar"}}
test load-1.4 {basic errors} {} {
list [catch {load {}} msg] $msg
} {1 {must specify either file name or package name}}
test load-1.5 {basic errors} {} {
list [catch {load {} {}} msg] $msg
} {1 {must specify either file name or package name}}
test load-1.6 {basic errors} {} {
list [catch {load {} Unknown} msg] $msg
} {1 {package "Unknown" isn't loaded statically}}
test load-2.1 {basic loading, with guess for package name} \
[list $dll $loaded] {
load [file join $testDir pkga$ext]
list [pkga_eq abc def] [info commands pkga_*]
} {0 {pkga_eq pkga_quote}}
interp create -safe child
test load-2.2 {loading into a safe interpreter, with package name conversion} \
[list $dll $loaded] {
load [file join $testDir pkgb$ext] pKgB child
list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
[catch {pkgb_sub 12 10} msg2] $msg2
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \
-body {
list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg
} -match glob -result {1 {*couldn't find procedure Foo_Init}}
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}
test load-3.1 {error in _Init procedure, same interpreter} \
[list $dll $loaded] {
list [catch {load [file join $testDir pkge$ext] pkge} msg] \
$msg $errorInfo $errorCode
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
while executing
"open non_existent"
invoked from within
"if 44 {open non_existent}"
invoked from within
"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}
test load-3.2 {error in _Init procedure, slave interpreter} \
[list $dll $loaded] {
catch {interp delete x}
interp create x
set errorCode foo
set errorInfo bar
set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \
$msg $errorInfo $errorCode]
interp delete x
set result
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
while executing
"open non_existent"
invoked from within
"if 44 {open non_existent}"
invoked from within
"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}}
test load-4.1 {reloading package into same interpreter} [list $dll $loaded] {
list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg
} {0 {}}
test load-4.2 {reloading package into same interpreter} [list $dll $loaded] {
list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]
test load-5.1 {file name not specified and no static package: pick default} \
[list $dll $loaded] {
catch {interp delete x}
interp create x
load [file join $testDir pkga$ext] pkga
load {} pkga x
set result [info loaded x]
interp delete x
set result
} [list [list [file join $testDir pkga$ext] Pkga]]
# On some platforms, like SunOS 4.1.3, these tests can't be run because
# they cause the process to exit.
test load-6.1 {errors loading file} [list $dll $loaded nonPortable] {
catch {load foo foo}
} {1}
test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] {
set x "not loaded"
teststaticpkg Test 1 0
load {} Test
load {} Test child
list [set x] [child eval set x]
} {loaded loaded}
test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] {
set x "not loaded"
teststaticpkg Another 0 0
load {} Another
child eval {set x "not loaded"}
list [catch {load {} Another child} msg] $msg \
[child eval set x] [set x]
} {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded}
test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] {
set x "not loaded"
teststaticpkg More 0 1
load {} More
set x
} {not loaded}
test load-7.4 {Tcl_StaticPackage procedure, redundant calls} \
[list teststaticpkg $dll $loaded] {
teststaticpkg Double 0 1
teststaticpkg Double 0 1
info loaded
} [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded]
test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
info loaded
} [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded]
test load-8.2 {TclGetLoadedPackages procedure} [list teststaticpkg] {
list [catch {info loaded gorp} msg] $msg
} {1 {could not find interpreter "gorp"}}
test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
list [info loaded {}] [info loaded child]
} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
load [file join $testDir pkgb$ext] pkgb
list [info loaded {}] [lsort [info commands pkgb_*]]
} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_sub pkgb_unsafe}]
interp delete child
test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \
-constraints {teststaticpkg} \
-setup {
interp create child1
interp create child2
load {} Tcltest child1
load {} Tcltest child2
} \
-body {
child1 eval { teststaticpkg Loadninepointone 0 1 }
child2 eval { teststaticpkg Loadninepointone 0 1 }
list \
[child1 eval { info loaded {} }] \
[child2 eval { info loaded {} }]
} \
-result {{{{} Loadninepointone} {{} Tcltest}} {{{} Loadninepointone} {{} Tcltest}}} \
-cleanup { interp delete child1 ; interp delete child2 }
test load-10.1 {load from vfs} \
-constraints [list $dll $loaded testsimplefilesystem] \
-setup {set dir [pwd]; cd $testDir; testsimplefilesystem 1} \
-body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \
-result {0 {}} \
-cleanup {testsimplefilesystem 0; cd $dir; unset dir}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/namespace-old.test 0000644 0036047 0045461 00000100361 11737050674 015473 0 ustar dgp 771div # Functionality covered: this file contains slightly modified versions of
# the original tests written by Mike McLennan of Lucent Technologies for
# the procedures in tclNamesp.c that implement Tcl's basic support for
# namespaces. Other namespace-related tests appear in namespace.test
# and variable.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1997 Lucent Technologies
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}
test namespace-old-1.1 {usage for "namespace" command} {
list [catch {namespace} msg] $msg
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-old-1.2 {global namespace's name is "::" or {}} {
list [namespace current] [namespace eval {} {namespace current}]
} {:: ::}
test namespace-old-1.3 {usage for "namespace eval"} {
list [catch {namespace eval} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-old-1.4 {create new namespaces} {
list [lsort [namespace children :: test_ns_simple*]] \
[namespace eval test_ns_simple {}] \
[namespace eval test_ns_simple2 {}] \
[lsort [namespace children :: test_ns_simple*]]
} {{} {} {} {::test_ns_simple ::test_ns_simple2}}
test namespace-old-1.5 {access a new namespace} {
namespace eval test_ns_simple { namespace current }
} {::test_ns_simple}
test namespace-old-1.6 {usage for "namespace eval"} {
list [catch {namespace eval} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-old-1.7 {usage for "namespace eval"} {
list [catch {namespace eval test_ns_xyzzy} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-old-1.8 {command "namespace eval" concatenates args} {
namespace eval test_ns_simple namespace current
} {::test_ns_simple}
test namespace-old-1.9 {add elements to a namespace} {
namespace eval test_ns_simple {
variable test_ns_x 0
proc test {test_ns_x} {
return "test: $test_ns_x"
}
}
} {}
test namespace-old-1.10 {commands in a namespace} {
namespace eval test_ns_simple { info commands [namespace current]::*}
} {::test_ns_simple::test}
test namespace-old-1.11 {variables in a namespace} {
namespace eval test_ns_simple { info vars [namespace current]::* }
} {::test_ns_simple::test_ns_x}
test namespace-old-1.12 {global vars are separate from locals vars} {
list [test_ns_simple::test 123] [set test_ns_simple::test_ns_x]
} {{test: 123} 0}
test namespace-old-1.13 {add to an existing namespace} {
namespace eval test_ns_simple {
variable test_ns_y 123
proc _backdoor {cmd} {
eval $cmd
}
}
} ""
test namespace-old-1.14 {commands in a namespace} {
lsort [namespace eval test_ns_simple {info commands [namespace current]::*}]
} {::test_ns_simple::_backdoor ::test_ns_simple::test}
test namespace-old-1.15 {variables in a namespace} {
lsort [namespace eval test_ns_simple {info vars [namespace current]::*}]
} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y}
test namespace-old-1.16 {variables in a namespace} {
lsort [info vars test_ns_simple::*]
} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y}
test namespace-old-1.17 {commands in a namespace are hidden} {
list [catch "_backdoor {return yes!}" msg] $msg
} {1 {invalid command name "_backdoor"}}
test namespace-old-1.18 {using namespace qualifiers} {
list [catch "test_ns_simple::_backdoor {return yes!}" msg] $msg
} {0 yes!}
test namespace-old-1.19 {using absolute namespace qualifiers} {
list [catch "::test_ns_simple::_backdoor {return yes!}" msg] $msg
} {0 yes!}
test namespace-old-1.20 {variables in a namespace are hidden} {
list [catch "set test_ns_x" msg] $msg [catch "set test_ns_y" msg] $msg
} {1 {can't read "test_ns_x": no such variable} 1 {can't read "test_ns_y": no such variable}}
test namespace-old-1.21 {using namespace qualifiers} {
list [catch "set test_ns_simple::test_ns_x" msg] $msg \
[catch "set test_ns_simple::test_ns_y" msg] $msg
} {0 0 0 123}
test namespace-old-1.22 {using absolute namespace qualifiers} {
list [catch "set ::test_ns_simple::test_ns_x" msg] $msg \
[catch "set ::test_ns_simple::test_ns_y" msg] $msg
} {0 0 0 123}
test namespace-old-1.23 {variables can be accessed within a namespace} {
test_ns_simple::_backdoor {
variable test_ns_x
variable test_ns_y
return "$test_ns_x $test_ns_y"
}
} {0 123}
test namespace-old-1.24 {setting global variables} {
test_ns_simple::_backdoor {variable test_ns_x; set test_ns_x "new val"}
namespace eval test_ns_simple {set test_ns_x}
} {new val}
test namespace-old-1.25 {qualified variables don't need a global declaration} {
namespace eval test_ns_another { variable test_ns_x 456 }
set cmd {set ::test_ns_another::test_ns_x}
list [catch {test_ns_simple::_backdoor "$cmd some-value"} msg] $msg \
[eval $cmd]
} {0 some-value some-value}
test namespace-old-1.26 {namespace qualifiers are okay after $'s} {
namespace eval test_ns_simple { set test_ns_x 12; set test_ns_y 34 }
set cmd {list $::test_ns_simple::test_ns_x $::test_ns_simple::test_ns_y}
list [test_ns_simple::_backdoor $cmd] [eval $cmd]
} {{12 34} {12 34}}
test namespace-old-1.27 {can create commands with null names} {
proc test_ns_simple:: {args} {return $args}
} {}
# -----------------------------------------------------------------------
# TEST: using "info" in namespace contexts
# -----------------------------------------------------------------------
test namespace-old-2.1 {querying: info commands} {
lsort [test_ns_simple::_backdoor {info commands [namespace current]::*}]
} {::test_ns_simple:: ::test_ns_simple::_backdoor ::test_ns_simple::test}
test namespace-old-2.2 {querying: info procs} {
lsort [test_ns_simple::_backdoor {info procs}]
} {{} _backdoor test}
test namespace-old-2.3 {querying: info vars} {
lsort [info vars test_ns_simple::*]
} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y}
test namespace-old-2.4 {querying: info vars} {
lsort [test_ns_simple::_backdoor {info vars [namespace current]::*}]
} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y}
test namespace-old-2.5 {querying: info locals} {
lsort [test_ns_simple::_backdoor {info locals}]
} {cmd}
test namespace-old-2.6 {querying: info exists} {
test_ns_simple::_backdoor {info exists test_ns_x}
} {0}
test namespace-old-2.7 {querying: info exists} {
test_ns_simple::_backdoor {info exists cmd}
} {1}
test namespace-old-2.8 {querying: info args} {
info args test_ns_simple::_backdoor
} {cmd}
test namespace-old-2.9 {querying: info body} {
string trim [info body test_ns_simple::test]
} {return "test: $test_ns_x"}
# -----------------------------------------------------------------------
# TEST: namespace qualifiers, namespace tail
# -----------------------------------------------------------------------
test namespace-old-3.1 {usage for "namespace qualifiers"} {
list [catch "namespace qualifiers" msg] $msg
} {1 {wrong # args: should be "namespace qualifiers string"}}
test namespace-old-3.2 {querying: namespace qualifiers} {
list [namespace qualifiers ""] \
[namespace qualifiers ::] \
[namespace qualifiers x] \
[namespace qualifiers ::x] \
[namespace qualifiers foo::x] \
[namespace qualifiers ::foo::bar::xyz]
} {{} {} {} {} foo ::foo::bar}
test namespace-old-3.3 {usage for "namespace tail"} {
list [catch "namespace tail" msg] $msg
} {1 {wrong # args: should be "namespace tail string"}}
test namespace-old-3.4 {querying: namespace tail} {
list [namespace tail ""] \
[namespace tail ::] \
[namespace tail x] \
[namespace tail ::x] \
[namespace tail foo::x] \
[namespace tail ::foo::bar::xyz]
} {{} {} x x x xyz}
# -----------------------------------------------------------------------
# TEST: delete commands and namespaces
# -----------------------------------------------------------------------
test namespace-old-4.1 {define test namespaces} {
namespace eval test_ns_delete {
namespace eval ns1 {
variable var1 1
proc cmd1 {} {return "cmd1"}
}
namespace eval ns2 {
variable var2 2
proc cmd2 {} {return "cmd2"}
}
namespace eval another {}
lsort [namespace children]
}
} {::test_ns_delete::another ::test_ns_delete::ns1 ::test_ns_delete::ns2}
test namespace-old-4.2 {it's okay to invoke "namespace delete" with no args} {
list [catch {namespace delete} msg] $msg
} {0 {}}
test namespace-old-4.3 {command "namespace delete" doesn't support patterns} {
set cmd {
namespace eval test_ns_delete {namespace delete ns*}
}
list [catch $cmd msg] $msg
} {1 {unknown namespace "ns*" in namespace delete command}}
test namespace-old-4.4 {command "namespace delete" handles multiple args} {
set cmd {
namespace eval test_ns_delete {
eval namespace delete \
[namespace children [namespace current] ns?]
}
}
list [catch $cmd msg] $msg [namespace children test_ns_delete]
} {0 {} ::test_ns_delete::another}
# -----------------------------------------------------------------------
# TEST: namespace hierarchy
# -----------------------------------------------------------------------
test namespace-old-5.1 {define nested namespaces} {
set test_ns_var_global "var in ::"
proc test_ns_cmd_global {} {return "cmd in ::"}
namespace eval test_ns_hier1 {
set test_ns_var_hier1 "particular to hier1"
proc test_ns_cmd_hier1 {} {return "particular to hier1"}
set test_ns_level 1
proc test_ns_show {} {return "[namespace current]: 1"}
namespace eval test_ns_hier2 {
set test_ns_var_hier2 "particular to hier2"
proc test_ns_cmd_hier2 {} {return "particular to hier2"}
set test_ns_level 2
proc test_ns_show {} {return "[namespace current]: 2"}
namespace eval test_ns_hier3a {}
namespace eval test_ns_hier3b {}
}
namespace eval test_ns_hier2a {}
namespace eval test_ns_hier2b {}
}
} {}
test namespace-old-5.2 {namespaces can be nested} {
list [namespace eval test_ns_hier1 {namespace current}] \
[namespace eval test_ns_hier1 {
namespace eval test_ns_hier2 {namespace current}
}]
} {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2}
test namespace-old-5.3 {namespace qualifiers work in namespace command} {
list [namespace eval ::test_ns_hier1 {namespace current}] \
[namespace eval test_ns_hier1::test_ns_hier2 {namespace current}] \
[namespace eval ::test_ns_hier1::test_ns_hier2 {namespace current}]
} {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2}
test namespace-old-5.4 {nested namespaces can access global namespace} {
list [namespace eval test_ns_hier1 {set test_ns_var_global}] \
[namespace eval test_ns_hier1 {test_ns_cmd_global}] \
[namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_global}] \
[namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}]
} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}}
test namespace-old-5.5 {variables in different namespaces don't conflict} {
list [set test_ns_hier1::test_ns_level] \
[set test_ns_hier1::test_ns_hier2::test_ns_level]
} {1 2}
test namespace-old-5.6 {commands in different namespaces don't conflict} {
list [test_ns_hier1::test_ns_show] \
[test_ns_hier1::test_ns_hier2::test_ns_show]
} {{::test_ns_hier1: 1} {::test_ns_hier1::test_ns_hier2: 2}}
test namespace-old-5.7 {nested namespaces don't see variables in parent} {
set cmd {
namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_hier1}
}
list [catch $cmd msg] $msg
} {1 {can't read "test_ns_var_hier1": no such variable}}
test namespace-old-5.8 {nested namespaces don't see commands in parent} {
set cmd {
namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_hier1}
}
list [catch $cmd msg] $msg
} {1 {invalid command name "test_ns_cmd_hier1"}}
test namespace-old-5.9 {usage for "namespace children"} {
list [catch {namespace children test_ns_hier1 y z} msg] $msg
} {1 {wrong # args: should be "namespace children ?name? ?pattern?"}}
test namespace-old-5.10 {command "namespace children" must get valid namespace} {
list [catch {namespace children xyzzy} msg] $msg
} {1 {unknown namespace "xyzzy" in namespace children command}}
test namespace-old-5.11 {querying namespace children} {
lsort [namespace children :: test_ns_hier*]
} {::test_ns_hier1}
test namespace-old-5.12 {querying namespace children} {
lsort [namespace children test_ns_hier1]
} {::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2a ::test_ns_hier1::test_ns_hier2b}
test namespace-old-5.13 {querying namespace children} {
lsort [namespace eval test_ns_hier1 {namespace children}]
} {::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2a ::test_ns_hier1::test_ns_hier2b}
test namespace-old-5.14 {querying namespace children} {
lsort [namespace children test_ns_hier1::test_ns_hier2]
} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b}
test namespace-old-5.15 {querying namespace children} {
lsort [namespace eval test_ns_hier1::test_ns_hier2 {namespace children}]
} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b}
test namespace-old-5.16 {querying namespace children with patterns} {
lsort [namespace children test_ns_hier1::test_ns_hier2 test_ns_*]
} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b}
test namespace-old-5.17 {querying namespace children with patterns} {
lsort [namespace children test_ns_hier1::test_ns_hier2 *b]
} {::test_ns_hier1::test_ns_hier2::test_ns_hier3b}
test namespace-old-5.18 {usage for "namespace parent"} {
list [catch {namespace parent x y} msg] $msg
} {1 {wrong # args: should be "namespace parent ?name?"}}
test namespace-old-5.19 {command "namespace parent" must get valid namespace} {
list [catch {namespace parent xyzzy} msg] $msg
} {1 {unknown namespace "xyzzy" in namespace parent command}}
test namespace-old-5.20 {querying namespace parent} {
list [namespace eval :: {namespace parent}] \
[namespace eval test_ns_hier1 {namespace parent}] \
[namespace eval test_ns_hier1::test_ns_hier2 {namespace parent}] \
[namespace eval test_ns_hier1::test_ns_hier2::test_ns_hier3a {namespace parent}] \
} {{} :: ::test_ns_hier1 ::test_ns_hier1::test_ns_hier2}
test namespace-old-5.21 {querying namespace parent for explicit namespace} {
list [namespace parent ::] \
[namespace parent test_ns_hier1] \
[namespace parent test_ns_hier1::test_ns_hier2] \
[namespace parent test_ns_hier1::test_ns_hier2::test_ns_hier3a]
} {{} :: ::test_ns_hier1 ::test_ns_hier1::test_ns_hier2}
# -----------------------------------------------------------------------
# TEST: name resolution and caching
# -----------------------------------------------------------------------
test namespace-old-6.1 {relative ns names only looked up in current ns} {
namespace eval test_ns_cache1 {}
namespace eval test_ns_cache2 {}
namespace eval test_ns_cache2::test_ns_cache3 {}
set trigger {
namespace eval test_ns_cache2 {namespace current}
}
set trigger2 {
namespace eval test_ns_cache2::test_ns_cache3 {namespace current}
}
list [namespace eval test_ns_cache1 $trigger] \
[namespace eval test_ns_cache1 $trigger2]
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
test namespace-old-6.2 {relative ns names only looked up in current ns} {
namespace eval test_ns_cache1::test_ns_cache2 {}
list [namespace eval test_ns_cache1 $trigger] \
[namespace eval test_ns_cache1 $trigger2]
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
test namespace-old-6.3 {relative ns names only looked up in current ns} {
namespace eval test_ns_cache1::test_ns_cache2::test_ns_cache3 {}
list [namespace eval test_ns_cache1 $trigger] \
[namespace eval test_ns_cache1 $trigger2]
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
test namespace-old-6.4 {relative ns names only looked up in current ns} {
namespace delete test_ns_cache1::test_ns_cache2
list [namespace eval test_ns_cache1 $trigger] \
[namespace eval test_ns_cache1 $trigger2]
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
test namespace-old-6.5 {define test commands} {
proc test_ns_cache_cmd {} {
return "global version"
}
namespace eval test_ns_cache1 {
proc trigger {} {
test_ns_cache_cmd
}
}
test_ns_cache1::trigger
} {global version}
test namespace-old-6.6 {one-level check for command shadowing} {
proc test_ns_cache1::test_ns_cache_cmd {} {
return "cache1 version"
}
test_ns_cache1::trigger
} {cache1 version}
test namespace-old-6.7 {renaming commands changes command epoch} {
namespace eval test_ns_cache1 {
rename test_ns_cache_cmd test_ns_new
}
test_ns_cache1::trigger
} {global version}
test namespace-old-6.8 {renaming back handles shadowing} {
namespace eval test_ns_cache1 {
rename test_ns_new test_ns_cache_cmd
}
test_ns_cache1::trigger
} {cache1 version}
test namespace-old-6.9 {deleting commands changes command epoch} {
namespace eval test_ns_cache1 {
rename test_ns_cache_cmd ""
}
test_ns_cache1::trigger
} {global version}
test namespace-old-6.10 {define test namespaces} {
namespace eval test_ns_cache2 {
proc test_ns_cache_cmd {} {
return "global cache2 version"
}
}
namespace eval test_ns_cache1 {
proc trigger {} {
test_ns_cache2::test_ns_cache_cmd
}
}
namespace eval test_ns_cache1::test_ns_cache2 {
proc trigger {} {
test_ns_cache_cmd
}
}
list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger]
} {{global cache2 version} {global version}}
test namespace-old-6.11 {commands affect all parent namespaces} {
proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} {
return "cache2 version"
}
list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger]
} {{cache2 version} {cache2 version}}
test namespace-old-6.12 {define test variables} {
variable test_ns_cache_var "global version"
set trigger {set test_ns_cache_var}
namespace eval test_ns_cache1 $trigger
} {global version}
test namespace-old-6.13 {one-level check for variable shadowing} {
namespace eval test_ns_cache1 {
variable test_ns_cache_var "cache1 version"
}
namespace eval test_ns_cache1 $trigger
} {cache1 version}
test namespace-old-6.14 {deleting variables changes variable epoch} {
namespace eval test_ns_cache1 {
unset test_ns_cache_var
}
namespace eval test_ns_cache1 $trigger
} {global version}
test namespace-old-6.15 {define test namespaces} {
namespace eval test_ns_cache2 {
variable test_ns_cache_var "global cache2 version"
}
set trigger2 {set test_ns_cache2::test_ns_cache_var}
list [namespace eval test_ns_cache1 $trigger2] \
[namespace eval test_ns_cache1::test_ns_cache2 $trigger]
} {{global cache2 version} {global version}}
test namespace-old-6.16 {public variables affect all parent namespaces} {
variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version"
list [namespace eval test_ns_cache1 $trigger2] \
[namespace eval test_ns_cache1::test_ns_cache2 $trigger]
} {{cache2 version} {cache2 version}}
test namespace-old-6.17 {usage for "namespace which"} {
list [catch "namespace which -baz" msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-old-6.18 {usage for "namespace which"} {
list [catch "namespace which -command" msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-old-6.19 {querying: namespace which -command} {
proc test_ns_cache1::test_ns_cache_cmd {} {
return "cache1 version"
}
list [namespace eval :: {namespace which test_ns_cache_cmd}] \
[namespace eval test_ns_cache1 {namespace which test_ns_cache_cmd}] \
[namespace eval :: {namespace which -command test_ns_cache_cmd}] \
[namespace eval test_ns_cache1 {namespace which -command test_ns_cache_cmd}]
} {::test_ns_cache_cmd ::test_ns_cache1::test_ns_cache_cmd ::test_ns_cache_cmd ::test_ns_cache1::test_ns_cache_cmd}
test namespace-old-6.20 {command "namespace which" may not find commands} {
namespace eval test_ns_cache1 {namespace which -command xyzzy}
} {}
test namespace-old-6.21 {querying: namespace which -variable} {
namespace eval test_ns_cache1::test_ns_cache2 {
namespace which -variable test_ns_cache_var
}
} {::test_ns_cache1::test_ns_cache2::test_ns_cache_var}
test namespace-old-6.22 {command "namespace which" may not find variables} {
namespace eval test_ns_cache1 {namespace which -variable xyzzy}
} {}
# -----------------------------------------------------------------------
# TEST: uplevel/upvar across namespace boundaries
# -----------------------------------------------------------------------
test namespace-old-7.1 {define test namespace} {
namespace eval test_ns_uplevel {
variable x 0
variable y 1
proc show_vars {num} {
return [uplevel $num {info vars}]
}
proc test_uplevel {num} {
set a 0
set b 1
namespace eval ::test_ns_uplevel " return \[show_vars $num\] "
}
}
} {}
test namespace-old-7.2 {uplevel can access namespace call frame} {
list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] x]>=0}] \
[expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] y]>=0}]
} {1 1}
test namespace-old-7.3 {uplevel can go beyond namespace call frame} {
lsort [test_ns_uplevel::test_uplevel 2]
} {a b num}
test namespace-old-7.4 {uplevel can go up to global context} {
expr {[test_ns_uplevel::test_uplevel 3] == [info globals]}
} {1}
test namespace-old-7.5 {absolute call frame references work too} {
list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] x]>=0}] \
[expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] y]>=0}]
} {1 1}
test namespace-old-7.6 {absolute call frame references work too} {
lsort [test_ns_uplevel::test_uplevel #1]
} {a b num}
test namespace-old-7.7 {absolute call frame references work too} {
expr {[test_ns_uplevel::test_uplevel #0] == [info globals]}
} {1}
test namespace-old-7.8 {namespaces are included in the call stack} {
namespace eval test_ns_upvar {
variable scope "test_ns_upvar"
proc show_val {var num} {
upvar $num $var x
return $x
}
proc test_upvar {num} {
set scope "test_ns_upvar::test_upvar"
namespace eval ::test_ns_upvar " return \[show_val scope $num\] "
}
}
} {}
test namespace-old-7.9 {upvar can access namespace call frame} {
test_ns_upvar::test_upvar 1
} {test_ns_upvar}
test namespace-old-7.10 {upvar can go beyond namespace call frame} {
test_ns_upvar::test_upvar 2
} {test_ns_upvar::test_upvar}
test namespace-old-7.11 {absolute call frame references work too} {
test_ns_upvar::test_upvar #2
} {test_ns_upvar}
test namespace-old-7.12 {absolute call frame references work too} {
test_ns_upvar::test_upvar #1
} {test_ns_upvar::test_upvar}
# -----------------------------------------------------------------------
# TEST: variable traces across namespace boundaries
# -----------------------------------------------------------------------
test namespace-old-8.1 {traces work across namespace boundaries} {
namespace eval test_ns_trace {
namespace eval foo {
variable x ""
}
variable status ""
proc monitor {name1 name2 op} {
variable status
lappend status "$op: $name1"
}
trace variable foo::x rwu [namespace code monitor]
}
set test_ns_trace::foo::x "yes!"
set test_ns_trace::foo::x
unset test_ns_trace::foo::x
namespace eval test_ns_trace { set status }
} {{w: test_ns_trace::foo::x} {r: test_ns_trace::foo::x} {u: test_ns_trace::foo::x}}
# -----------------------------------------------------------------------
# TEST: imported commands
# -----------------------------------------------------------------------
test namespace-old-9.1 {empty "namespace export" list} {
list [catch "namespace export" msg] $msg
} {0 {}}
test namespace-old-9.2 {usage for "namespace export" command} {
list [catch "namespace export test_ns_trace::zzz" msg] $msg
} {1 {invalid export pattern "test_ns_trace::zzz": pattern can't specify a namespace}}
test namespace-old-9.3 {define test namespaces for import} {
namespace eval test_ns_export {
namespace export cmd1 cmd2 cmd3
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
proc cmd3 {args} {return "cmd3: $args"}
proc cmd4 {args} {return "cmd4: $args"}
proc cmd5 {args} {return "cmd5: $args"}
proc cmd6 {args} {return "cmd6: $args"}
}
lsort [info commands test_ns_export::*]
} {::test_ns_export::cmd1 ::test_ns_export::cmd2 ::test_ns_export::cmd3 ::test_ns_export::cmd4 ::test_ns_export::cmd5 ::test_ns_export::cmd6}
test namespace-old-9.4 {check export status} {
set x ""
namespace eval test_ns_import {
namespace export cmd1 cmd2
namespace import ::test_ns_export::*
}
foreach cmd [lsort [info commands test_ns_import::*]] {
lappend x $cmd
}
set x
} {::test_ns_import::cmd1 ::test_ns_import::cmd2 ::test_ns_import::cmd3}
test namespace-old-9.5 {empty import list in "namespace import" command} {
namespace import
} {}
test namespace-old-9.6 {empty import list for "namespace import" command} {
namespace import
} {}
test namespace-old-9.7 {empty forget list for "namespace forget" command} {
namespace forget
} {}
catch {rename cmd1 {}}
catch {rename cmd2 {}}
catch {rename ncmd {}}
catch {rename ncmd1 {}}
catch {rename ncmd2 {}}
test namespace-old-9.8 {only exported commands are imported} {
namespace import test_ns_import::cmd*
set x [lsort [info commands cmd*]]
} {cmd1 cmd2}
test namespace-old-9.9 {imported commands work just the same as original} {
list [cmd1 test 1 2 3] [test_ns_import::cmd1 test 4 5 6]
} {{cmd1: test 1 2 3} {cmd1: test 4 5 6}}
test namespace-old-9.10 {commands can be imported from many namespaces} {
namespace eval test_ns_import2 {
namespace export ncmd ncmd1 ncmd2
proc ncmd {args} {return "ncmd: $args"}
proc ncmd1 {args} {return "ncmd1: $args"}
proc ncmd2 {args} {return "ncmd2: $args"}
proc ncmd3 {args} {return "ncmd3: $args"}
}
namespace import test_ns_import2::*
lsort [concat [info commands cmd*] [info commands ncmd*]]
} {cmd1 cmd2 ncmd ncmd1 ncmd2}
test namespace-old-9.11 {imported commands can be removed by deleting them} {
rename cmd1 ""
lsort [concat [info commands cmd*] [info commands ncmd*]]
} {cmd2 ncmd ncmd1 ncmd2}
test namespace-old-9.12 {command "namespace forget" checks for valid namespaces} {
list [catch {namespace forget xyzzy::*} msg] $msg
} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}}
test namespace-old-9.13 {command "namespace forget" ignores patterns that don't match} {
list [catch {namespace forget test_ns_import::xy*zzy} msg] $msg \
[lsort [info commands cmd?]]
} {0 {} cmd2}
test namespace-old-9.14 {imported commands can be removed} {
namespace forget test_ns_import::cmd?
list [lsort [info commands cmd?]] \
[catch {cmd1 another test} msg] $msg
} {{} 1 {invalid command name "cmd1"}}
test namespace-old-9.15 {existing commands can't be overwritten} {
proc cmd1 {x y} {
return [expr $x+$y]
}
list [catch {namespace import test_ns_import::cmd?} msg] $msg \
[cmd1 3 5]
} {1 {can't import command "cmd1": already exists} 8}
test namespace-old-9.16 {use "-force" option to override existing commands} {
list [cmd1 3 5] \
[namespace import -force test_ns_import::cmd?] \
[cmd1 3 5]
} {8 {} {cmd1: 3 5}}
test namespace-old-9.17 {commands can be imported into many namespaces} {
namespace eval test_ns_import_use {
namespace import ::test_ns_import::* ::test_ns_import2::ncmd?
lsort [concat [info commands ::test_ns_import_use::cmd*] \
[info commands ::test_ns_import_use::ncmd*]]
}
} {::test_ns_import_use::cmd1 ::test_ns_import_use::cmd2 ::test_ns_import_use::ncmd1 ::test_ns_import_use::ncmd2}
test namespace-old-9.18 {when command is deleted, imported commands go away} {
namespace eval test_ns_import { rename cmd1 "" }
list [info commands cmd1] \
[namespace eval test_ns_import_use {info commands cmd1}]
} {{} {}}
test namespace-old-9.19 {when namesp is deleted, all imported commands go away} {
namespace delete test_ns_import test_ns_import2
list [info commands cmd*] \
[info commands ncmd*] \
[namespace eval test_ns_import_use {info commands cmd*}] \
[namespace eval test_ns_import_use {info commands ncmd*}] \
} {{} {} {} {}}
# -----------------------------------------------------------------------
# TEST: scoped values
# -----------------------------------------------------------------------
test namespace-old-10.1 {define namespace for scope test} {
namespace eval test_ns_inscope {
variable x "x-value"
proc show {args} {
return "show: $args"
}
proc do {args} {
return [eval $args]
}
list [set x] [show test]
}
} {x-value {show: test}}
test namespace-old-10.2 {command "namespace code" requires one argument} {
list [catch {namespace code} msg] $msg
} {1 {wrong # args: should be "namespace code arg"}}
test namespace-old-10.3 {command "namespace code" requires one argument} {
list [catch {namespace code first "second arg" third} msg] $msg
} {1 {wrong # args: should be "namespace code arg"}}
test namespace-old-10.4 {command "namespace code" gets current namesp context} {
namespace eval test_ns_inscope {
namespace code {"1 2 3" "4 5" 6}
}
} {::namespace inscope ::test_ns_inscope {"1 2 3" "4 5" 6}}
test namespace-old-10.5 {with one arg, first "scope" sticks} {
set sval [namespace eval test_ns_inscope {namespace code {one two}}]
namespace code $sval
} {::namespace inscope ::test_ns_inscope {one two}}
test namespace-old-10.6 {with many args, each "scope" adds new args} {
set sval [namespace eval test_ns_inscope {namespace code {one two}}]
namespace code "$sval three"
} {::namespace inscope ::test_ns_inscope {one two} three}
test namespace-old-10.7 {scoped commands work with eval} {
set cref [namespace eval test_ns_inscope {namespace code show}]
list [eval $cref "a" "b c" "d e f"]
} {{show: a b c d e f}}
test namespace-old-10.8 {scoped commands execute in namespace context} {
set cref [namespace eval test_ns_inscope {
namespace code {set x "some new value"}
}]
list [set test_ns_inscope::x] [eval $cref] [set test_ns_inscope::x]
} {x-value {some new value} {some new value}}
foreach cmd [info commands test_ns_*] {
rename $cmd ""
}
catch {rename cmd {}}
catch {rename cmd1 {}}
catch {rename cmd2 {}}
catch {rename ncmd {}}
catch {rename ncmd1 {}}
catch {rename ncmd2 {}}
catch {unset cref}
catch {unset trigger}
catch {unset trigger2}
catch {unset sval}
catch {unset msg}
catch {unset x}
catch {unset test_ns_var_global}
catch {unset cmd}
eval namespace delete [namespace children :: test_ns_*]
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/stack.test 0000644 0036047 0045461 00000005623 12133546540 014066 0 ustar dgp 771div # Tests that the stack size is big enough for the application.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# 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.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Note that a failure in this test results in a crash of the executable.
# In order to avoid that, we do a basic check of the current stacksize.
# This size can be changed with ulimit (ksh/bash/sh) or limit (csh/tcsh).
# This doesn't catch all cases, for example threads of lower stacksize
# can still squeak through. A core check is really needed. -- JH
if {[string equal $::tcl_platform(platform) "unix"]
&& ![string equal $::tcl_platform(os) "Windows NT"]} {
set stackSize [exec /bin/sh -c "ulimit -s"]
if {[string is integer $stackSize] && ($stackSize < 2400)} {
puts stderr "WARNING: the default application stacksize of $stackSize\
may cause Tcl to\ncrash due to stack overflow before the\
recursion limit is reached.\nA minimum stacksize of 2400\
kbytes is recommended.\nSkipping infinite recursion test."
::tcltest::testConstraint minStack2400 0
} else {
::tcltest::testConstraint minStack2400 1
}
} else {
::tcltest::testConstraint minStack2400 1
}
test stack-1.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
proc recurse {} { return [recurse] }
catch {recurse} rv
rename recurse {}
set rv
} {too many nested evaluations (infinite loop?)}
test stack-2.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
# do this in a slave to not mess with parent
set slave stack-2.1
interp create $slave
$slave eval { interp alias {} unknown {} notaknownproc }
set msg [$slave eval { catch {foo} msg ; set msg }]
interp delete $slave
set msg
} {too many nested evaluations (infinite loop?)}
# Make sure that there is enough stack to run regexp even if we're
# close to the recursion limit. [Bug 947070]
test stack-3.1 {enough room for regexp near recursion limit} \
-constraints { win } \
-setup {
set ::limit [interp recursionlimit {} 10000]
set ::depth 0
proc a { max } {
if { [info level] < $max } {
set ::depth [info level]
a $max
} else {
regexp {^ ?} x
}
}
list [catch { a 10001 }]
incr depth -3
set depth2 $depth
} -body {
list [catch { a $::depth } result] \
$result [expr { $::depth2 - $::depth }]
} -cleanup {
interp recursionlimit {} $::limit
} -result {0 1 1}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
tcl8.4.20/tests/stringObj.test 0000644 0036047 0045461 00000042135 11737050674 014730 0 ustar dgp 771div # Commands covered: none
#
# This file contains tests for the procedures in tclStringObj.c
# that implement the Tcl type manager for the string type.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
puts "command, so I can't test the Tcl type and object support."
::tcltest::cleanupTests
return
}
test stringObj-1.1 {string type registration} {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first != -1}]
} {1}
test stringObj-2.1 {Tcl_NewStringObj} {
set result ""
lappend result [testobj freeallvars]
lappend result [teststringobj set 1 abcd]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} abcd string 2}
test stringObj-3.1 {Tcl_SetStringObj, existing "empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testobj newobj 1]
lappend result [teststringobj set 1 xyz] ;# makes existing obj a string
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} {} xyz string 2}
test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} {
set result ""
lappend result [testobj freeallvars]
lappend result [testintobj set 1 512]
lappend result [teststringobj set 1 foo] ;# makes existing obj a string
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 512 foo string 2}
test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} {
testobj freeallvars
teststringobj set 1 test
teststringobj setlength 1 3
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {3 4 tes}
test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} {
testobj freeallvars
teststringobj set 1 abcdef
teststringobj setlength 1 10
list [teststringobj length 1] [teststringobj length2 1]
} {10 10}
test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {
testobj freeallvars
teststringobj set 1 abcdef
teststringobj append 1 xyzq -1
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {10 20 abcdefxyzq}
test stringObj-4.4 {Tcl_SetObjLength procedure, "expty string", length 0} {
testobj freeallvars
testobj newobj 1
teststringobj setlength 1 0
list [teststringobj length2 1] [teststringobj get 1]
} {0 {}}
test stringObj-5.1 {Tcl_AppendToObj procedure, type conversion} {
testobj freeallvars
testintobj set2 1 43
teststringobj append 1 xyz -1
teststringobj get 1
} {43xyz}
test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} {
testobj freeallvars
teststringobj set 1 {x y }
teststringobj append 1 bbCCddEE 4
teststringobj append 1 123 -1
teststringobj get 1
} {x y bbCC123}
test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {
testobj freeallvars
teststringobj set 1 xyz
teststringobj setlength 1 15
teststringobj setlength 1 2
set result {}
teststringobj append 1 1234567890123 -1
lappend result [teststringobj length 1] [teststringobj length2 1]
teststringobj setlength 1 10
teststringobj append 1 abcdef -1
lappend result [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {15 15 16 32 xy12345678abcdef}
test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} {
testobj freeallvars
teststringobj set2 1 [list a b]
teststringobj appendstrings 1 xyz { 1234 } foo
teststringobj get 1
} {a bxyz 1234 foo}
test stringObj-6.2 {Tcl_AppendStringsToObj procedure, counting space} {
testobj freeallvars
teststringobj set 1 abc
teststringobj appendstrings 1
list [teststringobj length 1] [teststringobj get 1]
} {3 abc}
test stringObj-6.3 {Tcl_AppendStringsToObj procedure, counting space} {
testobj freeallvars
teststringobj set 1 abc
teststringobj appendstrings 1 {} {} {} {}
list [teststringobj length 1] [teststringobj get 1]
} {3 abc}
test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} {
testobj freeallvars
teststringobj set 1 abc
teststringobj appendstrings 1 { 123 } abcdefg
list [teststringobj length 1] [teststringobj get 1]
} {15 {abc 123 abcdefg}}
test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 123 abcdefg
list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1]
} {10 10 123abcdefg}
test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} {
testobj freeallvars
teststringobj set 1 abc
teststringobj setlength 1 10
teststringobj setlength 1 2
teststringobj appendstrings 1 34567890
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {10 10 ab34567890}
test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {
testobj freeallvars
teststringobj set 1 abc
teststringobj setlength 1 10
teststringobj setlength 1 2
teststringobj appendstrings 1 34567890x
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {11 22 ab34567890x}
test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 {}
list [teststringobj length2 1] [teststringobj get 1]
} {0 {}}
test stringObj-6.9 {Tcl_AppendStringToObj, pure unicode} {
testobj freeallvars
teststringobj set2 1 [string replace abc 1 1 d]
teststringobj appendstrings 1 foo bar soom
teststringobj get 1
} adcfoobarsoom
test stringObj-7.1 {SetStringFromAny procedure} {
testobj freeallvars
teststringobj set2 1 [list a b]
teststringobj append 1 x -1
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {4 8 {a bx}}
test stringObj-7.2 {SetStringFromAny procedure, null object} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 {}
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {0 0 {}}
test stringObj-7.3 {SetStringFromAny called with non-string obj} {
set x 2345
list [incr x] [testobj objtype $x] [string index $x end] \
[testobj objtype $x]
} {2346 int 6 string}
test stringObj-7.4 {SetStringFromAny called with string obj} {
set x "abcdef"
list [string length $x] [testobj objtype $x] \
[string length $x] [testobj objtype $x]
} {6 string 6 string}
test stringObj-8.1 {DupStringInternalRep procedure} {
testobj freeallvars
teststringobj set 1 {}
teststringobj append 1 abcde -1
testobj duplicate 1 2
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj ualloc 1] [teststringobj get 1] \
[teststringobj length 2] [teststringobj length2 2] \
[teststringobj ualloc 2] [teststringobj get 2]
} {5 10 0 abcde 5 5 0 abcde}
test stringObj-8.2 {DupUnicodeInternalRep, mixed width chars} {
set x abcяПЎghi
string length $x
set y $x
list [testobj objtype $x] [testobj objtype $y] [append x "ЎПя"] \
[set y] [testobj objtype $x] [testobj objtype $y]
} {string string abcяПЎghiЎПя abcяПЎghi string string}
test stringObj-8.3 {DupUnicodeInternalRep, mixed width chars} {
set x abcяПЎghi
set y $x
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x "ЎПя"] \
[set y] [testobj objtype $x] [testobj objtype $y]
} {string string abcяПЎghiЎПя abcяПЎghi string string}
test stringObj-8.4 {DupUnicodeInternalRep, all byte-size chars} {
set x abcdefghi
string length $x
set y $x
list [testobj objtype $x] [testobj objtype $y] [append x jkl] \
[set y] [testobj objtype $x] [testobj objtype $y]
} {string string abcdefghijkl abcdefghi string string}
test stringObj-8.5 {DupUnicodeInternalRep, all byte-size chars} {
set x abcdefghi
set y $x
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x jkl] \
[set y] [testobj objtype $x] [testobj objtype $y]
} {string string abcdefghijkl abcdefghi string string}
test stringObj-9.1 {TclAppendObjToObj, mixed src & dest} {
set x abcяПЎghi
set y ЎПя
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
} {string none abcяПЎghiЎПя ЎПя string none}
test stringObj-9.2 {TclAppendObjToObj, mixed src & dest} {
set x abcяПЎghi
string length $x
list [testobj objtype $x] [append x $x] [testobj objtype $x] \
[append x $x] [testobj objtype $x]
} {string abcяПЎghiabcяПЎghi string\
abcяПЎghiabcяПЎghiabcяПЎghiabcяПЎghi\
string}
test stringObj-9.3 {TclAppendObjToObj, mixed src & 1-byte dest} {
set x abcdefghi
set y ЎПя
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
} {string none abcdefghiЎПя ЎПя string none}
test stringObj-9.4 {TclAppendObjToObj, 1-byte src & dest} {
set x abcdefghi
set y jkl
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
} {string none abcdefghijkl jkl string none}
test stringObj-9.5 {TclAppendObjToObj, 1-byte src & dest} {
set x abcdefghi
string length $x
list [testobj objtype $x] [append x $x] [testobj objtype $x] \
[append x $x] [testobj objtype $x]
} {string abcdefghiabcdefghi string abcdefghiabcdefghiabcdefghiabcdefghi\
string}
test stringObj-9.6 {TclAppendObjToObj, 1-byte src & mixed dest} {
set x abcяПЎghi
set y jkl
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
} {string none abcяПЎghijkl jkl string none}
test stringObj-9.7 {TclAppendObjToObj, integer src & dest} {
set x [expr {4 * 5}]
set y [expr {4 + 5}]
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[testobj objtype $x] [append x $y] [testobj objtype $x] \
[testobj objtype $y]
} {int int 209 string 2099 string int}
test stringObj-9.8 {TclAppendObjToObj, integer src & dest} {
set x [expr {4 * 5}]
list [testobj objtype $x] [append x $x] [testobj objtype $x] \
[append x $x] [testobj objtype $x]
} {int 2020 string 20202020 string}
test stringObj-9.9 {TclAppendObjToObj, integer src & 1-byte dest} {
set x abcdefghi
set y [expr {4 + 5}]
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
} {string int abcdefghi9 9 string int}
test stringObj-9.10 {TclAppendObjToObj, integer src & mixed dest} {
set x abcяПЎghi
set y [expr {4 + 5}]
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
} {string int abcяПЎghi9 9 string int}
test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} {
# bug 2678, in <=8.2.0, the second obj (the one to append) in
# Tcl_AppendObjToObj was not correctly checked to see if it was
# all one byte chars, so a unicode string would be added as one
# byte chars.
set x abcdef
set len [string length $x]
set y aќbхcя
set len [string length $y]
append x $y
string length $x
set q {}
for {set i 0} {$i < 12} {incr i} {
lappend q [string index $x $i]
}
set q
} {a b c d e f a ќ b х c я}
test stringObj-10.1 {Tcl_GetRange with all byte-size chars} {
set x "abcdef"
list [testobj objtype $x] [set y [string range $x 1 end-1]] \
[testobj objtype $x] [testobj objtype $y]
} [list none bcde string string]
test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {
# Because this test does not use \uXXXX notation below instead of
# hardcoding the values, it may fail in multibyte locales. However,
# we need to test that the parser produces untyped objects even when there
# are high-ASCII characters in the input (like "я"). I don't know what
# else to do but inline those characters here.
set x "abcяяdef"
list [testobj objtype $x] [set y [string range $x 1 end-1]] \
[testobj objtype $x] [testobj objtype $y]
} [list none "bc\u00EF\u00EFde" string string]
test stringObj-10.3 {Tcl_GetRange with some mixed width chars} {
# set x "abcяяdef"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
set x "abc\u00EF\u00EFdef"
string length $x
list [testobj objtype $x] [set y [string range $x 1 end-1]] \
[testobj objtype $x] [testobj objtype $y]
} [list string "bc\u00EF\u00EFde" string string]
test stringObj-10.4 {Tcl_GetRange with some mixed width chars} {
# set a "яaПbЎcяПdЎ"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
set result [list]
while {[string length $a] > 0} {
set a [string range $a 1 end-1]
lappend result $a
}
set result
} [list a\u00BFb\u00AEc\u00EF\u00BFd \
\u00BFb\u00AEc\u00EF\u00BF \
b\u00AEc\u00EF \
\u00AEc \
{}]
test stringObj-11.1 {UpdateStringOfString} {
set x 2345
list [string index $x end] [testobj objtype $x] [incr x] \
[testobj objtype $x]
} {5 string 2346 int}
test stringObj-12.1 {Tcl_GetUniChar with byte-size chars} {
set x "abcdefghi"
list [string index $x 0] [string index $x 1]
} {a b}
test stringObj-12.2 {Tcl_GetUniChar with byte-size chars} {
set x "abcdefghi"
list [string index $x 3] [string index $x end]
} {d i}
test stringObj-12.3 {Tcl_GetUniChar with byte-size chars} {
set x "abcdefghi"
list [string index $x end] [string index $x end-1]
} {i h}
test stringObj-12.4 {Tcl_GetUniChar with mixed width chars} {
string index "яaПbЎcЎПdя" 0
} "я"
test stringObj-12.5 {Tcl_GetUniChar} {
set x "яaПbЎcЎПdя"
list [string index $x 4] [string index $x 0]
} {Ў я}
test stringObj-12.6 {Tcl_GetUniChar} {
string index "яaПbЎcяПdЎ" end
} "Ў"
test stringObj-13.1 {Tcl_GetCharLength with byte-size chars} {
set a ""
list [string length $a] [string length $a]
} {0 0}
test stringObj-13.2 {Tcl_GetCharLength with byte-size chars} {
string length "a"
} 1
test stringObj-13.3 {Tcl_GetCharLength with byte-size chars} {
set a "abcdef"
list [string length $a] [string length $a]
} {6 6}
test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} {
string length "Ў"
} 1
test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} {
# string length "яПЎяПЎ"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE"
} 6
test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} {
# set a "яaПbЎcяПdЎ"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
list [string length $a] [string length $a]
} {10 10}
test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {
# SF bug #684699
string length [encoding convertfrom identity \x00]
} 1
test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {
string length [encoding convertfrom identity \x01\x00\x02]
} 3
test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} {
teststringobj set 1 foo
teststringobj getunicode 1
teststringobj append 1 bar -1
teststringobj getunicode 1
teststringobj append 1 bar -1
teststringobj setlength 1 0
teststringobj append 1 bar -1
teststringobj get 1
} {bar}
test stringObj-15.1 {Tcl_Append*ToObj: self appends} {
teststringobj set 1 foo
teststringobj appendself 1 0
} foofoo
test stringObj-15.2 {Tcl_Append*ToObj: self appends} {
teststringobj set 1 foo
teststringobj appendself 1 1
} foooo
test stringObj-15.3 {Tcl_Append*ToObj: self appends} {
teststringobj set 1 foo
teststringobj appendself 1 2
} fooo
test stringObj-15.4 {Tcl_Append*ToObj: self appends} {
teststringobj set 1 foo
teststringobj appendself 1 3
} foo
test stringObj-15.5 {Tcl_Append*ToObj: self appends} {
teststringobj set 1 foo
teststringobj appendself2 1 0
} foofoo
test stringObj-15.6 {Tcl_Append*ToObj: self appends} {
teststringobj set 1 foo
teststringobj appendself2 1 1
} foooo
test stringObj-15.7 {Tcl_Append*ToObj: self appends} {
teststringobj set 1 foo
teststringobj appendself2 1 2
} fooo
test stringObj-15.8 {Tcl_Append*ToObj: self appends} {
teststringobj set 1 foo
teststringobj appendself2 1 3
} foo
testobj freeallvars
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/httpd 0000644 0036047 0045461 00000012155 12153150337 013121 0 ustar dgp 771div #
# The httpd_ procedures implement a stub http server.
#
# Copyright (c) 1997-1998 Sun Microsystems, Inc.
# Copyright (c) 1999-2000 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#set httpLog 1
proc httpd_init {{port 8015}} {
socket -server httpdAccept $port
}
proc httpd_log {args} {
global httpLog
if {[info exists httpLog] && $httpLog} {
puts stderr "httpd: [join $args { }]"
}
}
array set httpdErrors {
204 {No Content}
400 {Bad Request}
401 {Authorization Required}
404 {Not Found}
503 {Service Unavailable}
504 {Service Temporarily Unavailable}
}
proc httpdError {sock code args} {
global httpdErrors
puts $sock "$code $httpdErrors($code)"
httpd_log "error: [join $args { }]"
}
proc httpdAccept {newsock ipaddr port} {
global httpd
upvar #0 httpd$newsock data
fconfigure $newsock -blocking 0 -translation {auto crlf}
httpd_log $newsock Connect $ipaddr $port
set data(ipaddr) $ipaddr
after 50 [list fileevent $newsock readable [list httpdRead $newsock]]
}
# read data from a client request
proc httpdRead { sock } {
upvar #0 httpd$sock data
if {[eof $sock]} {
set readCount -1
} elseif {![info exists data(state)]} {
# Read the protocol line and parse out the URL and query
set readCount [gets $sock line]
if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/(1.[01])} \
$line x data(proto) data(url) data(query) data(httpversion)] {
set data(state) mime
httpd_log $sock Query $line
} else {
httpdError $sock 400
httpd_log $sock Error "bad first line:$line"
httpdSockDone $sock
}
return
} elseif {$data(state) == "mime"} {
# Read the HTTP headers
set readCount [gets $sock line]
} elseif {$data(state) == "query"} {
# Read the query data
if {![info exists data(length_orig)]} {
set data(length_orig) $data(length)
}
set line [read $sock $data(length)]
set readCount [string length $line]
incr data(length) -$readCount
}
# string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
set state [string compare $readCount 0],$data(state),$data(proto)
httpd_log $sock $state
switch -- $state {
-1,mime,HEAD -
-1,mime,GET -
-1,mime,POST {
# gets would block
return
}
0,mime,HEAD -
0,mime,GET -
0,query,POST {
# Empty line at end of headers,
# or eof after query data
httpdRespond $sock
}
0,mime,POST {
# Empty line between headers and query data
if {![info exists data(mime,content-length)]} {
httpd_log $sock Error "No Content-Length for POST"
httpdError $sock 400
httpdSockDone $sock
} else {
set data(state) query
set data(length) $data(mime,content-length)
# Special case to simulate servers that respond
# without reading the post data.
if {[string match *droppost* $data(url)]} {
fileevent $sock readable {}
httpdRespond $sock
}
}
}
1,mime,HEAD -
1,mime,POST -
1,mime,GET {
# A line of HTTP headers
if {[regexp {([^:]+):[ ]*(.*)} $line dummy key value]} {
set data(mime,[string tolower $key]) $value
}
}
-1,query,POST {
httpd_log $sock Error "unexpected eof on <$data(url)> request"
httpdError $sock 400
httpdSockDone $sock
}
1,query,POST {
append data(query) $line
if {$data(length) <= 0} {
set data(length) $data(length_orig)
httpdRespond $sock
}
}
default {
if {[eof $sock]} {
httpd_log $sock Error "unexpected eof on <$data(url)> request"
} else {
httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>"
}
httpdError $sock 404
httpdSockDone $sock
}
}
}
proc httpdSockDone { sock } {
upvar #0 httpd$sock data
unset data
catch {close $sock}
}
# Respond to the query.
proc httpdRespond { sock } {
global httpd bindata port
upvar #0 httpd$sock data
switch -glob -- $data(url) {
*binary* {
set html "$bindata[info hostname]:$port$data(url)"
set type application/octet-stream
}
*post* {
set html "Got [string length $data(query)] bytes"
set type text/plain
}
default {
set type text/html
set html "HTTP/1.0 TEST
Hello, World!
$data(proto) $data(url)
"
if {[info exists data(query)] && [string length $data(query)]} {
append html "Query\n\n"
foreach {key value} [split $data(query) &=] {
append html "- $key
- $value\n"
if {$key == "timeout"} {
after $value ;# pause
}
}
append html
\n
}
append html
}
}
# Catch errors from premature client closes
catch {
if {$data(proto) == "HEAD"} {
puts $sock "HTTP/1.0 200 OK"
} else {
puts $sock "HTTP/1.0 200 Data follows"
}
puts $sock "Date: [clock format [clock clicks]]"
puts $sock "Content-Type: $type"
puts $sock "Content-Length: [string length $html]"
puts $sock ""
flush $sock
if {$data(proto) != "HEAD"} {
fconfigure $sock -translation binary
puts -nonewline $sock $html
}
}
httpd_log $sock Done ""
httpdSockDone $sock
}
tcl8.4.20/tests/parseOld.test 0000644 0036047 0045461 00000037437 11737050674 014551 0 ustar dgp 771div # Commands covered: set (plus basic command syntax). Also tests the
# procedures in the file tclOldParse.c. This set of tests is an old
# one that predates the new parser in Tcl 8.1.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
tcltest::testConstraint testwordend \
[string equal "testwordend" [info commands testwordend]]
# Save the argv value for restoration later
set savedArgv $argv
proc fourArgs {a b c d} {
global arg1 arg2 arg3 arg4
set arg1 $a
set arg2 $b
set arg3 $c
set arg4 $d
}
proc getArgs args {
global argv
set argv $args
}
# Basic argument parsing.
test parseOld-1.1 {basic argument parsing} {
set arg1 {}
fourArgs a b c d
list $arg1 $arg2 $arg3 $arg4
} {a b c d}
test parseOld-1.2 {basic argument parsing} {
set arg1 {}
eval "fourArgs 123\v4\f56\r7890"
list $arg1 $arg2 $arg3 $arg4
} {123 4 56 7890}
# Quotes.
test parseOld-2.1 {quotes and variable-substitution} {
getArgs "a b c" d
set argv
} {{a b c} d}
test parseOld-2.2 {quotes and variable-substitution} {
set a 101
getArgs "a$a b c"
set argv
} {{a101 b c}}
test parseOld-2.3 {quotes and variable-substitution} {
set argv "xy[format xabc]"
set argv
} {xyxabc}
test parseOld-2.4 {quotes and variable-substitution} {
set argv "xy\t"
set argv
} xy\t
test parseOld-2.5 {quotes and variable-substitution} {
set argv "a b c
d e f"
set argv
} a\ b\tc\nd\ e\ f
test parseOld-2.6 {quotes and variable-substitution} {
set argv a"bcd"e
set argv
} {a"bcd"e}
# Braces.
test parseOld-3.1 {braces} {
getArgs {a b c} d
set argv
} "{a b c} d"
test parseOld-3.2 {braces} {
set a 101
set argv {a$a b c}
set b [string index $argv 1]
set b
} {$}
test parseOld-3.3 {braces} {
set argv {a[format xyz] b}
string length $argv
} 15
test parseOld-3.4 {braces} {
set argv {a\nb\}}
string length $argv
} 6
test parseOld-3.5 {braces} {
set argv {{{{}}}}
set argv
} "{{{}}}"
test parseOld-3.6 {braces} {
set argv a{{}}b
set argv
} "a{{}}b"
test parseOld-3.7 {braces} {
set a [format "last]"]
set a
} {last]}
# Command substitution.
test parseOld-4.1 {command substitution} {
set a [format xyz]
set a
} xyz
test parseOld-4.2 {command substitution} {
set a a[format xyz]b[format q]
set a
} axyzbq
test parseOld-4.3 {command substitution} {
set a a[
set b 22;
format %s $b
]b
set a
} a22b
test parseOld-4.4 {command substitution} {
set a 7.7
if [catch {expr int($a)}] {set a foo}
set a
} 7.7
# Variable substitution.
test parseOld-5.1 {variable substitution} {
set a 123
set b $a
set b
} 123
test parseOld-5.2 {variable substitution} {
set a 345
set b x$a.b
set b
} x345.b
test parseOld-5.3 {variable substitution} {
set _123z xx
set b $_123z^
set b
} xx^
test parseOld-5.4 {variable substitution} {
set a 78
set b a${a}b
set b
} a78b
test parseOld-5.5 {variable substitution} {catch {$_non_existent_} msg} 1
test parseOld-5.6 {variable substitution} {
catch {$_non_existent_} msg
set msg
} {can't read "_non_existent_": no such variable}
test parseOld-5.7 {array variable substitution} {
catch {unset a}
set a(xyz) 123
set b $a(xyz)foo
set b
} 123foo
test parseOld-5.8 {array variable substitution} {
catch {unset a}
set "a(x y z)" 123
set b $a(x y z)foo
set b
} 123foo
test parseOld-5.9 {array variable substitution} {
catch {unset a}; catch {unset qqq}
set "a(x y z)" qqq
set $a([format x]\ y [format z]) foo
set qqq
} foo
test parseOld-5.10 {array variable substitution} {
catch {unset a}
list [catch {set b $a(22)} msg] $msg
} {1 {can't read "a(22)": no such variable}}
test parseOld-5.11 {array variable substitution} {
set b a$!
set b
} {a$!}
test parseOld-5.12 {empty array name support} {
list [catch {set b a$()} msg] $msg
} {1 {can't read "()": no such variable}}
catch {unset a}
test parseOld-5.13 {array variable substitution} {
catch {unset a}
set long {This is a very long variable, long enough to cause storage \
allocation to occur in Tcl_ParseVar. If that storage isn't getting \
freed up correctly, then a core leak will occur when this test is \
run. This text is probably beginning to sound like drivel, but I've \
run out of things to say and I need more characters still.}
set a($long) 777
set b $a($long)
list $b [array names a]
} {777 {{This is a very long variable, long enough to cause storage \
allocation to occur in Tcl_ParseVar. If that storage isn't getting \
freed up correctly, then a core leak will occur when this test is \
run. This text is probably beginning to sound like drivel, but I've \
run out of things to say and I need more characters still.}}}
test parseOld-5.14 {array variable substitution} {
catch {unset a}; catch {unset b}; catch {unset a1}
set a1(22) foo
set a(foo) bar
set b $a($a1(22))
set b
} bar
catch {unset a}; catch {unset a1}
test parseOld-7.1 {backslash substitution} {
set a "\a\c\n\]\}"
string length $a
} 5
test parseOld-7.2 {backslash substitution} {
set a {\a\c\n\]\}}
string length $a
} 10
test parseOld-7.3 {backslash substitution} {
set a "abc\
def"
set a
} {abc def}
test parseOld-7.4 {backslash substitution} {
set a {abc\
def}
set a
} {abc def}
test parseOld-7.5 {backslash substitution} {
set msg {}
set a xxx
set error [catch {if {24 < \
35} {set a 22} {set \
a 33}} msg]
list $error $msg $a
} {0 22 22}
test parseOld-7.6 {backslash substitution} {
eval "concat abc\\"
} "abc\\"
test parseOld-7.7 {backslash substitution} {
eval "concat \\\na"
} "a"
test parseOld-7.8 {backslash substitution} {
eval "concat x\\\n a"
} "x a"
test parseOld-7.9 {backslash substitution} {
eval "concat \\x"
} "x"
test parseOld-7.10 {backslash substitution} {
eval "list a b\\\nc d"
} {a b c d}
test parseOld-7.11 {backslash substitution} {
eval "list a \"b c\"\\\nd e"
} {a {b c} d e}
test parseOld-7.12 {backslash substitution} {
list \ua2
} [bytestring "\xc2\xa2"]
test parseOld-7.13 {backslash substitution} {
list \u4e21
} [bytestring "\xe4\xb8\xa1"]
test parseOld-7.14 {backslash substitution} {
list \u4e2k
} [bytestring "\xd3\xa2k"]
# Semi-colon.
test parseOld-8.1 {semi-colons} {
set b 0
getArgs a;set b 2
set argv
} a
test parseOld-8.2 {semi-colons} {
set b 0
getArgs a;set b 2
set b
} 2
test parseOld-8.3 {semi-colons} {
getArgs a b ; set b 1
set argv
} {a b}
test parseOld-8.4 {semi-colons} {
getArgs a b ; set b 1
set b
} 1
# The following checks are to ensure that the interpreter's result
# gets re-initialized by Tcl_Eval in all the right places.
test parseOld-9.1 {result initialization} {concat abc} abc
test parseOld-9.2 {result initialization} {concat abc; proc foo {} {}} {}
test parseOld-9.3 {result initialization} {concat abc; proc foo {} $a} {}
test parseOld-9.4 {result initialization} {proc foo {} [concat abc]} {}
test parseOld-9.5 {result initialization} {concat abc; } abc
test parseOld-9.6 {result initialization} {
eval {
concat abc
}} abc
test parseOld-9.7 {result initialization} {} {}
test parseOld-9.8 {result initialization} {concat abc; ; ;} abc
# Syntax errors.
test parseOld-10.1 {syntax errors} {catch "set a \{bcd" msg} 1
test parseOld-10.2 {syntax errors} {
catch "set a \{bcd" msg
set msg
} {missing close-brace}
test parseOld-10.3 {syntax errors} {catch {set a "bcd} msg} 1
test parseOld-10.4 {syntax errors} {
catch {set a "bcd} msg
set msg
} {missing "}
#" Emacs formatting >:^(
test parseOld-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1
test parseOld-10.6 {syntax errors} {
catch {set a "bcd"xy} msg
set msg
} {extra characters after close-quote}
test parseOld-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1
test parseOld-10.8 {syntax errors} {
catch "set a {bcd}xy" msg
set msg
} {extra characters after close-brace}
test parseOld-10.9 {syntax errors} {catch {set a [format abc} msg} 1
test parseOld-10.10 {syntax errors} {
catch {set a [format abc} msg
set msg
} {missing close-bracket}
test parseOld-10.11 {syntax errors} {catch gorp-a-lot msg} 1
test parseOld-10.12 {syntax errors} {
catch gorp-a-lot msg
set msg
} {invalid command name "gorp-a-lot"}
test parseOld-10.13 {syntax errors} {
set a [concat {a}\
{b}]
set a
} {a b}
# The next test will fail on the Mac, 'cause the MSL uses a fixed sized
# buffer for %d conversions (LAME!). I won't leave the test out, however,
# since MetroWerks may some day fix this.
test parseOld-10.14 {syntax errors} {
list [catch {eval \$x[format "%01000d" 0](} msg] $msg $errorInfo
} {1 {missing )} {missing )
while executing
"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000..."
("eval" body line 1)
invoked from within
"eval \$x[format "%01000d" 0]("}}
test parseOld-10.15 {syntax errors, missplaced braces} {
catch {
proc misplaced_end_brace {} {
set what foo
set when [expr ${what}size - [set off$what]}]
} msg
set msg
} {extra characters after close-brace}
test parseOld-10.16 {syntax errors, missplaced braces} {
catch {
set a {
set what foo
set when [expr ${what}size - [set off$what]}]
} msg
set msg
} {extra characters after close-brace}
test parseOld-10.17 {syntax errors, unusual spacing} {
list [catch {return [ [1]]} msg] $msg
} {1 {invalid command name "1"}}
# Long values (stressing storage management)
set a {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH}
test parseOld-11.1 {long values} {
string length $a
} 214
test parseOld-11.2 {long values} {
llength $a
} 43
test parseOld-11.3 {long values} {
set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH"
set b
} $a
test parseOld-11.4 {long values} {
set b "$a"
set b
} $a
test parseOld-11.5 {long values} {
set b [set a]
set b
} $a
test parseOld-11.6 {long values} {
set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH]
string length $b
} 214
test parseOld-11.7 {long values} {
set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH]
llength $b
} 43
test parseOld-11.8 {long values} {
set b
} $a
test parseOld-11.9 {long values} {
set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ]
llength $a
} 62
set i 0
foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] {
set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i]
set test $test$test$test$test
test parseOld-11.10-[incr i] {long values} {
set j
} $test
}
test parseOld-11.11 {test buffer overflow in backslashes in braces} {
expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}}
} 0
test parseOld-12.1 {comments} {
set a old
eval { # set a new}
set a
} {old}
test parseOld-12.2 {comments} {
set a old
eval " # set a new\nset a new"
set a
} {new}
test parseOld-12.3 {comments} {
set a old
eval " # set a new\\\nset a new"
set a
} {old}
test parseOld-12.4 {comments} {
set a old
eval " # set a new\\\\\nset a new"
set a
} {new}
test parseOld-13.1 {comments at the end of a bracketed script} {
set x "[
expr 1+1
# skip this!
]"
} {2}
test parseOld-14.1 {TclWordEnd procedure} {testwordend} {
testwordend " \n abc"
} {c}
test parseOld-14.2 {TclWordEnd procedure} {testwordend} {
testwordend " \\\n"
} {}
test parseOld-14.3 {TclWordEnd procedure} {testwordend} {
testwordend " \\\n "
} { }
test parseOld-14.4 {TclWordEnd procedure} {testwordend} {
testwordend {"abc"}
} {"}
#" Emacs formatting >:^(
test parseOld-14.5 {TclWordEnd procedure} {testwordend} {
testwordend {{xyz}}
} \}
test parseOld-14.6 {TclWordEnd procedure} {testwordend} {
testwordend {{a{}b{}\}} xyz}
} "\} xyz"
test parseOld-14.7 {TclWordEnd procedure} {testwordend} {
testwordend {abc[this is a]def ghi}
} {f ghi}
test parseOld-14.8 {TclWordEnd procedure} {testwordend} {
testwordend "puts\\\n\n "
} "s\\\n\n "
test parseOld-14.9 {TclWordEnd procedure} {testwordend} {
testwordend "puts\\\n "
} "s\\\n "
test parseOld-14.10 {TclWordEnd procedure} {testwordend} {
testwordend "puts\\\n xyz"
} "s\\\n xyz"
test parseOld-14.11 {TclWordEnd procedure} {testwordend} {
testwordend {a$x.$y(a long index) foo}
} ") foo"
test parseOld-14.12 {TclWordEnd procedure} {testwordend} {
testwordend {abc; def}
} {; def}
test parseOld-14.13 {TclWordEnd procedure} {testwordend} {
testwordend {abc def}
} {c def}
test parseOld-14.14 {TclWordEnd procedure} {testwordend} {
testwordend {abc def}
} {c def}
test parseOld-14.15 {TclWordEnd procedure} {testwordend} {
testwordend "abc\ndef"
} "c\ndef"
test parseOld-14.16 {TclWordEnd procedure} {testwordend} {
testwordend "abc"
} {c}
test parseOld-14.17 {TclWordEnd procedure} {testwordend} {
testwordend "a\000bc"
} {c}
test parseOld-14.18 {TclWordEnd procedure} {testwordend} {
testwordend \[a\000\]
} {]}
test parseOld-14.19 {TclWordEnd procedure} {testwordend} {
testwordend \"a\000\"
} {"}
#" Emacs formatting >:^(
test parseOld-14.20 {TclWordEnd procedure} {testwordend} {
testwordend a{\000}b
} {b}
test parseOld-14.21 {TclWordEnd procedure} {testwordend} {
testwordend " \000b"
} {b}
test parseOld-15.1 {TclScriptEnd procedure} {
info complete {puts [
expr 1+1
#this is a comment ]}
} {0}
test parseOld-15.2 {TclScriptEnd procedure} {
info complete "abc\\\n"
} {0}
test parseOld-15.3 {TclScriptEnd procedure} {
info complete "abc\\\\\n"
} {1}
test parseOld-15.4 {TclScriptEnd procedure} {
info complete "xyz \[abc \{abc\]"
} {0}
test parseOld-15.5 {TclScriptEnd procedure} {
info complete "xyz \[abc"
} {0}
# cleanup
set argv $savedArgv
::tcltest::cleanupTests
return
tcl8.4.20/tests/all.tcl 0000644 0036047 0045461 00000001055 12052456744 013335 0 ustar dgp 771div # all.tcl --
#
# This file contains a top-level script to run all of the Tcl
# tests. Execute it by invoking "source all.test" when running tcltest
# in this directory.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
set tcltestVersion [package require tcltest]
namespace import -force tcltest::*
tcltest::testsDirectory [file dir [info script]]
tcltest::runAllTests
return
tcl8.4.20/tests/binary.test 0000644 0036047 0045461 00000150012 12052456744 014244 0 ustar dgp 771div # This file tests the tclBinary.c file and the "binary" Tcl command.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test binary-0.1 {DupByteArrayInternalRep} {
set hdr [binary format cc 0 0316]
set buf hellomatt
set data $hdr
append data $buf
string length $data
} 11
test binary-1.1 {Tcl_BinaryObjCmd: bad args} {
list [catch {binary} msg] $msg
} {1 {wrong # args: should be "binary option ?arg arg ...?"}}
test binary-1.2 {Tcl_BinaryObjCmd: bad args} {
list [catch {binary foo} msg] $msg
} {1 {bad option "foo": must be format or scan}}
test binary-1.3 {Tcl_BinaryObjCmd: format error} {
list [catch {binary f} msg] $msg
} {1 {wrong # args: should be "binary format formatString ?arg arg ...?"}}
test binary-1.4 {Tcl_BinaryObjCmd: format} {
binary format ""
} {}
test binary-2.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format a } msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-2.2 {Tcl_BinaryObjCmd: format} {
binary format a0 foo
} {}
test binary-2.3 {Tcl_BinaryObjCmd: format} {
binary format a f
} {f}
test binary-2.4 {Tcl_BinaryObjCmd: format} {
binary format a foo
} {f}
test binary-2.5 {Tcl_BinaryObjCmd: format} {
binary format a3 foo
} {foo}
test binary-2.6 {Tcl_BinaryObjCmd: format} {
binary format a5 foo
} foo\x00\x00
test binary-2.7 {Tcl_BinaryObjCmd: format} {
binary format a*a3 foobarbaz blat
} foobarbazbla
test binary-2.8 {Tcl_BinaryObjCmd: format} {
binary format a*X3a2 foobar x
} foox\x00r
test binary-3.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format A} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-3.2 {Tcl_BinaryObjCmd: format} {
binary format A0 f
} {}
test binary-3.3 {Tcl_BinaryObjCmd: format} {
binary format A f
} {f}
test binary-3.4 {Tcl_BinaryObjCmd: format} {
binary format A foo
} {f}
test binary-3.5 {Tcl_BinaryObjCmd: format} {
binary format A3 foo
} {foo}
test binary-3.6 {Tcl_BinaryObjCmd: format} {
binary format A5 foo
} {foo }
test binary-3.7 {Tcl_BinaryObjCmd: format} {
binary format A*A3 foobarbaz blat
} foobarbazbla
test binary-3.8 {Tcl_BinaryObjCmd: format} {
binary format A*X3A2 foobar x
} {foox r}
test binary-4.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format B} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-4.2 {Tcl_BinaryObjCmd: format} {
binary format B0 1
} {}
test binary-4.3 {Tcl_BinaryObjCmd: format} {
binary format B 1
} \x80
test binary-4.4 {Tcl_BinaryObjCmd: format} {
binary format B* 010011
} \x4c
test binary-4.5 {Tcl_BinaryObjCmd: format} {
binary format B8 01001101
} \x4d
test binary-4.6 {Tcl_BinaryObjCmd: format} {
binary format A2X2B9 oo 01001101
} \x4d\x00
test binary-4.7 {Tcl_BinaryObjCmd: format} {
binary format B9 010011011010
} \x4d\x80
test binary-4.8 {Tcl_BinaryObjCmd: format} {
binary format B2B3 10 010
} \x80\x40
test binary-4.9 {Tcl_BinaryObjCmd: format} {
list [catch {binary format B1B5 1 foo} msg] $msg
} {1 {expected binary string but got "foo" instead}}
test binary-5.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format b} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-5.2 {Tcl_BinaryObjCmd: format} {
binary format b0 1
} {}
test binary-5.3 {Tcl_BinaryObjCmd: format} {
binary format b 1
} \x01
test binary-5.4 {Tcl_BinaryObjCmd: format} {
binary format b* 010011
} 2
test binary-5.5 {Tcl_BinaryObjCmd: format} {
binary format b8 01001101
} \xb2
test binary-5.6 {Tcl_BinaryObjCmd: format} {
binary format A2X2b9 oo 01001101
} \xb2\x00
test binary-5.7 {Tcl_BinaryObjCmd: format} {
binary format b9 010011011010
} \xb2\x01
test binary-5.8 {Tcl_BinaryObjCmd: format} {
binary format b17 1
} \x01\00\00
test binary-5.9 {Tcl_BinaryObjCmd: format} {
binary format b2b3 10 010
} \x01\x02
test binary-5.10 {Tcl_BinaryObjCmd: format} {
list [catch {binary format b1b5 1 foo} msg] $msg
} {1 {expected binary string but got "foo" instead}}
test binary-6.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format h} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-6.2 {Tcl_BinaryObjCmd: format} {
binary format h0 1
} {}
test binary-6.3 {Tcl_BinaryObjCmd: format} {
binary format h 1
} \x01
test binary-6.4 {Tcl_BinaryObjCmd: format} {
binary format h c
} \x0c
test binary-6.5 {Tcl_BinaryObjCmd: format} {
binary format h* baadf00d
} \xab\xda\x0f\xd0
test binary-6.6 {Tcl_BinaryObjCmd: format} {
binary format h4 c410
} \x4c\x01
test binary-6.7 {Tcl_BinaryObjCmd: format} {
binary format h6 c4102
} \x4c\x01\x02
test binary-6.8 {Tcl_BinaryObjCmd: format} {
binary format h5 c41020304
} \x4c\x01\x02
test binary-6.9 {Tcl_BinaryObjCmd: format} {
binary format a3X3h5 foo 2
} \x02\x00\x00
test binary-6.10 {Tcl_BinaryObjCmd: format} {
binary format h2h3 23 456
} \x32\x54\x06
test binary-6.11 {Tcl_BinaryObjCmd: format} {
list [catch {binary format h2 foo} msg] $msg
} {1 {expected hexadecimal string but got "foo" instead}}
test binary-7.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format H} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-7.2 {Tcl_BinaryObjCmd: format} {
binary format H0 1
} {}
test binary-7.3 {Tcl_BinaryObjCmd: format} {
binary format H 1
} \x10
test binary-7.4 {Tcl_BinaryObjCmd: format} {
binary format H c
} \xc0
test binary-7.5 {Tcl_BinaryObjCmd: format} {
binary format H* baadf00d
} \xba\xad\xf0\x0d
test binary-7.6 {Tcl_BinaryObjCmd: format} {
binary format H4 c410
} \xc4\x10
test binary-7.7 {Tcl_BinaryObjCmd: format} {
binary format H6 c4102
} \xc4\x10\x20
test binary-7.8 {Tcl_BinaryObjCmd: format} {
binary format H5 c41023304
} \xc4\x10\x20
test binary-7.9 {Tcl_BinaryObjCmd: format} {
binary format a3X3H5 foo 2
} \x20\x00\x00
test binary-7.10 {Tcl_BinaryObjCmd: format} {
binary format H2H3 23 456
} \x23\x45\x60
test binary-7.11 {Tcl_BinaryObjCmd: format} {
list [catch {binary format H2 foo} msg] $msg
} {1 {expected hexadecimal string but got "foo" instead}}
test binary-8.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format c} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-8.2 {Tcl_BinaryObjCmd: format} {
list [catch {binary format c blat} msg] $msg
} {1 {expected integer but got "blat"}}
test binary-8.3 {Tcl_BinaryObjCmd: format} {
binary format c0 0x50
} {}
test binary-8.4 {Tcl_BinaryObjCmd: format} {
binary format c 0x50
} P
test binary-8.5 {Tcl_BinaryObjCmd: format} {
binary format c 0x5052
} R
test binary-8.6 {Tcl_BinaryObjCmd: format} {
binary format c2 {0x50 0x52}
} PR
test binary-8.7 {Tcl_BinaryObjCmd: format} {
binary format c2 {0x50 0x52 0x53}
} PR
test binary-8.8 {Tcl_BinaryObjCmd: format} {
binary format c* {0x50 0x52}
} PR
test binary-8.9 {Tcl_BinaryObjCmd: format} {
list [catch {binary format c2 {0x50}} msg] $msg
} {1 {number of elements in list does not match count}}
test binary-8.10 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
list [catch {binary format c $a} msg] $msg
} [list 1 "expected integer but got \"0x50 0x51\""]
test binary-8.11 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format c1 $a
} P
test binary-9.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format s} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-9.2 {Tcl_BinaryObjCmd: format} {
list [catch {binary format s blat} msg] $msg
} {1 {expected integer but got "blat"}}
test binary-9.3 {Tcl_BinaryObjCmd: format} {
binary format s0 0x50
} {}
test binary-9.4 {Tcl_BinaryObjCmd: format} {
binary format s 0x50
} P\x00
test binary-9.5 {Tcl_BinaryObjCmd: format} {
binary format s 0x5052
} RP
test binary-9.6 {Tcl_BinaryObjCmd: format} {
binary format s 0x505251 0x53
} QR
test binary-9.7 {Tcl_BinaryObjCmd: format} {
binary format s2 {0x50 0x52}
} P\x00R\x00
test binary-9.8 {Tcl_BinaryObjCmd: format} {
binary format s* {0x5051 0x52}
} QPR\x00
test binary-9.9 {Tcl_BinaryObjCmd: format} {
binary format s2 {0x50 0x52 0x53} 0x54
} P\x00R\x00
test binary-9.10 {Tcl_BinaryObjCmd: format} {
list [catch {binary format s2 {0x50}} msg] $msg
} {1 {number of elements in list does not match count}}
test binary-9.11 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
list [catch {binary format s $a} msg] $msg
} [list 1 "expected integer but got \"0x50 0x51\""]
test binary-9.12 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format s1 $a
} P\x00
test binary-10.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format S} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-10.2 {Tcl_BinaryObjCmd: format} {
list [catch {binary format S blat} msg] $msg
} {1 {expected integer but got "blat"}}
test binary-10.3 {Tcl_BinaryObjCmd: format} {
binary format S0 0x50
} {}
test binary-10.4 {Tcl_BinaryObjCmd: format} {
binary format S 0x50
} \x00P
test binary-10.5 {Tcl_BinaryObjCmd: format} {
binary format S 0x5052
} PR
test binary-10.6 {Tcl_BinaryObjCmd: format} {
binary format S 0x505251 0x53
} RQ
test binary-10.7 {Tcl_BinaryObjCmd: format} {
binary format S2 {0x50 0x52}
} \x00P\x00R
test binary-10.8 {Tcl_BinaryObjCmd: format} {
binary format S* {0x5051 0x52}
} PQ\x00R
test binary-10.9 {Tcl_BinaryObjCmd: format} {
binary format S2 {0x50 0x52 0x53} 0x54
} \x00P\x00R
test binary-10.10 {Tcl_BinaryObjCmd: format} {
list [catch {binary format S2 {0x50}} msg] $msg
} {1 {number of elements in list does not match count}}
test binary-10.11 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
list [catch {binary format S $a} msg] $msg
} [list 1 "expected integer but got \"0x50 0x51\""]
test binary-10.12 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format S1 $a
} \x00P
test binary-11.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format i} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-11.2 {Tcl_BinaryObjCmd: format} {
list [catch {binary format i blat} msg] $msg
} {1 {expected integer but got "blat"}}
test binary-11.3 {Tcl_BinaryObjCmd: format} {
binary format i0 0x50
} {}
test binary-11.4 {Tcl_BinaryObjCmd: format} {
binary format i 0x50
} P\x00\x00\x00
test binary-11.5 {Tcl_BinaryObjCmd: format} {
binary format i 0x5052
} RP\x00\x00
test binary-11.6 {Tcl_BinaryObjCmd: format} {
binary format i 0x505251 0x53
} QRP\x00
test binary-11.7 {Tcl_BinaryObjCmd: format} {
binary format i1 {0x505251 0x53}
} QRP\x00
test binary-11.8 {Tcl_BinaryObjCmd: format} {
binary format i 0x53525150
} PQRS
test binary-11.9 {Tcl_BinaryObjCmd: format} {
binary format i2 {0x50 0x52}
} P\x00\x00\x00R\x00\x00\x00
test binary-11.10 {Tcl_BinaryObjCmd: format} {
binary format i* {0x50515253 0x52}
} SRQPR\x00\x00\x00
test binary-11.11 {Tcl_BinaryObjCmd: format} {
list [catch {binary format i2 {0x50}} msg] $msg
} {1 {number of elements in list does not match count}}
test binary-11.12 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
list [catch {binary format i $a} msg] $msg
} [list 1 "expected integer but got \"0x50 0x51\""]
test binary-11.13 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format i1 $a
} P\x00\x00\x00
test binary-12.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format I} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-12.2 {Tcl_BinaryObjCmd: format} {
list [catch {binary format I blat} msg] $msg
} {1 {expected integer but got "blat"}}
test binary-12.3 {Tcl_BinaryObjCmd: format} {
binary format I0 0x50
} {}
test binary-12.4 {Tcl_BinaryObjCmd: format} {
binary format I 0x50
} \x00\x00\x00P
test binary-12.5 {Tcl_BinaryObjCmd: format} {
binary format I 0x5052
} \x00\x00PR
test binary-12.6 {Tcl_BinaryObjCmd: format} {
binary format I 0x505251 0x53
} \x00PRQ
test binary-12.7 {Tcl_BinaryObjCmd: format} {
binary format I1 {0x505251 0x53}
} \x00PRQ
test binary-12.8 {Tcl_BinaryObjCmd: format} {
binary format I 0x53525150
} SRQP
test binary-12.9 {Tcl_BinaryObjCmd: format} {
binary format I2 {0x50 0x52}
} \x00\x00\x00P\x00\x00\x00R
test binary-12.10 {Tcl_BinaryObjCmd: format} {
binary format I* {0x50515253 0x52}
} PQRS\x00\x00\x00R
test binary-12.11 {Tcl_BinaryObjCmd: format} {
list [catch {binary format i2 {0x50}} msg] $msg
} {1 {number of elements in list does not match count}}
test binary-12.12 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
list [catch {binary format I $a} msg] $msg
} [list 1 "expected integer but got \"0x50 0x51\""]
test binary-12.13 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format I1 $a
} \x00\x00\x00P
test binary-13.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format f} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-13.2 {Tcl_BinaryObjCmd: format} {
list [catch {binary format f blat} msg] $msg
} {1 {expected floating-point number but got "blat"}}
test binary-13.3 {Tcl_BinaryObjCmd: format} {
binary format f0 1.6
} {}
test binary-13.4 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
binary format f 1.6
} \x3f\xcc\xcc\xcd
test binary-13.5 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
binary format f 1.6
} \xcd\xcc\xcc\x3f
test binary-13.6 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
binary format f* {1.6 3.4}
} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
test binary-13.7 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
binary format f* {1.6 3.4}
} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
test binary-13.8 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
binary format f2 {1.6 3.4}
} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
test binary-13.9 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
binary format f2 {1.6 3.4}
} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
test binary-13.10 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
binary format f2 {1.6 3.4 5.6}
} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
test binary-13.11 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
binary format f2 {1.6 3.4 5.6}
} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
test binary-13.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable macOrUnix} {
binary format f -3.402825e+38
} \xff\x7f\xff\xff
test binary-13.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable pcOnly} {
binary format f -3.402825e+38
} \xff\xff\x7f\xff
test binary-13.14 {Tcl_BinaryObjCmd: float underflow} {nonPortable macOrUnix} {
binary format f -3.402825e-100
} \x80\x00\x00\x00
test binary-13.15 {Tcl_BinaryObjCmd: float underflow} {nonPortable pcOnly} {
binary format f -3.402825e-100
} \x00\x00\x00\x80
test binary-13.16 {Tcl_BinaryObjCmd: format} {
list [catch {binary format f2 {1.6}} msg] $msg
} {1 {number of elements in list does not match count}}
test binary-13.17 {Tcl_BinaryObjCmd: format} {
set a {1.6 3.4}
list [catch {binary format f $a} msg] $msg
} [list 1 "expected floating-point number but got \"1.6 3.4\""]
test binary-13.18 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
set a {1.6 3.4}
binary format f1 $a
} \x3f\xcc\xcc\xcd
test binary-13.19 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
set a {1.6 3.4}
binary format f1 $a
} \xcd\xcc\xcc\x3f
test binary-14.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format d} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-14.2 {Tcl_BinaryObjCmd: format} {
list [catch {binary format d blat} msg] $msg
} {1 {expected floating-point number but got "blat"}}
test binary-14.3 {Tcl_BinaryObjCmd: format} {
binary format d0 1.6
} {}
test binary-14.4 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
binary format d 1.6
} \x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-14.5 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
binary format d 1.6
} \x9a\x99\x99\x99\x99\x99\xf9\x3f
test binary-14.6 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
binary format d* {1.6 3.4}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-14.7 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
binary format d* {1.6 3.4}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-14.8 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
binary format d2 {1.6 3.4}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-14.9 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
binary format d2 {1.6 3.4}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-14.10 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
binary format d2 {1.6 3.4 5.6}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-14.11 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
binary format d2 {1.6 3.4 5.6}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-14.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable unixOnly} {
binary format d NaN
} \x7f\xff\xff\xff\xff\xff\xff\xff
test binary-14.14 {Tcl_BinaryObjCmd: format} {
list [catch {binary format d2 {1.6}} msg] $msg
} {1 {number of elements in list does not match count}}
test binary-14.15 {Tcl_BinaryObjCmd: format} {
set a {1.6 3.4}
list [catch {binary format d $a} msg] $msg
} [list 1 "expected floating-point number but got \"1.6 3.4\""]
test binary-14.16 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
set a {1.6 3.4}
binary format d1 $a
} \x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-14.17 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
set a {1.6 3.4}
binary format d1 $a
} \x9a\x99\x99\x99\x99\x99\xf9\x3f
test binary-14.18 {FormatNumber: Bug 1116542} {
binary scan [binary format d 1.25] d w
set w
} 1.25
test binary-15.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format ax*a "y" "z"} msg] $msg
} {1 {cannot use "*" in format string with "x"}}
test binary-15.2 {Tcl_BinaryObjCmd: format} {
binary format axa "y" "z"
} y\x00z
test binary-15.3 {Tcl_BinaryObjCmd: format} {
binary format ax3a "y" "z"
} y\x00\x00\x00z
test binary-15.4 {Tcl_BinaryObjCmd: format} {
binary format a*X3x3a* "foo" "z"
} \x00\x00\x00z
test binary-15.5 {Tcl_BinaryObjCmd: format - bug #1923966} {
binary format x0s 1
} \x01\x00
test binary-15.6 {Tcl_BinaryObjCmd: format - bug #1923966} {
binary format x0ss 1 1
} \x01\x00\x01\x00
test binary-15.7 {Tcl_BinaryObjCmd: format - bug #1923966} {
binary format x1s 1
} \x00\x01\x00
test binary-15.8 {Tcl_BinaryObjCmd: format - bug #1923966} {
binary format x1ss 1 1
} \x00\x01\x00\x01\x00
test binary-16.1 {Tcl_BinaryObjCmd: format} {
binary format a*X*a "foo" "z"
} zoo
test binary-16.2 {Tcl_BinaryObjCmd: format} {
binary format aX3a "y" "z"
} z
test binary-16.3 {Tcl_BinaryObjCmd: format} {
binary format a*Xa* "foo" "zy"
} fozy
test binary-16.4 {Tcl_BinaryObjCmd: format} {
binary format a*X3a "foobar" "z"
} foozar
test binary-16.5 {Tcl_BinaryObjCmd: format} {
binary format a*X3aX2a "foobar" "z" "b"
} fobzar
test binary-17.1 {Tcl_BinaryObjCmd: format} {
binary format @1
} \x00
test binary-17.2 {Tcl_BinaryObjCmd: format} {
binary format @5a2 "ab"
} \x00\x00\x00\x00\x00\x61\x62
test binary-17.3 {Tcl_BinaryObjCmd: format} {
binary format {a* @0 a2 @* a*} "foobar" "ab" "blat"
} abobarblat
test binary-18.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format u0a3 abc abd} msg] $msg
} {1 {bad field specifier "u"}}
test binary-19.1 {Tcl_BinaryObjCmd: errors} {
list [catch {binary s} msg] $msg
} {1 {wrong # args: should be "binary scan value formatString ?varName varName ...?"}}
test binary-19.2 {Tcl_BinaryObjCmd: errors} {
list [catch {binary scan foo} msg] $msg
} {1 {wrong # args: should be "binary scan value formatString ?varName varName ...?"}}
test binary-19.3 {Tcl_BinaryObjCmd: scan} {
binary scan {} {}
} 0
test binary-20.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc a} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-20.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan abc a arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-20.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 abc
list [binary scan abc a0 arg1] $arg1
} {1 {}}
test binary-20.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abc a* arg1] $arg1
} {1 abc}
test binary-20.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abc a5 arg1] [info exists arg1]
} {0 0}
test binary-20.6 {Tcl_BinaryObjCmd: scan} {
set arg1 foo
list [binary scan abc a2 arg1] $arg1
} {1 ab}
test binary-20.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
list [binary scan abcdef a2a2 arg1 arg2] $arg1 $arg2
} {2 ab cd}
test binary-20.8 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abc a2 arg1(a)] $arg1(a)
} {1 ab}
test binary-20.9 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abc a arg1(a)] $arg1(a)
} {1 a}
test binary-21.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc A} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-21.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan abc A arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-21.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 abc
list [binary scan abc A0 arg1] $arg1
} {1 {}}
test binary-21.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abc A* arg1] $arg1
} {1 abc}
test binary-21.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abc A5 arg1] [info exists arg1]
} {0 0}
test binary-21.6 {Tcl_BinaryObjCmd: scan} {
set arg1 foo
list [binary scan abc A2 arg1] $arg1
} {1 ab}
test binary-21.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
list [binary scan abcdef A2A2 arg1 arg2] $arg1 $arg2
} {2 ab cd}
test binary-21.8 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abc A2 arg1(a)] $arg1(a)
} {1 ab}
test binary-21.9 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abc A2 arg1(a)] $arg1(a)
} {1 ab}
test binary-21.10 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abc A arg1(a)] $arg1(a)
} {1 a}
test binary-21.11 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan "abc def \x00 " A* arg1] $arg1
} {1 {abc def}}
test binary-21.12 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan "abc def \x00ghi " A* arg1] $arg1
} [list 1 "abc def \x00ghi"]
test binary-22.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc b} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-22.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 b* arg1] $arg1
} {1 0100101011001010}
test binary-22.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x82\x53 b arg1] $arg1
} {1 0}
test binary-22.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x82\x53 b1 arg1] $arg1
} {1 0}
test binary-22.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x82\x53 b0 arg1] $arg1
} {1 {}}
test binary-22.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 b5 arg1] $arg1
} {1 01001}
test binary-22.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 b8 arg1] $arg1
} {1 01001010}
test binary-22.8 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 b14 arg1] $arg1
} {1 01001010110010}
test binary-22.9 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
list [binary scan \x52 b14 arg1] $arg1
} {0 foo}
test binary-22.10 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan \x52\x53 b1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-22.11 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x07\x87\x05 b5b* arg1 arg2] $arg1 $arg2
} {2 11100 1110000110100000}
test binary-23.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc B} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-23.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 B* arg1] $arg1
} {1 0101001001010011}
test binary-23.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x82\x53 B arg1] $arg1
} {1 1}
test binary-23.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x82\x53 B1 arg1] $arg1
} {1 1}
test binary-23.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 B0 arg1] $arg1
} {1 {}}
test binary-23.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 B5 arg1] $arg1
} {1 01010}
test binary-23.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 B8 arg1] $arg1
} {1 01010010}
test binary-23.8 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 B14 arg1] $arg1
} {1 01010010010100}
test binary-23.9 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
list [binary scan \x52 B14 arg1] $arg1
} {0 foo}
test binary-23.10 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan \x52\x53 B1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-23.11 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x70\x87\x05 B5B* arg1 arg2] $arg1 $arg2
} {2 01110 1000011100000101}
test binary-24.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc h} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-24.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3 h* arg1] $arg1
} {1 253a}
test binary-24.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \xc2\xa3 h arg1] $arg1
} {1 2}
test binary-24.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x82\x53 h1 arg1] $arg1
} {1 2}
test binary-24.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 h0 arg1] $arg1
} {1 {}}
test binary-24.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \xf2\x53 h2 arg1] $arg1
} {1 2f}
test binary-24.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 h3 arg1] $arg1
} {1 253}
test binary-24.8 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
list [binary scan \x52 h3 arg1] $arg1
} {0 foo}
test binary-24.9 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan \x52\x53 h1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-24.10 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x70\x87\x05 h2h* arg1 arg2] $arg1 $arg2
} {2 07 7850}
test binary-25.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc H} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-25.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3 H* arg1] $arg1
} {1 52a3}
test binary-25.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \xc2\xa3 H arg1] $arg1
} {1 c}
test binary-25.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x82\x53 H1 arg1] $arg1
} {1 8}
test binary-25.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 H0 arg1] $arg1
} {1 {}}
test binary-25.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \xf2\x53 H2 arg1] $arg1
} {1 f2}
test binary-25.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\x53 H3 arg1] $arg1
} {1 525}
test binary-25.8 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
list [binary scan \x52 H3 arg1] $arg1
} {0 foo}
test binary-25.9 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan \x52\x53 H1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-25.10 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x70\x87\x05 H2H* arg1 arg2] $arg1 $arg2
} {2 70 8705}
test binary-26.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc c} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-26.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3 c* arg1] $arg1
} {1 {82 -93}}
test binary-26.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3 c arg1] $arg1
} {1 82}
test binary-26.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3 c1 arg1] $arg1
} {1 82}
test binary-26.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3 c0 arg1] $arg1
} {1 {}}
test binary-26.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3 c2 arg1] $arg1
} {1 {82 -93}}
test binary-26.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \xff c arg1] $arg1
} {1 -1}
test binary-26.8 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
list [binary scan \x52 c3 arg1] $arg1
} {0 foo}
test binary-26.9 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan \x52\x53 c1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-26.10 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x70\x87\x05 c2c* arg1 arg2] $arg1 $arg2
} {2 {112 -121} 5}
test binary-27.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc s} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-27.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54 s* arg1] $arg1
} {1 {-23726 21587}}
test binary-27.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54 s arg1] $arg1
} {1 -23726}
test binary-27.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3 s1 arg1] $arg1
} {1 -23726}
test binary-27.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3 s0 arg1] $arg1
} {1 {}}
test binary-27.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54 s2 arg1] $arg1
} {1 {-23726 21587}}
test binary-27.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
list [binary scan \x52 s1 arg1] $arg1
} {0 foo}
test binary-27.8 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan \x52\x53 s1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-27.9 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x52\xa3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2
} {2 {-23726 21587} 5}
test binary-28.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc S} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-28.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54 S* arg1] $arg1
} {1 {21155 21332}}
test binary-28.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54 S arg1] $arg1
} {1 21155}
test binary-28.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3 S1 arg1] $arg1
} {1 21155}
test binary-28.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3 S0 arg1] $arg1
} {1 {}}
test binary-28.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54 S2 arg1] $arg1
} {1 {21155 21332}}
test binary-28.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
list [binary scan \x52 S1 arg1] $arg1
} {0 foo}
test binary-28.8 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan \x52\x53 S1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-28.9 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x52\xa3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2
} {2 {21155 21332} 5}
test binary-29.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc i} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-29.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1
} {1 {1414767442 67305985}}
test binary-29.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i arg1] $arg1
} {1 1414767442}
test binary-29.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54 i1 arg1] $arg1
} {1 1414767442}
test binary-29.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53 i0 arg1] $arg1
} {1 {}}
test binary-29.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i2 arg1] $arg1
} {1 {1414767442 67305985}}
test binary-29.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
list [binary scan \x52 i1 arg1] $arg1
} {0 foo}
test binary-29.8 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan \x52\x53\x53\x54 i1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-29.9 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2
} {2 {1414767442 67305985} 5}
test binary-30.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc I} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-30.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1
} {1 {1386435412 16909060}}
test binary-30.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I arg1] $arg1
} {1 1386435412}
test binary-30.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54 I1 arg1] $arg1
} {1 1386435412}
test binary-30.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53 I0 arg1] $arg1
} {1 {}}
test binary-30.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I2 arg1] $arg1
} {1 {1386435412 16909060}}
test binary-30.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
list [binary scan \x52 I1 arg1] $arg1
} {0 foo}
test binary-30.8 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan \x52\x53\x53\x54 I1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-30.9 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2
} {2 {1386435412 16909060} 5}
test binary-31.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc f} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-31.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-31.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-31.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1
} {1 1.60000002384}
test binary-31.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1
} {1 1.60000002384}
test binary-31.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1
} {1 1.60000002384}
test binary-31.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1
} {1 1.60000002384}
test binary-31.8 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1
} {1 {}}
test binary-31.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1
} {1 {}}
test binary-31.10 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-31.11 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1
} {1 {1.60000002384 3.40000009537}}
test binary-31.12 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
list [binary scan \x52 f1 arg1] $arg1
} {0 foo}
test binary-31.13 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan \x3f\xcc\xcc\xcd f1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-31.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2
} {2 {1.60000002384 3.40000009537} 5}
test binary-31.15 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2
} {2 {1.60000002384 3.40000009537} 5}
test binary-32.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc d} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-32.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d* arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d arg1] $arg1
} {1 1.6}
test binary-32.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d arg1] $arg1
} {1 1.6}
test binary-32.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1] $arg1
} {1 1.6}
test binary-32.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d1 arg1] $arg1
} {1 1.6}
test binary-32.8 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d0 arg1] $arg1
} {1 {}}
test binary-32.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d0 arg1] $arg1
} {1 {}}
test binary-32.10 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1}
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.11 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1}
list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d2 arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.12 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 foo
list [binary scan \x52 d1 arg1] $arg1
} {0 foo}
test binary-32.13 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
set arg1 1
list [catch {binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1(a)} msg] $msg
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-32.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2
} {2 {1.6 3.4} 5}
test binary-32.15 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
catch {unset arg1 arg2}
set arg1 foo
set arg2 bar
list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 d2c* arg1 arg2] $arg1 $arg2
} {2 {1.6 3.4} 5}
test binary-33.1 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
list [binary scan abcdefg a2xa3 arg1 arg2] $arg1 $arg2
} {2 ab def}
test binary-33.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
set arg2 foo
list [binary scan abcdefg a3x*a3 arg1 arg2] $arg1 $arg2
} {1 abc foo}
test binary-33.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
set arg2 foo
list [binary scan abcdefg a3x20a3 arg1 arg2] $arg1 $arg2
} {1 abc foo}
test binary-33.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
set arg2 foo
list [binary scan abc a3x20a3 arg1 arg2] $arg1 $arg2
} {1 abc foo}
test binary-33.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abcdef x1a1 arg1] $arg1
} {1 b}
test binary-33.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abcdef x5a1 arg1] $arg1
} {1 f}
test binary-33.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abcdef x0a1 arg1] $arg1
} {1 a}
test binary-34.1 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
list [binary scan abcdefg a2Xa3 arg1 arg2] $arg1 $arg2
} {2 ab bcd}
test binary-34.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
set arg2 foo
list [binary scan abcdefg a3X*a3 arg1 arg2] $arg1 $arg2
} {2 abc abc}
test binary-34.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
set arg2 foo
list [binary scan abcdefg a3X20a3 arg1 arg2] $arg1 $arg2
} {2 abc abc}
test binary-34.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abc X20a3 arg1] $arg1
} {1 abc}
test binary-34.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abcdef x*X1a1 arg1] $arg1
} {1 f}
test binary-34.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abcdef x*X5a1 arg1] $arg1
} {1 b}
test binary-34.7 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abcdef x3X0a1 arg1] $arg1
} {1 d}
test binary-35.1 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
list [catch {binary scan abcdefg a2@a3 arg1 arg2} msg] $msg
} {1 {missing count for "@" field specifier}}
test binary-35.2 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
set arg2 foo
list [binary scan abcdefg a3@*a3 arg1 arg2] $arg1 $arg2
} {1 abc foo}
test binary-35.3 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
catch {unset arg2}
set arg2 foo
list [binary scan abcdefg a3@20a3 arg1 arg2] $arg1 $arg2
} {1 abc foo}
test binary-35.4 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abcdef @2a3 arg1] $arg1
} {1 cde}
test binary-35.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abcdef x*@1a1 arg1] $arg1
} {1 b}
test binary-35.6 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
list [binary scan abcdef x*@0a1 arg1] $arg1
} {1 a}
test binary-36.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abcdef u0a3} msg] $msg
} {1 {bad field specifier "u"}}
# GetFormatSpec is pretty thoroughly tested above, but there are a few
# cases we should text explicitly
test binary-37.1 {GetFormatSpec: whitespace} {
binary format "a3 a5 a3" foo barblat baz
} foobarblbaz
test binary-37.2 {GetFormatSpec: whitespace} {
binary format " " foo
} {}
test binary-37.3 {GetFormatSpec: whitespace} {
binary format " a3" foo
} foo
test binary-37.4 {GetFormatSpec: whitespace} {
binary format "" foo
} {}
test binary-37.5 {GetFormatSpec: whitespace} {
binary format "" foo
} {}
test binary-37.6 {GetFormatSpec: whitespace} {
binary format " a3 " foo
} foo
test binary-37.7 {GetFormatSpec: numbers} {
list [catch {binary scan abcdef "x-1" foo} msg] $msg
} {1 {bad field specifier "-"}}
test binary-37.8 {GetFormatSpec: numbers} {
catch {unset arg1}
set arg1 foo
list [binary scan abcdef "a0x3" arg1] $arg1
} {1 {}}
test binary-37.9 {GetFormatSpec: numbers} {
# test format of neg numbers
# bug report/fix provided by Harald Kirsch
set x [binary format f* {1 -1 2 -2 0}]
binary scan $x f* bla
set bla
} {1.0 -1.0 2.0 -2.0 0.0}
test binary-38.1 {FormatNumber: word alignment} {
set x [binary format c1s1 1 1]
} \x01\x01\x00
test binary-38.2 {FormatNumber: word alignment} {
set x [binary format c1S1 1 1]
} \x01\x00\x01
test binary-38.3 {FormatNumber: word alignment} {
set x [binary format c1i1 1 1]
} \x01\x01\x00\x00\x00
test binary-38.4 {FormatNumber: word alignment} {
set x [binary format c1I1 1 1]
} \x01\x00\x00\x00\x01
test binary-38.5 {FormatNumber: word alignment} {nonPortable macOrUnix} {
set x [binary format c1d1 1 1.6]
} \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-38.6 {FormatNumber: word alignment} {nonPortable pcOnly} {
set x [binary format c1d1 1 1.6]
} \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f
test binary-38.7 {FormatNumber: word alignment} {nonPortable macOrUnix} {
set x [binary format c1f1 1 1.6]
} \x01\x3f\xcc\xcc\xcd
test binary-38.8 {FormatNumber: word alignment} {nonPortable pcOnly} {
set x [binary format c1f1 1 1.6]
} \x01\xcd\xcc\xcc\x3f
test binary-39.1 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x52\xa3 c2 arg1] $arg1
} {1 {82 -93}}
test binary-39.2 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 s4 arg1] $arg1
} {1 {513 -32511 386 -32127}}
test binary-39.3 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 S4 arg1] $arg1
} {1 {258 385 -32255 -32382}}
test binary-39.4 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 i5 arg1] $arg1
} {1 {33620225 16843137 16876033 25297153 -2130640639}}
test binary-39.5 {ScanNumber: sign extension} {
catch {unset arg1}
list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1
} {1 {16843010 -2130640639 25297153 16876033 16843137}}
test binary-40.1 {ScanNumber: floating point overflow} {nonPortable unixOnly} {
catch {unset arg1}
list [binary scan \xff\xff\xff\xff f1 arg1] $arg1
} {1 -NaN}
test binary-40.3 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
catch {unset arg1}
set result [binary scan \xff\xff\xff\xff f1 arg1]
if {([string compare $arg1 -1.\#QNAN] == 0)
|| ([string compare $arg1 -NAN] == 0)} {
lappend result success
} else {
lappend result failure
}
} {1 success}
test binary-40.4 {ScanNumber: floating point overflow} {nonPortable unixOnly} {
catch {unset arg1}
list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1] $arg1
} {1 -NaN}
test binary-40.6 {ScanNumber: floating point overflow} {nonPortable pcOnly} {
catch {unset arg1}
set result [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d1 arg1]
if {([string compare $arg1 -1.\#QNAN] == 0)
|| ([string compare $arg1 -NAN] == 0)} {
lappend result success
} else {
lappend result failure
}
} {1 success}
test binary-41.1 {ScanNumber: word alignment} {
catch {unset arg1; unset arg2}
list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.2 {ScanNumber: word alignment} {
catch {unset arg1; unset arg2}
list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.3 {ScanNumber: word alignment} {
catch {unset arg1; unset arg2}
list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.4 {ScanNumber: word alignment} {
catch {unset arg1; unset arg2}
list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.5 {ScanNumber: word alignment} {nonPortable macOrUnix} {
catch {unset arg1; unset arg2}
list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2
} {2 1 1.60000002384}
test binary-41.6 {ScanNumber: word alignment} {nonPortable pcOnly} {
catch {unset arg1; unset arg2}
list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2
} {2 1 1.60000002384}
test binary-41.7 {ScanNumber: word alignment} {nonPortable macOrUnix} {
catch {unset arg1; unset arg2}
list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}
test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} {
catch {unset arg1; unset arg2}
list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}
test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} {} {
catch {binary ?} result
set result
} {bad option "?": must be format or scan}
# Wide int (guaranteed at least 64-bit) handling
test binary-43.1 {Tcl_BinaryObjCmd: format wide int} {} {
binary format w 7810179016327718216
} HelloTcl
test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} {
binary format W 7810179016327718216
} lcTolleH
test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} {
binary scan HelloTcl W x
set x
} 5216694956358656876
test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} {
binary scan lcTolleH w x
set x
} 5216694956358656876
test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
binary scan [binary format w [expr {wide(3) << 31}]] w x
set x
} 6442450944
test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
binary scan [binary format W [expr {wide(3) << 31}]] W x
set x
} 6442450944
test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} {
binary scan [binary format sws 16450 -1 19521] c* x
set x
} {66 64 -1 -1 -1 -1 -1 -1 -1 -1 65 76}
test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} {
binary scan [binary format sWs 16450 0x7fffffff 19521] c* x
set x
} {66 64 0 0 0 0 127 -1 -1 -1 65 76}
test binary-46.1 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
binary format a* \u20ac
} \u00ac
test binary-46.2 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
list [binary scan [binary format a* \u20ac\u20bd] s x] $x
} {1 -16980}
test binary-46.3 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
set x {}
set y {}
set z {}
list [binary scan [binary format a* \u20ac\u20bd] aaa x y z] $x $y $z
} "2 \u00ac \u00bd {}"
test binary-46.4 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
set x [encoding convertto iso8859-15 \u20ac]
set y [binary format a* $x]
list $x $y
} "\u00a4 \u00a4"
test binary-46.5 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
set x [binary scan \u00a4 a* y]
list $x $y [encoding convertfrom iso8859-15 $y]
} "1 \u00a4 \u20ac"
test binary-47.1 {Tcl_BinaryObjCmd: number cache reference count handling} {
# This test is only reliable when memory debugging is turned on,
# but without even memory debugging it should still generate the
# expected answers and might therefore still pick up memory corruption
# caused by [Bug 851747].
list [binary scan aba ccc x x x] $x
} {3 97}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/append.test 0000644 0036047 0045461 00000017670 11737050674 014244 0 ustar dgp 771div # Commands covered: append lappend
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset x}
test append-1.1 {append command} {
catch {unset x}
list [append x 1 2 abc "long string"] $x
} {{12abclong string} {12abclong string}}
test append-1.2 {append command} {
set x ""
list [append x first] [append x second] [append x third] $x
} {first firstsecond firstsecondthird firstsecondthird}
test append-1.3 {append command} {
set x "abcd"
append x
} abcd
test append-2.1 {long appends} {
set x ""
for {set i 0} {$i < 1000} {set i [expr $i+1]} {
append x "foobar "
}
set y "foobar"
set y "$y $y $y $y $y $y $y $y $y $y"
set y "$y $y $y $y $y $y $y $y $y $y"
set y "$y $y $y $y $y $y $y $y $y $y "
expr {$x == $y}
} 1
test append-3.1 {append errors} {
list [catch {append} msg] $msg
} {1 {wrong # args: should be "append varName ?value value ...?"}}
test append-3.2 {append errors} {
set x ""
list [catch {append x(0) 44} msg] $msg
} {1 {can't set "x(0)": variable isn't array}}
test append-3.3 {append errors} {
catch {unset x}
list [catch {append x} msg] $msg
} {1 {can't read "x": no such variable}}
test append-4.1 {lappend command} {
catch {unset x}
list [lappend x 1 2 abc "long string"] $x
} {{1 2 abc {long string}} {1 2 abc {long string}}}
test append-4.2 {lappend command} {
set x ""
list [lappend x first] [lappend x second] [lappend x third] $x
} {first {first second} {first second third} {first second third}}
test append-4.3 {lappend command} {
proc foo {} {
global x
set x old
unset x
lappend x new
}
set result [foo]
rename foo {}
set result
} {new}
test append-4.4 {lappend command} {
set x {}
lappend x \{\ abc
} {\{\ abc}
test append-4.5 {lappend command} {
set x {}
lappend x \{ abc
} {\{ abc}
test append-4.6 {lappend command} {
set x {1 2 3}
lappend x
} {1 2 3}
test append-4.7 {lappend command} {
set x "a\{"
lappend x abc
} "a\\\{ abc"
test append-4.8 {lappend command} {
set x "\\\{"
lappend x abc
} "\\{ abc"
test append-4.9 {lappend command} {
set x " \{"
list [catch {lappend x abc} msg] $msg
} {1 {unmatched open brace in list}}
test append-4.10 {lappend command} {
set x " \{"
list [catch {lappend x abc} msg] $msg
} {1 {unmatched open brace in list}}
test append-4.11 {lappend command} {
set x "\{\{\{"
list [catch {lappend x abc} msg] $msg
} {1 {unmatched open brace in list}}
test append-4.12 {lappend command} {
set x "x \{\{\{"
list [catch {lappend x abc} msg] $msg
} {1 {unmatched open brace in list}}
test append-4.13 {lappend command} {
set x "x\{\{\{"
lappend x abc
} "x\\\{\\\{\\\{ abc"
test append-4.14 {lappend command} {
set x " "
lappend x abc
} "abc"
test append-4.15 {lappend command} {
set x "\\ "
lappend x abc
} "{ } abc"
test append-4.16 {lappend command} {
set x "x "
lappend x abc
} "x abc"
test append-4.17 {lappend command} {
catch {unset x}
lappend x
} {}
test append-4.18 {lappend command} {
catch {unset x}
lappend x {}
} {{}}
test append-4.19 {lappend command} {
catch {unset x}
lappend x(0)
} {}
test append-4.20 {lappend command} {
catch {unset x}
lappend x(0) abc
} {abc}
unset x
test append-4.21 {lappend command} {
set x \"
list [catch {lappend x} msg] $msg
} {1 {unmatched open quote in list}}
test append-4.22 {lappend command} {
set x \"
list [catch {lappend x abc} msg] $msg
} {1 {unmatched open quote in list}}
proc check {var size} {
set l [llength $var]
if {$l != $size} {
return "length mismatch: should have been $size, was $l"
}
for {set i 0} {$i < $size} {set i [expr $i+1]} {
set j [lindex $var $i]
if {$j != "item $i"} {
return "element $i should have been \"item $i\", was \"$j\""
}
}
return ok
}
test append-5.1 {long lappends} {
catch {unset x}
set x ""
for {set i 0} {$i < 300} {set i [expr $i+1]} {
lappend x "item $i"
}
check $x 300
} ok
test append-6.1 {lappend errors} {
list [catch {lappend} msg] $msg
} {1 {wrong # args: should be "lappend varName ?value value ...?"}}
test append-6.2 {lappend errors} {
set x ""
list [catch {lappend x(0) 44} msg] $msg
} {1 {can't set "x(0)": variable isn't array}}
test append-7.1 {lappend-created var and error in trace on that var} {
catch {rename foo ""}
catch {unset x}
trace variable x w foo
proc foo {} {global x; unset x}
catch {lappend x 1}
proc foo {args} {global x; unset x}
info exists x
set x
lappend x 1
list [info exists x] [catch {set x} msg] $msg
} {0 1 {can't read "x": no such variable}}
test append-7.2 {lappend var triggers read trace} {
catch {unset myvar}
catch {unset ::result}
trace variable myvar r foo
proc foo {args} {append ::result $args}
lappend myvar a
list [catch {set ::result} msg] $msg
} {0 {myvar {} r}}
test append-7.3 {lappend var triggers read trace, array var} {
# The behavior of read triggers on lappend changed in 8.0 to
# not trigger them, and was changed back in 8.4.
catch {unset myvar}
catch {unset ::result}
trace variable myvar r foo
proc foo {args} {append ::result $args}
lappend myvar(b) a
list [catch {set ::result} msg] $msg
} {0 {myvar b r}}
test append-7.4 {lappend var triggers read trace, array var exists} {
catch {unset myvar}
catch {unset ::result}
set myvar(0) 1
trace variable myvar r foo
proc foo {args} {append ::result $args}
lappend myvar(b) a
list [catch {set ::result} msg] $msg
} {0 {myvar b r}}
test append-7.5 {append var does not trigger read trace} {
catch {unset myvar}
catch {unset ::result}
trace variable myvar r foo
proc foo {args} {append ::result $args}
append myvar a
info exists ::result
} {0}
# New tests for bug 3057639 to show off the more consistent behaviour
# of lappend in both direct-eval and bytecompiled code paths (see
# appendComp.test for the compiled variants). lappend now behaves like
# append. 9.0/1 lappend - 9.2/3 append
test append-9.0 {bug 3057639, lappend direct eval, read trace on non-existing array variable element} {
catch {unset myvar}
array set myvar {}
proc nonull {var key val} {
upvar 1 $var lvar
if {![info exists lvar($key)]} {
return -code error "no such variable"
}
}
trace add variable myvar read nonull
list [catch {
lappend myvar(key) "new value"
} msg] $msg
} {0 {{new value}}}
test append-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} {
catch {unset ::env(__DUMMY__)}
list [catch {
lappend ::env(__DUMMY__) "new value"
} msg] $msg
} {0 {{new value}}}
test append-9.2 {bug 3057639, append direct eval, read trace on non-existing array variable element} {
catch {unset myvar}
array set myvar {}
proc nonull {var key val} {
upvar 1 $var lvar
if {![info exists lvar($key)]} {
return -code error "no such variable"
}
}
trace add variable myvar read nonull
list [catch {
append myvar(key) "new value"
} msg] $msg
} {0 {new value}}
test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} {
catch {unset ::env(__DUMMY__)}
list [catch {
append ::env(__DUMMY__) "new value"
} msg] $msg
} {0 {new value}}
catch {unset i x result y}
catch {rename foo ""}
catch {rename check ""}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/link.test 0000644 0036047 0045461 00000020346 11737050674 013724 0 ustar dgp 771div # Commands covered: none
#
# This file contains a collection of tests for Tcl_LinkVar and related
# library procedures. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::testConstraint testlink \
[expr {[info commands testlink] != {}}]
foreach i {int real bool string} {
catch {unset $i}
}
test link-1.1 {reading C variables from Tcl} {testlink} {
testlink delete
testlink set 43 1.23 4 - 12341234
testlink create 1 1 1 1 1
list $int $real $bool $string $wide
} {43 1.23 1 NULL 12341234}
test link-1.2 {reading C variables from Tcl} {testlink} {
testlink delete
testlink create 1 1 1 1 1
testlink set -3 2 0 "A long string with spaces" 43214321
list $int $real $bool $string $wide $int $real $bool $string $wide
} {-3 2.0 0 {A long string with spaces} 43214321 -3 2.0 0 {A long string with spaces} 43214321}
test link-2.1 {writing C variables from Tcl} {testlink} {
testlink delete
testlink set 43 1.21 4 - 56785678
testlink create 1 1 1 1 1
set int "00721"
set real -10.5
set bool true
set string abcdef
set wide 135135
concat [testlink get] $int $real $bool $string $wide
} {465 -10.5 1 abcdef 135135 00721 -10.5 true abcdef 135135}
test link-2.2 {writing bad values into variables} {testlink} {
testlink delete
testlink set 43 1.23 4 - 56785678
testlink create 1 1 1 1 1
list [catch {set int 09a} msg] $msg $int
} {1 {can't set "int": variable must have integer value} 43}
test link-2.3 {writing bad values into variables} {testlink} {
testlink delete
testlink set 43 1.23 4 - 56785678
testlink create 1 1 1 1 1
list [catch {set real 1.x3} msg] $msg $real
} {1 {can't set "real": variable must have real value} 1.23}
test link-2.4 {writing bad values into variables} {testlink} {
testlink delete
testlink set 43 1.23 4 - 56785678
testlink create 1 1 1 1 1
list [catch {set bool gorp} msg] $msg $bool
} {1 {can't set "bool": variable must have boolean value} 1}
test link-2.5 {writing bad values into variables} {testlink} {
testlink delete
testlink set 43 1.23 4 - 56785678
testlink create 1 1 1 1 1
list [catch {set wide gorp} msg] $msg $bool
} {1 {can't set "wide": variable must have integer value} 1}
test link-3.1 {read-only variables} {testlink} {
testlink delete
testlink set 43 1.23 4 - 56785678
testlink create 0 1 1 0 0
list [catch {set int 4} msg] $msg $int \
[catch {set real 10.6} msg] $msg $real \
[catch {set bool no} msg] $msg $bool \
[catch {set string "new value"} msg] $msg $string \
[catch {set wide 12341234} msg] $msg $wide
} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL 1 {can't set "wide": linked variable is read-only} 56785678}
test link-3.2 {read-only variables} {testlink} {
testlink delete
testlink set 43 1.23 4 - 56785678
testlink create 1 0 0 1 1
list [catch {set int 4} msg] $msg $int \
[catch {set real 10.6} msg] $msg $real \
[catch {set bool no} msg] $msg $bool \
[catch {set string "new value"} msg] $msg $string\
[catch {set wide 12341234} msg] $msg $wide
} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value} 0 12341234 12341234}
test link-4.1 {unsetting linked variables} {testlink} {
testlink delete
testlink set -6 -2.5 0 stringValue 13579
testlink create 1 1 1 1 1
unset int real bool string wide
list [catch {set int} msg] $msg [catch {set real} msg] $msg \
[catch {set bool} msg] $msg [catch {set string} msg] $msg \
[catch {set wide} msg] $msg
} {0 -6 0 -2.5 0 0 0 stringValue 0 13579}
test link-4.2 {unsetting linked variables} {testlink} {
testlink delete
testlink set -6 -2.1 0 stringValue 97531
testlink create 1 1 1 1 1
unset int real bool string wide
set int 102
set real 16
set bool true
set string newValue
set wide 333555
testlink get
} {102 16.0 1 newValue 333555}
test link-5.1 {unlinking variables} {testlink} {
testlink delete
testlink set -6 -2.25 0 stringValue 13579
testlink delete
set int xx1
set real qrst
set bool bogus
set string 12345
set wide 875421
testlink get
} {-6 -2.25 0 stringValue 13579}
test link-5.2 {unlinking variables} {testlink} {
testlink delete
testlink set -6 -2.25 0 stringValue 97531
testlink create 1 1 1 1 1
testlink delete
testlink set 25 14.7 7 - 999999
list $int $real $bool $string $wide
} {-6 -2.25 0 stringValue 97531}
test link-6.1 {errors in setting up link} {testlink} {
testlink delete
catch {unset int}
set int(44) 1
list [catch {testlink create 1 1 1 1 1} msg] $msg
} {1 {can't set "int": variable is array}}
catch {unset int}
test link-7.1 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar int y
unset y
}
testlink delete
testlink create 1 0 0 0 0
testlink set 14 {} {} {} {}
x
list [catch {set int} msg] $msg
} {0 14}
test link-7.2 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar int y
return [set y]
}
testlink delete
testlink create 1 0 0 0 0
testlink set 0 {} {} {} {}
set int
testlink set 23 {} {} {} {}
x
list [x] $int
} {23 23}
test link-7.3 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar int y
set y 44
}
testlink delete
testlink create 0 0 0 0 0
testlink set 11 {} {} {} {}
list [catch x msg] $msg $int
} {1 {can't set "y": linked variable is read-only} 11}
test link-7.4 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar int y
set y abc
}
testlink delete
testlink create 1 1 1 1 1
testlink set -4 {} {} {} {}
list [catch x msg] $msg $int
} {1 {can't set "y": variable must have integer value} -4}
test link-7.5 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar real y
set y abc
}
testlink delete
testlink create 1 1 1 1 1
testlink set -4 16.75 {} {} {}
list [catch x msg] $msg $real
} {1 {can't set "y": variable must have real value} 16.75}
test link-7.6 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar bool y
set y abc
}
testlink delete
testlink create 1 1 1 1 1
testlink set -4 16.3 1 {} {}
list [catch x msg] $msg $bool
} {1 {can't set "y": variable must have boolean value} 1}
test link-7.7 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar wide y
set y abc
}
testlink delete
testlink create 1 1 1 1 1
testlink set -4 16.3 1 {} 778899
list [catch x msg] $msg $wide
} {1 {can't set "y": variable must have integer value} 778899}
test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
proc x args {
global x int real bool string wide
lappend x $args $int $real $bool $string $wide
}
set x {}
testlink create 1 1 1 1 1
testlink set 14 -2.0 0 xyzzy 995511
trace var int w x
testlink update 32 4.0 3 abcd 113355
trace vdelete int w x
set x
} {{int {} w} 32 -2.0 0 xyzzy 995511}
test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} {
proc x args {
global x int real bool string wide
lappend x $args $int $real $bool $string $wide
}
set x {}
testlink create 1 1 1 1 1
testlink set 14 -2.0 0 xyzzy 995511
testlink delete
trace var int w x
testlink update 32 4.0 6 abcd 113355
trace vdelete int w x
set x
} {}
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
testlink create 0 0 0 0 0
list [catch {testlink update 47 {} {} {} {}} msg] $msg $int
} {0 {} 47}
catch {testlink set 0 0 0 - 0}
catch {testlink delete}
foreach i {int real bool string wide} {
catch {unset $i}
}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/for-old.test 0000644 0036047 0045461 00000003641 11737050674 014330 0 ustar dgp 771div # Commands covered: for, continue, break
#
# This file contains the original set of tests for Tcl's for command.
# Since the for command is now compiled, a new set of tests covering
# the new implementation is in the file "for.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Check "for" and its use of continue and break.
catch {unset a i}
test for-old-1.1 {for tests} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
set a [concat $a $i]
}
set a
} {1 2 3 4 5}
test for-old-1.2 {for tests} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
if $i==4 continue
set a [concat $a $i]
}
set a
} {1 2 3 5}
test for-old-1.3 {for tests} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
if $i==4 break
set a [concat $a $i]
}
set a
} {1 2 3}
test for-old-1.4 {for tests} {catch {for 1 2 3} msg} 1
test for-old-1.5 {for tests} {
catch {for 1 2 3} msg
set msg
} {wrong # args: should be "for start test next command"}
test for-old-1.6 {for tests} {catch {for 1 2 3 4 5} msg} 1
test for-old-1.7 {for tests} {
catch {for 1 2 3 4 5} msg
set msg
} {wrong # args: should be "for start test next command"}
test for-old-1.8 {for tests} {
set a {xyz}
for {set i 1} {$i<6} {set i [expr $i+1]} {}
set a
} xyz
test for-old-1.9 {for tests} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} {
set a [concat $a $i]
}
set a
} {1 2 3}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/interp.test 0000644 0036047 0045461 00000234613 12052456744 014273 0 ustar dgp 771div # This file tests the multiple interpreter facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source}
foreach i [interp slaves] {
interp delete $i
}
proc equiv {x} {return $x}
# Part 0: Check out options for interp command
test interp-1.1 {options for interp command} {
list [catch {interp} msg] $msg
} {1 {wrong # args: should be "interp cmd ?arg ...?"}}
test interp-1.2 {options for interp command} {
list [catch {interp frobox} msg] $msg
} {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.3 {options for interp command} {
interp delete
} ""
test interp-1.4 {options for interp command} {
list [catch {interp delete foo bar} msg] $msg
} {1 {could not find interpreter "foo"}}
test interp-1.5 {options for interp command} {
list [catch {interp exists foo bar} msg] $msg
} {1 {wrong # args: should be "interp exists ?path?"}}
#
# test interp-0.6 was removed
#
test interp-1.6 {options for interp command} {
list [catch {interp slaves foo bar zop} msg] $msg
} {1 {wrong # args: should be "interp slaves ?path?"}}
test interp-1.7 {options for interp command} {
list [catch {interp hello} msg] $msg
} {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.8 {options for interp command} {
list [catch {interp -froboz} msg] $msg
} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.9 {options for interp command} {
list [catch {interp -froboz -safe} msg] $msg
} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.10 {options for interp command} {
list [catch {interp target} msg] $msg
} {1 {wrong # args: should be "interp target path alias"}}
# Part 1: Basic interpreter creation tests:
test interp-2.1 {basic interpreter creation} {
interp create a
} a
test interp-2.2 {basic interpreter creation} {
catch {interp create}
} 0
test interp-2.3 {basic interpreter creation} {
catch {interp create -safe}
} 0
test interp-2.4 {basic interpreter creation} {
list [catch {interp create a} msg] $msg
} {1 {interpreter named "a" already exists, cannot create}}
test interp-2.5 {basic interpreter creation} {
interp create b -safe
} b
test interp-2.6 {basic interpreter creation} {
interp create d -safe
} d
test interp-2.7 {basic interpreter creation} {
list [catch {interp create -froboz} msg] $msg
} {1 {bad option "-froboz": must be -safe or --}}
test interp-2.8 {basic interpreter creation} {
interp create -- -froboz
} -froboz
test interp-2.9 {basic interpreter creation} {
interp create -safe -- -froboz1
} -froboz1
test interp-2.10 {basic interpreter creation} {
interp create {a x1}
interp create {a x2}
interp create {a x3} -safe
} {a x3}
test interp-2.11 {anonymous interps vs existing procs} {
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy thenum
interp delete $x
proc interp$thenum {} {}
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy anothernum
expr $anothernum > $thenum
} 1
test interp-2.12 {anonymous interps vs existing procs} {
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy thenum
interp delete $x
proc interp$thenum {} {}
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy anothernum
expr $anothernum - $thenum
} 1
test interp-2.13 {correct default when no $path arg is given} -body {
interp create --
} -match regexp -result {interp[0-9]+}
foreach i [interp slaves] {
interp delete $i
}
# Part 2: Testing "interp slaves" and "interp exists"
test interp-3.1 {testing interp exists and interp slaves} {
interp slaves
} ""
test interp-3.2 {testing interp exists and interp slaves} {
interp create a
interp exists a
} 1
test interp-3.3 {testing interp exists and interp slaves} {
interp exists nonexistent
} 0
test interp-3.4 {testing interp exists and interp slaves} {
list [catch {interp slaves a b c} msg] $msg
} {1 {wrong # args: should be "interp slaves ?path?"}}
test interp-3.5 {testing interp exists and interp slaves} {
list [catch {interp exists a b c} msg] $msg
} {1 {wrong # args: should be "interp exists ?path?"}}
test interp-3.6 {testing interp exists and interp slaves} {
interp exists
} 1
test interp-3.7 {testing interp exists and interp slaves} {
interp slaves
} a
test interp-3.8 {testing interp exists and interp slaves} {
list [catch {interp slaves a b c} msg] $msg
} {1 {wrong # args: should be "interp slaves ?path?"}}
test interp-3.9 {testing interp exists and interp slaves} {
interp create {a a2} -safe
expr {[lsearch [interp slaves a] a2] >= 0}
} 1
test interp-3.10 {testing interp exists and interp slaves} {
interp exists {a a2}
} 1
# Part 3: Testing "interp delete"
test interp-3.11 {testing interp delete} {
interp delete
} ""
test interp-4.1 {testing interp delete} {
catch {interp create a}
interp delete a
} ""
test interp-4.2 {testing interp delete} {
list [catch {interp delete nonexistent} msg] $msg
} {1 {could not find interpreter "nonexistent"}}
test interp-4.3 {testing interp delete} {
list [catch {interp delete x y z} msg] $msg
} {1 {could not find interpreter "x"}}
test interp-4.4 {testing interp delete} {
interp delete
} ""
test interp-4.5 {testing interp delete} {
interp create a
interp create {a x1}
interp delete {a x1}
expr {[lsearch [interp slaves a] x1] >= 0}
} 0
test interp-4.6 {testing interp delete} {
interp create c1
interp create c2
interp create c3
interp delete c1 c2 c3
} ""
test interp-4.7 {testing interp delete} {
interp create c1
interp create c2
list [catch {interp delete c1 c2 c3} msg] $msg
} {1 {could not find interpreter "c3"}}
test interp-4.8 {testing interp delete} {
list [catch {interp delete {}} msg] $msg
} {1 {cannot delete the current interpreter}}
foreach i [interp slaves] {
interp delete $i
}
# Part 4: Consistency checking - all nondeleted interpreters should be
# there:
test interp-5.1 {testing consistency} {
interp slaves
} ""
test interp-5.2 {testing consistency} {
interp exists a
} 0
test interp-5.3 {testing consistency} {
interp exists nonexistent
} 0
# Recreate interpreter "a"
interp create a
# Part 5: Testing eval in interpreter object command and with interp command
test interp-6.1 {testing eval} {
a eval expr 3 + 5
} 8
test interp-6.2 {testing eval} {
list [catch {a eval foo} msg] $msg
} {1 {invalid command name "foo"}}
test interp-6.3 {testing eval} {
a eval {proc foo {} {expr 3 + 5}}
a eval foo
} 8
test interp-6.4 {testing eval} {
interp eval a foo
} 8
test interp-6.5 {testing eval} {
interp create {a x2}
interp eval {a x2} {proc frob {} {expr 4 * 9}}
interp eval {a x2} frob
} 36
test interp-6.6 {testing eval} {
list [catch {interp eval {a x2} foo} msg] $msg
} {1 {invalid command name "foo"}}
# UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER:
proc in_master {args} {
return [list seen in master: $args]
}
# Part 6: Testing basic alias creation
test interp-7.1 {testing basic alias creation} {
a alias foo in_master
} foo
test interp-7.2 {testing basic alias creation} {
a alias bar in_master a1 a2 a3
} bar
# Test 6.3 has been deleted.
test interp-7.3 {testing basic alias creation} {
a alias foo
} in_master
test interp-7.4 {testing basic alias creation} {
a alias bar
} {in_master a1 a2 a3}
test interp-7.5 {testing basic alias creation} {
lsort [a aliases]
} {bar foo}
test interp-7.6 {testing basic aliases arg checking} {
list [catch {a aliases too many args} msg] $msg
} {1 {wrong # args: should be "a aliases"}}
# Part 7: testing basic alias invocation
test interp-8.1 {testing basic alias invocation} {
catch {interp create a}
a alias foo in_master
a eval foo s1 s2 s3
} {seen in master: {s1 s2 s3}}
test interp-8.2 {testing basic alias invocation} {
catch {interp create a}
a alias bar in_master a1 a2 a3
a eval bar s1 s2 s3
} {seen in master: {a1 a2 a3 s1 s2 s3}}
test interp-8.3 {testing basic alias invocation} {
catch {interp create a}
list [catch {a alias} msg] $msg
} {1 {wrong # args: should be "a alias aliasName ?targetName? ?args..?"}}
# Part 8: Testing aliases for non-existent or hidden targets
test interp-9.1 {testing aliases for non-existent targets} {
catch {interp create a}
a alias zop nonexistent-command-in-master
list [catch {a eval zop} msg] $msg
} {1 {invalid command name "nonexistent-command-in-master"}}
test interp-9.2 {testing aliases for non-existent targets} {
catch {interp create a}
a alias zop nonexistent-command-in-master
proc nonexistent-command-in-master {} {return i_exist!}
a eval zop
} i_exist!
test interp-9.3 {testing aliases for hidden commands} {
catch {interp create a}
a eval {proc p {} {return ENTER_A}}
interp alias {} p a p
set res {}
lappend res [list [catch p msg] $msg]
interp hide a p
lappend res [list [catch p msg] $msg]
rename p {}
interp delete a
set res
} {{0 ENTER_A} {1 {invalid command name "p"}}}
test interp-9.4 {testing aliases and namespace commands} {
proc p {} {return GLOBAL}
namespace eval tst {
proc p {} {return NAMESPACE}
}
interp alias {} a {} p
set res [a]
lappend res [namespace eval tst a]
rename p {}
rename a {}
namespace delete tst
set res
} {GLOBAL GLOBAL}
if {[info command nonexistent-command-in-master] != ""} {
rename nonexistent-command-in-master {}
}
# Part 9: Aliasing between interpreters
test interp-10.1 {testing aliasing between interpreters} {
catch {interp delete a}
catch {interp delete b}
interp create a
interp create b
interp alias a a_alias b b_alias 1 2 3
} a_alias
test interp-10.2 {testing aliasing between interpreters} {
catch {interp delete a}
catch {interp delete b}
interp create a
interp create b
b eval {proc b_alias {args} {return [list got $args]}}
interp alias a a_alias b b_alias 1 2 3
a eval a_alias a b c
} {got {1 2 3 a b c}}
test interp-10.3 {testing aliasing between interpreters} {
catch {interp delete a}
catch {interp delete b}
interp create a
interp create b
interp alias a a_alias b b_alias 1 2 3
list [catch {a eval a_alias a b c} msg] $msg
} {1 {invalid command name "b_alias"}}
test interp-10.4 {testing aliasing between interpreters} {
catch {interp delete a}
interp create a
a alias a_alias puts
a aliases
} a_alias
test interp-10.5 {testing aliasing between interpreters} {
catch {interp delete a}
catch {interp delete b}
interp create a
interp create b
a alias a_alias puts
interp alias a a_del b b_del
interp delete b
a aliases
} a_alias
test interp-10.6 {testing aliasing between interpreters} {
catch {interp delete a}
catch {interp delete b}
interp create a
interp create b
interp alias a a_command b b_command a1 a2 a3
b alias b_command in_master b1 b2 b3
a eval a_command m1 m2 m3
} {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}}
test interp-10.7 {testing aliases between interpreters} {
catch {interp delete a}
interp create a
interp alias "" foo a zoppo
a eval {proc zoppo {x} {list $x $x $x}}
set x [foo 33]
a eval {rename zoppo {}}
interp alias "" foo a {}
equiv $x
} {33 33 33}
# Part 10: Testing "interp target"
test interp-11.1 {testing interp target} {
list [catch {interp target} msg] $msg
} {1 {wrong # args: should be "interp target path alias"}}
test interp-11.2 {testing interp target} {
list [catch {interp target nosuchinterpreter foo} msg] $msg
} {1 {could not find interpreter "nosuchinterpreter"}}
test interp-11.3 {testing interp target} {
catch {interp delete a}
interp create a
a alias boo no_command
interp target a boo
} ""
test interp-11.4 {testing interp target} {
catch {interp delete x1}
interp create x1
x1 eval interp create x2
x1 eval x2 eval interp create x3
catch {interp delete y1}
interp create y1
y1 eval interp create y2
y1 eval y2 eval interp create y3
interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand
interp target {x1 x2 x3} xcommand
} {y1 y2 y3}
test interp-11.5 {testing interp target} {
catch {interp delete x1}
interp create x1
interp create {x1 x2}
interp create {x1 x2 x3}
catch {interp delete y1}
interp create y1
interp create {y1 y2}
interp create {y1 y2 y3}
interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand
list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg
} {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}}
test interp-11.6 {testing interp target} {
foreach a [interp aliases] {
rename $a {}
}
list [catch {interp target {} foo} msg] $msg
} {1 {alias "foo" in path "" not found}}
test interp-11.7 {testing interp target} {
catch {interp delete a}
interp create a
list [catch {interp target a foo} msg] $msg
} {1 {alias "foo" in path "a" not found}}
# Part 11: testing "interp issafe"
test interp-12.1 {testing interp issafe} {
interp issafe
} 0
test interp-12.2 {testing interp issafe} {
catch {interp delete a}
interp create a
interp issafe a
} 0
test interp-12.3 {testing interp issafe} {
catch {interp delete a}
interp create a
interp create {a x3} -safe
interp issafe {a x3}
} 1
test interp-12.4 {testing interp issafe} {
catch {interp delete a}
interp create a
interp create {a x3} -safe
interp create {a x3 foo}
interp issafe {a x3 foo}
} 1
# Part 12: testing interpreter object command "issafe" sub-command
test interp-13.1 {testing foo issafe} {
catch {interp delete a}
interp create a
a issafe
} 0
test interp-13.2 {testing foo issafe} {
catch {interp delete a}
interp create a
interp create {a x3} -safe
a eval x3 issafe
} 1
test interp-13.3 {testing foo issafe} {
catch {interp delete a}
interp create a
interp create {a x3} -safe
interp create {a x3 foo}
a eval x3 eval foo issafe
} 1
test interp-13.4 {testing issafe arg checking} {
catch {interp create a}
list [catch {a issafe too many args} msg] $msg
} {1 {wrong # args: should be "a issafe"}}
# part 14: testing interp aliases
test interp-14.1 {testing interp aliases} {
interp aliases
} ""
test interp-14.2 {testing interp aliases} {
catch {interp delete a}
interp create a
a alias a1 puts
a alias a2 puts
a alias a3 puts
lsort [interp aliases a]
} {a1 a2 a3}
test interp-14.3 {testing interp aliases} {
catch {interp delete a}
interp create a
interp create {a x3}
interp alias {a x3} froboz "" puts
interp aliases {a x3}
} froboz
test interp-14.4 {testing interp alias - alias over master} {
# SF Bug 641195
catch {interp delete a}
interp create a
list [catch {interp alias "" a a eval} msg] $msg [info commands a]
} {1 {cannot define or rename alias "a": interpreter deleted} {}}
# part 15: testing file sharing
test interp-15.1 {testing file sharing} {
catch {interp delete z}
interp create z
z eval close stdout
list [catch {z eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
test interp-15.2 {testing file sharing} -body {
catch {interp delete z}
interp create z
set f [open [makeFile {} file-15.2] w]
interp share "" $f z
z eval puts $f hello
z eval close $f
close $f
} -cleanup {
removeFile file-15.2
} -result ""
test interp-15.3 {testing file sharing} {
catch {interp delete xsafe}
interp create xsafe -safe
list [catch {xsafe eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
test interp-15.4 {testing file sharing} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.4] w]
interp share "" $f xsafe
xsafe eval puts $f hello
xsafe eval close $f
close $f
} -cleanup {
removeFile file-15.4
} -result ""
test interp-15.5 {testing file sharing} {
catch {interp delete xsafe}
interp create xsafe -safe
interp share "" stdout xsafe
list [catch {xsafe eval gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test interp-15.6 {testing file sharing} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.6] w]
interp share "" $f xsafe
set x [list [catch [list xsafe eval gets $f] msg] $msg]
xsafe eval close $f
close $f
string compare [string tolower $x] \
[list 1 [format "channel \"%s\" wasn't opened for reading" $f]]
} -cleanup {
removeFile file-15.6
} -result 0
test interp-15.7 {testing file transferring} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.7] w]
interp transfer "" $f xsafe
xsafe eval puts $f hello
xsafe eval close $f
} -cleanup {
removeFile file-15.7
} -result ""
test interp-15.8 {testing file transferring} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.8] w]
interp transfer "" $f xsafe
xsafe eval close $f
set x [list [catch {close $f} msg] $msg]
string compare [string tolower $x] \
[list 1 [format "can not find channel named \"%s\"" $f]]
} -cleanup {
removeFile file-15.8
} -result 0
#
# Torture tests for interpreter deletion order
#
proc kill {} {interp delete xxx}
test interp-15.9 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
xxx alias kill kill
list [catch {xxx eval kill} msg] $msg
} {0 {}}
test interp-16.1 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
interp create {xxx yyy}
interp alias {xxx yyy} kill "" kill
list [catch {interp eval {xxx yyy} kill} msg] $msg
} {0 {}}
test interp-16.2 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
interp create {xxx yyy}
interp alias {xxx yyy} kill "" kill
list [catch {xxx eval yyy eval kill} msg] $msg
} {0 {}}
test interp-16.3 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
interp create ddd
xxx alias kill kill
interp alias ddd kill xxx kill
set x [ddd eval kill]
interp delete ddd
set x
} ""
test interp-16.4 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
interp create {xxx yyy}
interp alias {xxx yyy} kill "" kill
interp create ddd
interp alias ddd kill {xxx yyy} kill
set x [ddd eval kill]
interp delete ddd
set x
} ""
test interp-16.5 {testing deletion order, bgerror} {
catch {interp delete xxx}
interp create xxx
xxx eval {proc bgerror {args} {exit}}
xxx alias exit kill xxx
proc kill {i} {interp delete $i}
xxx eval after 100 expr a + b
after 200
update
interp exists xxx
} 0
#
# Alias loop prevention testing.
#
test interp-17.1 {alias loop prevention} {
list [catch {interp alias {} a {} a} msg] $msg
} {1 {cannot define or rename alias "a": would create a loop}}
test interp-17.2 {alias loop prevention} {
catch {interp delete x}
interp create x
x alias a loop
list [catch {interp alias {} loop x a} msg] $msg
} {1 {cannot define or rename alias "loop": would create a loop}}
test interp-17.3 {alias loop prevention} {
catch {interp delete x}
interp create x
interp alias x a x b
list [catch {interp alias x b x a} msg] $msg
} {1 {cannot define or rename alias "b": would create a loop}}
test interp-17.4 {alias loop prevention} {
catch {interp delete x}
interp create x
interp alias x b x a
list [catch {x eval rename b a} msg] $msg
} {1 {cannot define or rename alias "b": would create a loop}}
test interp-17.5 {alias loop prevention} {
catch {interp delete x}
interp create x
x alias z l1
interp alias {} l2 x z
list [catch {rename l2 l1} msg] $msg
} {1 {cannot define or rename alias "l2": would create a loop}}
#
# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter.
# If there are bugs in the implementation these tests are likely to expose
# the bugs as a core dump.
#
if {[info commands testinterpdelete] == ""} {
puts "This application hasn't been compiled with the \"testinterpdelete\""
puts "command, so I can't test slave delete calls"
} else {
test interp-18.1 {testing Tcl_DeleteInterp vs slaves} {
list [catch {testinterpdelete} msg] $msg
} {1 {wrong # args: should be "testinterpdelete path"}}
test interp-18.2 {testing Tcl_DeleteInterp vs slaves} {
catch {interp delete a}
interp create a
testinterpdelete a
} ""
test interp-18.3 {testing Tcl_DeleteInterp vs slaves} {
catch {interp delete a}
interp create a
interp create {a b}
testinterpdelete {a b}
} ""
test interp-18.4 {testing Tcl_DeleteInterp vs slaves} {
catch {interp delete a}
interp create a
interp create {a b}
testinterpdelete a
} ""
test interp-18.5 {testing Tcl_DeleteInterp vs slaves} {
catch {interp delete a}
interp create a
interp create {a b}
interp alias {a b} dodel {} dodel
proc dodel {x} {testinterpdelete $x}
list [catch {interp eval {a b} {dodel {a b}}} msg] $msg
} {0 {}}
test interp-18.6 {testing Tcl_DeleteInterp vs slaves} {
catch {interp delete a}
interp create a
interp create {a b}
interp alias {a b} dodel {} dodel
proc dodel {x} {testinterpdelete $x}
list [catch {interp eval {a b} {dodel a}} msg] $msg
} {0 {}}
test interp-18.7 {eval in deleted interp} {
catch {interp delete a}
interp create a
a eval {
proc dodel {} {
delme
dosomething else
}
proc dosomething args {
puts "I should not have been called!!"
}
}
a alias delme dela
proc dela {} {interp delete a}
list [catch {a eval dodel} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
test interp-18.8 {eval in deleted interp} {
catch {interp delete a}
interp create a
a eval {
interp create b
b eval {
proc dodel {} {
dela
}
}
proc foo {} {
b eval dela
dosomething else
}
proc dosomething args {
puts "I should not have been called!!"
}
}
interp alias {a b} dela {} dela
proc dela {} {interp delete a}
list [catch {a eval foo} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
}
test interp-18.9 {eval in deleted interp, bug 495830} {knownBug} {
interp create tst
interp alias tst suicide {} interp delete tst
list [catch {tst eval {suicide; set a 5}} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
test interp-18.10 {eval in deleted interp, bug 495830} {
interp create tst
interp alias tst suicide {} interp delete tst
list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
# Test alias deletion
test interp-19.1 {alias deletion} {
catch {interp delete a}
interp create a
interp alias a foo a bar
set s [interp alias a foo {}]
interp delete a
set s
} {}
test interp-19.2 {alias deletion} {
catch {interp delete a}
interp create a
catch {interp alias a foo {}} msg
interp delete a
set msg
} {alias "foo" not found}
test interp-19.3 {alias deletion} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a {rename foo zop}
interp alias a foo a zop
catch {interp eval a foo} msg
interp delete a
set msg
} {invalid command name "zop"}
test interp-19.4 {alias deletion} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a {rename foo zop}
catch {interp eval a foo} msg
interp delete a
set msg
} {invalid command name "foo"}
test interp-19.5 {alias deletion} {
catch {interp delete a}
interp create a
interp eval a {proc bar {} {return 1}}
interp alias a foo a bar
interp eval a {rename foo zop}
catch {interp eval a zop} msg
interp delete a
set msg
} 1
test interp-19.6 {alias deletion} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a {rename foo zop}
interp alias a foo a zop
set s [interp aliases a]
interp delete a
set s
} foo
test interp-19.7 {alias deletion, renaming} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a rename foo blotz
interp alias a foo {}
set s [interp aliases a]
interp delete a
set s
} {}
test interp-19.8 {alias deletion, renaming} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a rename foo blotz
set l ""
lappend l [interp aliases a]
interp alias a foo {}
lappend l [interp aliases a]
interp delete a
set l
} {foo {}}
test interp-19.9 {alias deletion, renaming} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a rename foo blotz
interp eval a {proc foo {} {expr 34 * 34}}
interp alias a foo {}
set l [interp eval a foo]
interp delete a
set l
} 1156
test interp-20.1 {interp hide, interp expose and interp invokehidden} {
catch {interp delete a}
interp create a
a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
a eval {proc foo {} {}}
a hide foo
catch {a eval foo something} msg
interp delete a
set msg
} {invalid command name "foo"}
test interp-20.2 {interp hide, interp expose and interp invokehidden} {
catch {interp delete a}
interp create a
a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
a hide list
set l ""
lappend l [catch {a eval {list 1 2 3}} msg]
lappend l $msg
a expose list
lappend l [catch {a eval {list 1 2 3}} msg]
lappend l $msg
interp delete a
set l
} {1 {invalid command name "list"} 0 {1 2 3}}
test interp-20.3 {interp hide, interp expose and interp invokehidden} {
catch {interp delete a}
interp create a
a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
a hide list
set l ""
lappend l [catch {a eval {list 1 2 3}} msg]
lappend l $msg
lappend l [catch {a invokehidden list 1 2 3} msg]
lappend l $msg
a expose list
lappend l [catch {a eval {list 1 2 3}} msg]
lappend l $msg
interp delete a
set l
} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}}
test interp-20.4 {interp hide, interp expose and interp invokehidden -- passing {}} {
catch {interp delete a}
interp create a
a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
a hide list
set l ""
lappend l [catch {a eval {list 1 2 3}} msg]
lappend l $msg
lappend l [catch {a invokehidden list {"" 1 2 3}} msg]
lappend l $msg
a expose list
lappend l [catch {a eval {list 1 2 3}} msg]
lappend l $msg
interp delete a
set l
} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}}
test interp-20.5 {interp hide, interp expose and interp invokehidden -- passing {}} {
catch {interp delete a}
interp create a
a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
a hide list
set l ""
lappend l [catch {a eval {list 1 2 3}} msg]
lappend l $msg
lappend l [catch {a invokehidden list {{} 1 2 3}} msg]
lappend l $msg
a expose list
lappend l [catch {a eval {list 1 2 3}} msg]
lappend l $msg
interp delete a
set l
} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}}
test interp-20.6 {interp invokehidden -- eval args} {
catch {interp delete a}
interp create a
a hide list
set l ""
set z 45
lappend l [catch {a invokehidden list $z 1 2 3} msg]
lappend l $msg
a expose list
lappend l [catch {a eval list $z 1 2 3} msg]
lappend l $msg
interp delete a
set l
} {0 {45 1 2 3} 0 {45 1 2 3}}
test interp-20.7 {interp invokehidden vs variable eval} {
catch {interp delete a}
interp create a
a hide list
set z 45
set l ""
lappend l [catch {a invokehidden list {$z a b c}} msg]
lappend l $msg
interp delete a
set l
} {0 {{$z a b c}}}
test interp-20.8 {interp invokehidden vs variable eval} {
catch {interp delete a}
interp create a
a hide list
a eval set z 89
set z 45
set l ""
lappend l [catch {a invokehidden list {$z a b c}} msg]
lappend l $msg
interp delete a
set l
} {0 {{$z a b c}}}
test interp-20.9 {interp invokehidden vs variable eval} {
catch {interp delete a}
interp create a
a hide list
a eval set z 89
set z 45
set l ""
lappend l [catch {a invokehidden list $z {$z a b c}} msg]
lappend l $msg
interp delete a
set l
} {0 {45 {$z a b c}}}
test interp-20.10 {interp hide, interp expose and interp invokehidden} {
catch {interp delete a}
interp create a
a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
a eval {proc foo {} {}}
interp hide a foo
catch {interp eval a foo something} msg
interp delete a
set msg
} {invalid command name "foo"}
test interp-20.11 {interp hide, interp expose and interp invokehidden} {
catch {interp delete a}
interp create a
a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
interp hide a list
set l ""
lappend l [catch {interp eval a {list 1 2 3}} msg]
lappend l $msg
interp expose a list
lappend l [catch {interp eval a {list 1 2 3}} msg]
lappend l $msg
interp delete a
set l
} {1 {invalid command name "list"} 0 {1 2 3}}
test interp-20.12 {interp hide, interp expose and interp invokehidden} {
catch {interp delete a}
interp create a
a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
interp hide a list
set l ""
lappend l [catch {interp eval a {list 1 2 3}} msg]
lappend l $msg
lappend l [catch {interp invokehidden a list 1 2 3} msg]
lappend l $msg
interp expose a list
lappend l [catch {interp eval a {list 1 2 3}} msg]
lappend l $msg
interp delete a
set l
} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}}
test interp-20.13 {interp hide, interp expose, interp invokehidden -- passing {}} {
catch {interp delete a}
interp create a
a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
interp hide a list
set l ""
lappend l [catch {interp eval a {list 1 2 3}} msg]
lappend l $msg
lappend l [catch {interp invokehidden a list {"" 1 2 3}} msg]
lappend l $msg
interp expose a list
lappend l [catch {interp eval a {list 1 2 3}} msg]
lappend l $msg
interp delete a
set l
} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}}
test interp-20.14 {interp hide, interp expose, interp invokehidden -- passing {}} {
catch {interp delete a}
interp create a
a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
interp hide a list
set l ""
lappend l [catch {interp eval a {list 1 2 3}} msg]
lappend l $msg
lappend l [catch {interp invokehidden a list {{} 1 2 3}} msg]
lappend l $msg
interp expose a list
lappend l [catch {a eval {list 1 2 3}} msg]
lappend l $msg
interp delete a
set l
} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}}
test interp-20.15 {interp invokehidden -- eval args} {
catch {interp delete a}
interp create a
interp hide a list
set l ""
set z 45
lappend l [catch {interp invokehidden a list $z 1 2 3} msg]
lappend l $msg
a expose list
lappend l [catch {interp eval a list $z 1 2 3} msg]
lappend l $msg
interp delete a
set l
} {0 {45 1 2 3} 0 {45 1 2 3}}
test interp-20.16 {interp invokehidden vs variable eval} {
catch {interp delete a}
interp create a
interp hide a list
set z 45
set l ""
lappend l [catch {interp invokehidden a list {$z a b c}} msg]
lappend l $msg
interp delete a
set l
} {0 {{$z a b c}}}
test interp-20.17 {interp invokehidden vs variable eval} {
catch {interp delete a}
interp create a
interp hide a list
a eval set z 89
set z 45
set l ""
lappend l [catch {interp invokehidden a list {$z a b c}} msg]
lappend l $msg
interp delete a
set l
} {0 {{$z a b c}}}
test interp-20.18 {interp invokehidden vs variable eval} {
catch {interp delete a}
interp create a
interp hide a list
a eval set z 89
set z 45
set l ""
lappend l [catch {interp invokehidden a list $z {$z a b c}} msg]
lappend l $msg
interp delete a
set l
} {0 {45 {$z a b c}}}
test interp-20.19 {interp invokehidden vs nested commands} {
catch {interp delete a}
interp create a
a hide list
set l [a invokehidden list {[list x y z] f g h} z]
interp delete a
set l
} {{[list x y z] f g h} z}
test interp-20.20 {interp invokehidden vs nested commands} {
catch {interp delete a}
interp create a
a hide list
set l [interp invokehidden a list {[list x y z] f g h} z]
interp delete a
set l
} {{[list x y z] f g h} z}
test interp-20.21 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {a hide list} msg]
lappend l $msg
interp delete a
set l
} {0 {}}
test interp-20.22 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {interp hide a list} msg]
lappend l $msg
interp delete a
set l
} {0 {}}
test interp-20.23 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {a eval {interp hide {} list}} msg]
lappend l $msg
interp delete a
set l
} {1 {permission denied: safe interpreter cannot hide commands}}
test interp-20.24 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
interp create {a b}
set l ""
lappend l [catch {a eval {interp hide b list}} msg]
lappend l $msg
interp delete a
set l
} {1 {permission denied: safe interpreter cannot hide commands}}
test interp-20.25 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
interp create {a b}
set l ""
lappend l [catch {interp hide {a b} list} msg]
lappend l $msg
interp delete a
set l
} {0 {}}
test interp-20.26 {interp expoose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {a hide list} msg]
lappend l $msg
lappend l [catch {a expose list} msg]
lappend l $msg
interp delete a
set l
} {0 {} 0 {}}
test interp-20.27 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {interp hide a list} msg]
lappend l $msg
lappend l [catch {interp expose a list} msg]
lappend l $msg
interp delete a
set l
} {0 {} 0 {}}
test interp-20.28 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {a hide list} msg]
lappend l $msg
lappend l [catch {a eval {interp expose {} list}} msg]
lappend l $msg
interp delete a
set l
} {0 {} 1 {permission denied: safe interpreter cannot expose commands}}
test interp-20.29 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {interp hide a list} msg]
lappend l $msg
lappend l [catch {a eval {interp expose {} list}} msg]
lappend l $msg
interp delete a
set l
} {0 {} 1 {permission denied: safe interpreter cannot expose commands}}
test interp-20.30 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
interp create {a b}
set l ""
lappend l [catch {interp hide {a b} list} msg]
lappend l $msg
lappend l [catch {a eval {interp expose b list}} msg]
lappend l $msg
interp delete a
set l
} {0 {} 1 {permission denied: safe interpreter cannot expose commands}}
test interp-20.31 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
interp create {a b}
set l ""
lappend l [catch {interp hide {a b} list} msg]
lappend l $msg
lappend l [catch {interp expose {a b} list} msg]
lappend l $msg
interp delete a
set l
} {0 {} 0 {}}
test interp-20.32 {interp invokehidden vs safety} {
catch {interp delete a}
interp create a -safe
interp hide a list
set l ""
lappend l [catch {a eval {interp invokehidden {} list a b c}} msg]
lappend l $msg
interp delete a
set l
} {1 {not allowed to invoke hidden commands from safe interpreter}}
test interp-20.33 {interp invokehidden vs safety} {
catch {interp delete a}
interp create a -safe
interp hide a list
set l ""
lappend l [catch {a eval {interp invokehidden {} list a b c}} msg]
lappend l $msg
lappend l [catch {a invokehidden list a b c} msg]
lappend l $msg
interp delete a
set l
} {1 {not allowed to invoke hidden commands from safe interpreter}\
0 {a b c}}
test interp-20.34 {interp invokehidden vs safety} {
catch {interp delete a}
interp create a -safe
interp create {a b}
interp hide {a b} list
set l ""
lappend l [catch {a eval {interp invokehidden b list a b c}} msg]
lappend l $msg
lappend l [catch {interp invokehidden {a b} list a b c} msg]
lappend l $msg
interp delete a
set l
} {1 {not allowed to invoke hidden commands from safe interpreter}\
0 {a b c}}
test interp-20.35 {invokehidden at local level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
set z 90
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.36 {invokehidden at local level} {
catch {interp delete a}
interp create a
a eval {
set z 90
proc p1 {} {
global z
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.37 {invokehidden at local level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.38 {invokehidden at global level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a -global h1
}
set r [catch {interp eval a p1} msg]
interp delete a
list $r $msg
} {1 {can't read "z": no such variable}}
test interp-20.39 {invokehidden at global level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
global z
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a -global h1
}
set r [catch {interp eval a p1} msg]
interp delete a
list $r $msg
} {0 91}
test interp-20.40 {safe, invokehidden at local level} {
catch {interp delete a}
interp create a -safe
a eval {
proc p1 {} {
set z 90
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.41 {safe, invokehidden at local level} {
catch {interp delete a}
interp create a -safe
a eval {
set z 90
proc p1 {} {
global z
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.42 {safe, invokehidden at local level} {
catch {interp delete a}
interp create a -safe
a eval {
proc p1 {} {
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.43 {invokehidden at global level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a -global h1
}
set r [catch {interp eval a p1} msg]
interp delete a
list $r $msg
} {1 {can't read "z": no such variable}}
test interp-20.44 {invokehidden at global level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
global z
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a -global h1
}
set r [catch {interp eval a p1} msg]
interp delete a
list $r $msg
} {0 91}
test interp-20.45 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.46 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x x} msg] $msg]
interp delete a
set l
} {1 {can only hide global namespace commands (use rename then hide)}}
test interp-20.47 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
proc x {} {}
}
set l [list [catch {interp hide a x foo::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.48 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x bar::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-21.1 {interp hidden} {
interp hidden {}
} ""
test interp-21.2 {interp hidden} {
interp hidden
} ""
test interp-21.3 {interp hidden vs interp hide, interp expose} {
set l ""
lappend l [interp hidden]
interp hide {} pwd
lappend l [interp hidden]
interp expose {} pwd
lappend l [interp hidden]
set l
} {{} pwd {}}
test interp-21.4 {interp hidden} {
catch {interp delete a}
interp create a
set l [interp hidden a]
interp delete a
set l
} ""
test interp-21.5 {interp hidden} {
catch {interp delete a}
interp create -safe a
set l [lsort [interp hidden a]]
interp delete a
set l
} $hidden_cmds
test interp-21.6 {interp hidden vs interp hide, interp expose} {
catch {interp delete a}
interp create a
set l ""
lappend l [interp hidden a]
interp hide a pwd
lappend l [interp hidden a]
interp expose a pwd
lappend l [interp hidden a]
interp delete a
set l
} {{} pwd {}}
test interp-21.7 {interp hidden} {
catch {interp delete a}
interp create a
set l [a hidden]
interp delete a
set l
} ""
test interp-21.8 {interp hidden} {
catch {interp delete a}
interp create a -safe
set l [lsort [a hidden]]
interp delete a
set l
} $hidden_cmds
test interp-21.9 {interp hidden vs interp hide, interp expose} {
catch {interp delete a}
interp create a
set l ""
lappend l [a hidden]
a hide pwd
lappend l [a hidden]
a expose pwd
lappend l [a hidden]
interp delete a
set l
} {{} pwd {}}
test interp-22.1 {testing interp marktrusted} {
catch {interp delete a}
interp create a
set l ""
lappend l [a issafe]
lappend l [a marktrusted]
lappend l [a issafe]
interp delete a
set l
} {0 {} 0}
test interp-22.2 {testing interp marktrusted} {
catch {interp delete a}
interp create a
set l ""
lappend l [interp issafe a]
lappend l [interp marktrusted a]
lappend l [interp issafe a]
interp delete a
set l
} {0 {} 0}
test interp-22.3 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [a issafe]
lappend l [a marktrusted]
lappend l [a issafe]
interp delete a
set l
} {1 {} 0}
test interp-22.4 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [interp issafe a]
lappend l [interp marktrusted a]
lappend l [interp issafe a]
interp delete a
set l
} {1 {} 0}
test interp-22.5 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
interp create {a b}
catch {a eval {interp marktrusted b}} msg
interp delete a
set msg
} {permission denied: safe interpreter cannot mark trusted}
test interp-22.6 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
interp create {a b}
catch {a eval {b marktrusted}} msg
interp delete a
set msg
} {permission denied: safe interpreter cannot mark trusted}
test interp-22.7 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [interp issafe a]
interp marktrusted a
interp create {a b}
lappend l [interp issafe a]
lappend l [interp issafe {a b}]
interp delete a
set l
} {1 0 0}
test interp-22.8 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [interp issafe a]
interp create {a b}
lappend l [interp issafe {a b}]
interp marktrusted a
interp create {a c}
lappend l [interp issafe a]
lappend l [interp issafe {a c}]
interp delete a
set l
} {1 1 0 0}
test interp-22.9 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [interp issafe a]
interp create {a b}
lappend l [interp issafe {a b}]
interp marktrusted {a b}
lappend l [interp issafe a]
lappend l [interp issafe {a b}]
interp create {a b c}
lappend l [interp issafe {a b c}]
interp delete a
set l
} {1 1 1 0 0}
test interp-23.1 {testing hiding vs aliases} {
catch {interp delete a}
interp create a
set l ""
lappend l [interp hidden a]
a alias bar bar
lappend l [interp aliases a]
lappend l [interp hidden a]
a hide bar
lappend l [interp aliases a]
lappend l [interp hidden a]
a alias bar {}
lappend l [interp aliases a]
lappend l [interp hidden a]
interp delete a
set l
} {{} bar {} bar bar {} {}}
test interp-23.2 {testing hiding vs aliases} {unixOrPc} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [lsort [interp hidden a]]
a alias bar bar
lappend l [interp aliases a]
lappend l [lsort [interp hidden a]]
a hide bar
lappend l [interp aliases a]
lappend l [lsort [interp hidden a]]
a alias bar {}
lappend l [interp aliases a]
lappend l [lsort [interp hidden a]]
interp delete a
set l
} {{cd encoding exec exit fconfigure file glob load open pwd socket source} bar {cd encoding exec exit fconfigure file glob load open pwd socket source} bar {bar cd encoding exec exit fconfigure file glob load open pwd socket source} {} {cd encoding exec exit fconfigure file glob load open pwd socket source}}
test interp-24.1 {result resetting on error} {
catch {interp delete a}
interp create a
proc foo args {error $args}
interp alias a foo {} foo
set l [interp eval a {
set l {}
lappend l [catch {foo 1 2 3} msg]
lappend l $msg
lappend l [catch {foo 3 4 5} msg]
lappend l $msg
set l
}]
interp delete a
set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.2 {result resetting on error} {
catch {interp delete a}
interp create a -safe
proc foo args {error $args}
interp alias a foo {} foo
set l [interp eval a {
set l {}
lappend l [catch {foo 1 2 3} msg]
lappend l $msg
lappend l [catch {foo 3 4 5} msg]
lappend l $msg
set l
}]
interp delete a
set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.3 {result resetting on error} {
catch {interp delete a}
interp create a
interp create {a b}
interp eval a {
proc foo args {error $args}
}
interp alias {a b} foo a foo
set l [interp eval {a b} {
set l {}
lappend l [catch {foo 1 2 3} msg]
lappend l $msg
lappend l [catch {foo 3 4 5} msg]
lappend l $msg
set l
}]
interp delete a
set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.4 {result resetting on error} {
catch {interp delete a}
interp create a -safe
interp create {a b}
interp eval a {
proc foo args {error $args}
}
interp alias {a b} foo a foo
set l [interp eval {a b} {
set l {}
lappend l [catch {foo 1 2 3} msg]
lappend l $msg
lappend l [catch {foo 3 4 5} msg]
lappend l $msg
set l
}]
interp delete a
set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.5 {result resetting on error} {
catch {interp delete a}
catch {interp delete b}
interp create a
interp create b
interp eval a {
proc foo args {error $args}
}
interp alias b foo a foo
set l [interp eval b {
set l {}
lappend l [catch {foo 1 2 3} msg]
lappend l $msg
lappend l [catch {foo 3 4 5} msg]
lappend l $msg
set l
}]
interp delete a
set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.6 {result resetting on error} {
catch {interp delete a}
catch {interp delete b}
interp create a -safe
interp create b -safe
interp eval a {
proc foo args {error $args}
}
interp alias b foo a foo
set l [interp eval b {
set l {}
lappend l [catch {foo 1 2 3} msg]
lappend l $msg
lappend l [catch {foo 3 4 5} msg]
lappend l $msg
set l
}]
interp delete a
set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.7 {result resetting on error} {
catch {interp delete a}
interp create a
interp eval a {
proc foo args {error $args}
}
set l {}
lappend l [catch {interp eval a foo 1 2 3} msg]
lappend l $msg
lappend l [catch {interp eval a foo 3 4 5} msg]
lappend l $msg
interp delete a
set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.8 {result resetting on error} {
catch {interp delete a}
interp create a -safe
interp eval a {
proc foo args {error $args}
}
set l {}
lappend l [catch {interp eval a foo 1 2 3} msg]
lappend l $msg
lappend l [catch {interp eval a foo 3 4 5} msg]
lappend l $msg
interp delete a
set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.9 {result resetting on error} {
catch {interp delete a}
interp create a
interp create {a b}
interp eval {a b} {
proc foo args {error $args}
}
interp eval a {
proc foo args {
eval interp eval b foo $args
}
}
set l {}
lappend l [catch {interp eval a foo 1 2 3} msg]
lappend l $msg
lappend l [catch {interp eval a foo 3 4 5} msg]
lappend l $msg
interp delete a
set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.10 {result resetting on error} {
catch {interp delete a}
interp create a -safe
interp create {a b}
interp eval {a b} {
proc foo args {error $args}
}
interp eval a {
proc foo args {
eval interp eval b foo $args
}
}
set l {}
lappend l [catch {interp eval a foo 1 2 3} msg]
lappend l $msg
lappend l [catch {interp eval a foo 3 4 5} msg]
lappend l $msg
interp delete a
set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.11 {result resetting on error} {
catch {interp delete a}
interp create a
interp create {a b}
interp eval {a b} {
proc foo args {error $args}
}
interp eval a {
proc foo args {
set l {}
lappend l [catch {eval interp eval b foo $args} msg]
lappend l $msg
lappend l [catch {eval interp eval b foo $args} msg]
lappend l $msg
set l
}
}
set l [interp eval a foo 1 2 3]
interp delete a
set l
} {1 {1 2 3} 1 {1 2 3}}
test interp-24.12 {result resetting on error} {
catch {interp delete a}
interp create a -safe
interp create {a b}
interp eval {a b} {
proc foo args {error $args}
}
interp eval a {
proc foo args {
set l {}
lappend l [catch {eval interp eval b foo $args} msg]
lappend l $msg
lappend l [catch {eval interp eval b foo $args} msg]
lappend l $msg
set l
}
}
set l [interp eval a foo 1 2 3]
interp delete a
set l
} {1 {1 2 3} 1 {1 2 3}}
unset hidden_cmds
test interp-25.1 {testing aliasing of string commands} {
catch {interp delete a}
interp create a
a alias exec foo ;# Relies on exec being a string command!
interp delete a
} ""
#
# Interps result transmission
#
test interp-26.1 {result code transmission : interp eval direct} {
# Test that all the possibles error codes from Tcl get passed up
# from the slave interp's context to the master, even though the
# slave nominally thinks the command is running at the root level.
catch {interp delete a}
interp create a
set res {}
# use a for so if a return -code break 'escapes' we would notice
for {set code -1} {$code<=5} {incr code} {
lappend res [catch {interp eval a return -code $code} msg]
}
interp delete a
set res
} {-1 0 1 2 3 4 5}
test interp-26.2 {result code transmission : interp eval indirect} {
# retcode == 2 == return is special
catch {interp delete a}
interp create a
interp eval a {proc retcode {code} {return -code $code ret$code}}
set res {}
# use a for so if a return -code break 'escapes' we would notice
for {set code -1} {$code<=5} {incr code} {
lappend res [catch {interp eval a retcode $code} msg] $msg
}
interp delete a
set res
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
test interp-26.3 {result code transmission : aliases} {
# Test that all the possibles error codes from Tcl get passed up
# from the slave interp's context to the master, even though the
# slave nominally thinks the command is running at the root level.
catch {interp delete a}
interp create a
set res {}
proc MyTestAlias {code} {
return -code $code ret$code
}
interp alias a Test {} MyTestAlias
for {set code -1} {$code<=5} {incr code} {
lappend res [interp eval a [list catch [list Test $code] msg]]
}
interp delete a
set res
} {-1 0 1 2 3 4 5}
test interp-26.4 {result code transmission: invoke hidden direct--bug 1637} \
{knownBug} {
# The known bug is that code 2 is returned, not the -code argument
catch {interp delete a}
interp create a
set res {}
interp hide a return
for {set code -1} {$code<=5} {incr code} {
lappend res [catch {interp invokehidden a return -code $code ret$code}]
}
interp delete a
set res
} {-1 0 1 2 3 4 5}
test interp-26.5 {result code transmission: invoke hidden indirect--bug 1637} \
{knownBug} {
# The known bug is that the break and continue should raise errors
# that they are used outside a loop.
catch {interp delete a}
interp create a
set res {}
interp eval a {proc retcode {code} {return -code $code ret$code}}
interp hide a retcode
for {set code -1} {$code<=5} {incr code} {
lappend res [catch {interp invokehidden a retcode $code} msg] $msg
}
interp delete a
set res
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
test interp-26.6 {result code transmission: all combined--bug 1637} \
{knownBug} {
# Test that all the possibles error codes from Tcl get passed
# In both directions. This doesn't work.
set interp [interp create];
proc MyTestAlias {interp args} {
global aliasTrace;
lappend aliasTrace $args;
eval interp invokehidden [list $interp] $args
}
foreach c {return} {
interp hide $interp $c;
interp alias $interp $c {} MyTestAlias $interp $c;
}
interp eval $interp {proc ret {code} {return -code $code ret$code}}
set res {}
set aliasTrace {}
for {set code -1} {$code<=5} {incr code} {
lappend res [catch {interp eval $interp ret $code} msg] $msg
}
interp delete $interp;
set res
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
# Some tests might need to be added to check for difference between
# toplevel and non toplevel evals.
# End of return code transmission section
test interp-26.7 {errorInfo transmission: regular interps} {
set interp [interp create];
proc MyError {secret} {
return -code error "msg"
}
proc MyTestAlias {interp args} {
MyError "some secret"
}
interp alias $interp test {} MyTestAlias $interp;
set res [interp eval $interp {catch test;set errorInfo}]
interp delete $interp;
set res
} {msg
while executing
"MyError "some secret""
(procedure "MyTestAlias" line 2)
invoked from within
"test"}
test interp-26.8 {errorInfo transmission: safe interps--bug 1637} {knownBug} {
# this test fails because the errorInfo is fully transmitted
# whether the interp is safe or not. The errorInfo should never
# report data from the master interpreter because it could
# contain sensitive information.
set interp [interp create -safe];
proc MyError {secret} {
return -code error "msg"
}
proc MyTestAlias {interp args} {
MyError "some secret"
}
interp alias $interp test {} MyTestAlias $interp;
set res [interp eval $interp {catch test;set errorInfo}]
interp delete $interp;
set res
} {msg
while executing
"test"}
# Interps & Namespaces
test interp-27.1 {interp aliases & namespaces} {
set i [interp create];
set aliasTrace {};
proc tstAlias {args} {
global aliasTrace;
lappend aliasTrace [list [namespace current] $args];
}
$i alias foo::bar tstAlias foo::bar;
$i eval foo::bar test
interp delete $i
set aliasTrace;
} {{:: {foo::bar test}}}
test interp-27.2 {interp aliases & namespaces} {
set i [interp create];
set aliasTrace {};
proc tstAlias {args} {
global aliasTrace;
lappend aliasTrace [list [namespace current] $args];
}
$i alias foo::bar tstAlias foo::bar;
$i eval namespace eval foo {bar test}
interp delete $i
set aliasTrace;
} {{:: {foo::bar test}}}
test interp-27.3 {interp aliases & namespaces} {
set i [interp create];
set aliasTrace {};
proc tstAlias {args} {
global aliasTrace;
lappend aliasTrace [list [namespace current] $args];
}
interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}}
interp alias $i foo::bar {} tstAlias foo::bar;
interp eval $i {namespace eval foo {bar test}}
interp delete $i
set aliasTrace;
} {{:: {foo::bar test}}}
test interp-27.4 {interp aliases & namespaces} {
set i [interp create];
namespace eval foo2 {
variable aliasTrace {};
proc bar {args} {
variable aliasTrace;
lappend aliasTrace [list [namespace current] $args];
}
}
$i alias foo::bar foo2::bar foo::bar;
$i eval namespace eval foo {bar test}
set r $foo2::aliasTrace;
namespace delete foo2;
set r
} {{::foo2 {foo::bar test}}}
# the following tests are commented out while we don't support
# hiding in namespaces
# test interp-27.5 {interp hidden & namespaces} {
# set i [interp create];
# interp eval $i {
# namespace eval foo {
# proc bar {args} {
# return "bar called ([namespace current]) ($args)"
# }
# }
# }
# set res [list [interp eval $i {namespace eval foo {bar test1}}]]
# interp hide $i foo::bar;
# lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg]
# interp delete $i;
# set res;
#} {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}}
# test interp-27.6 {interp hidden & aliases & namespaces} {
# set i [interp create];
# set v root-master;
# namespace eval foo {
# variable v foo-master;
# proc bar {interp args} {
# variable v;
# list "master bar called ($v) ([namespace current]) ($args)"\
# [interp invokehidden $interp foo::bar $args];
# }
# }
# interp eval $i {
# namespace eval foo {
# namespace export *
# variable v foo-slave;
# proc bar {args} {
# variable v;
# return "slave bar called ($v) ([namespace current]) ($args)"
# }
# }
# }
# set res [list [interp eval $i {namespace eval foo {bar test1}}]]
# $i hide foo::bar;
# $i alias foo::bar foo::bar $i;
# set res [concat $res [interp eval $i {
# set v root-slave;
# namespace eval test {
# variable v foo-test;
# namespace import ::foo::*;
# bar test2
# }
# }]]
# namespace delete foo;
# interp delete $i;
# set res
# } {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}}
# test interp-27.7 {interp hidden & aliases & imports & namespaces} {
# set i [interp create];
# set v root-master;
# namespace eval mfoo {
# variable v foo-master;
# proc bar {interp args} {
# variable v;
# list "master bar called ($v) ([namespace current]) ($args)"\
# [interp invokehidden $interp test::bar $args];
# }
# }
# interp eval $i {
# namespace eval foo {
# namespace export *
# variable v foo-slave;
# proc bar {args} {
# variable v;
# return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)"
# }
# }
# set v root-slave;
# namespace eval test {
# variable v foo-test;
# namespace import ::foo::*;
# }
# }
# set res [list [interp eval $i {namespace eval test {bar test1}}]]
# $i hide test::bar;
# $i alias test::bar mfoo::bar $i;
# set res [concat $res [interp eval $i {test::bar test2}]];
# namespace delete mfoo;
# interp delete $i;
# set res
# } {{slave bar called (foo-slave) (bar test1) (::tcltest) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}}
#test interp-27.8 {hiding, namespaces and integrity} {
# namespace eval foo {
# variable v 3;
# proc bar {} {variable v; set v}
# # next command would currently generate an unknown command "bar" error.
# interp hide {} bar;
# }
# namespace delete foo;
# list [catch {interp invokehidden {} foo} msg] $msg;
#} {1 {invalid hidden command name "foo"}}
test interp-28.1 {getting fooled by slave's namespace ?} {
set i [interp create -safe];
proc master {interp args} {interp hide $interp list}
$i alias master master $i;
set r [interp eval $i {
namespace eval foo {
proc list {args} {
return "dummy foo::list";
}
master;
}
info commands list
}]
interp delete $i;
set r
} {}
# Part 29: recursion limit
# 29.1.* Argument checking
# 29.2.* Reading and setting the recursion limit
# 29.3.* Does the recursion limit work?
# 29.4.* Recursion limit inheritance by sub-interpreters
# 29.5.* Confirming the recursionlimit command does not affect the parent
# 29.6.* Safe interpreter restriction
test interp-29.1.1 {interp recursionlimit argument checking} {
list [catch {interp recursionlimit} msg] $msg
} {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}}
test interp-29.1.2 {interp recursionlimit argument checking} {
list [catch {interp recursionlimit foo bar} msg] $msg
} {1 {could not find interpreter "foo"}}
test interp-29.1.3 {interp recursionlimit argument checking} {
list [catch {interp recursionlimit foo bar baz} msg] $msg
} {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}}
test interp-29.1.4 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo bar} msg]
interp delete moo
list $result $msg
} {1 {expected integer but got "bar"}}
test interp-29.1.5 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo 0} msg]
interp delete moo
list $result $msg
} {1 {recursion limit must be > 0}}
test interp-29.1.6 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo -1} msg]
interp delete moo
list $result $msg
} {1 {recursion limit must be > 0}}
test interp-29.1.7 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.1.8 {slave recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit foo bar} msg]
interp delete moo
list $result $msg
} {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}}
test interp-29.1.9 {slave recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit foo} msg]
interp delete moo
list $result $msg
} {1 {expected integer but got "foo"}}
test interp-29.1.10 {slave recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit 0} msg]
interp delete moo
list $result $msg
} {1 {recursion limit must be > 0}}
test interp-29.1.11 {slave recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit -1} msg]
interp delete moo
list $result $msg
} {1 {recursion limit must be > 0}}
test interp-29.1.12 {slave recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.2.1 {query recursion limit} {
interp recursionlimit {}
} 1000
test interp-29.2.2 {query recursion limit} {
set i [interp create]
set n [interp recursionlimit $i]
interp delete $i
set n
} 1000
test interp-29.2.3 {query recursion limit} {
set i [interp create]
set n [$i recursionlimit]
interp delete $i
set n
} 1000
test interp-29.2.4 {query recursion limit} {
set i [interp create]
set r [$i eval {
set n1 [interp recursionlimit {} 42]
set n2 [interp recursionlimit {}]
list $n1 $n2
}]
interp delete $i
set r
} {42 42}
test interp-29.2.5 {query recursion limit} {
set i [interp create]
set n1 [interp recursionlimit $i 42]
set n2 [interp recursionlimit $i]
interp delete $i
list $n1 $n2
} {42 42}
test interp-29.2.6 {query recursion limit} {
set i [interp create]
set n1 [interp recursionlimit $i 42]
set n2 [$i recursionlimit]
interp delete $i
list $n1 $n2
} {42 42}
test interp-29.2.7 {query recursion limit} {
set i [interp create]
set n1 [$i recursionlimit 42]
set n2 [interp recursionlimit $i]
interp delete $i
list $n1 $n2
} {42 42}
test interp-29.2.8 {query recursion limit} {
set i [interp create]
set n1 [$i recursionlimit 42]
set n2 [$i recursionlimit]
interp delete $i
list $n1 $n2
} {42 42}
test interp-29.3.1 {recursion limit} {
set i [interp create]
set r [interp eval $i {
interp recursionlimit {} 50
proc p {} {incr ::i; p}
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 48}
test interp-29.3.2 {recursion limit} {
set i [interp create]
interp recursionlimit $i 50
set r [interp eval $i {
proc p {} {incr ::i; p}
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 48}
test interp-29.3.3 {recursion limit} {
set i [interp create]
$i recursionlimit 50
set r [interp eval $i {
proc p {} {incr ::i; p}
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 48}
test interp-29.3.4 {recursion limit error reporting} {
interp create slave
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 5
set x ok
}
}
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {1 {falling back due to new recursion limit}}
test interp-29.3.5 {recursion limit error reporting} {
interp create slave
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 4
set x ok
}
}
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {1 {falling back due to new recursion limit}}
test interp-29.3.6 {recursion limit error reporting} {
interp create slave
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 6
set x ok
}
}
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {0 ok}
test interp-29.3.7 {recursion limit error reporting} {
interp create slave
after 0 {interp recursionlimit slave 5}
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.8 {recursion limit error reporting} {
interp create slave
after 0 {interp recursionlimit slave 4}
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.9 {recursion limit error reporting} {
interp create slave
after 0 {interp recursionlimit slave 6}
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {0 ok}
test interp-29.3.10 {recursion limit error reporting} {
interp create slave
after 0 {slave recursionlimit 4}
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.11 {recursion limit error reporting} {
interp create slave
after 0 {slave recursionlimit 5}
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.12 {recursion limit error reporting} {
interp create slave
after 0 {slave recursionlimit 6}
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {0 ok}
test interp-29.4.1 {recursion limit inheritance} {
set i [interp create]
set ii [interp eval $i {
interp recursionlimit {} 50
interp create
}]
set r [interp eval [list $i $ii] {
proc p {} {incr ::i; p}
set i 0
catch p
set i
}]
interp delete $i
set r
} 49
test interp-29.4.2 {recursion limit inheritance} {
set i [interp create]
$i recursionlimit 50
set ii [interp eval $i {interp create}]
set r [interp eval [list $i $ii] {
proc p {} {incr ::i; p}
set i 0
catch p
set i
}]
interp delete $i
set r
} 49
test interp-29.5.1 {does slave recursion limit affect master?} {
set before [interp recursionlimit {}]
set i [interp create]
interp recursionlimit $i 20000
set after [interp recursionlimit {}]
set slavelimit [interp recursionlimit $i]
interp delete $i
list [expr {$before == $after}] $slavelimit
} {1 20000}
test interp-29.5.2 {does slave recursion limit affect master?} {
set before [interp recursionlimit {}]
set i [interp create]
interp recursionlimit $i 20000
set after [interp recursionlimit {}]
set slavelimit [$i recursionlimit]
interp delete $i
list [expr {$before == $after}] $slavelimit
} {1 20000}
test interp-29.5.3 {does slave recursion limit affect master?} {
set before [interp recursionlimit {}]
set i [interp create]
$i recursionlimit 20000
set after [interp recursionlimit {}]
set slavelimit [interp recursionlimit $i]
interp delete $i
list [expr {$before == $after}] $slavelimit
} {1 20000}
test interp-29.5.4 {does slave recursion limit affect master?} {
set before [interp recursionlimit {}]
set i [interp create]
$i recursionlimit 20000
set after [interp recursionlimit {}]
set slavelimit [$i recursionlimit]
interp delete $i
list [expr {$before == $after}] $slavelimit
} {1 20000}
test interp-29.6.1 {safe interpreter recursion limit} {
interp create slave -safe
set n [interp recursionlimit slave]
interp delete slave
set n
} 1000
test interp-29.6.2 {safe interpreter recursion limit} {
interp create slave -safe
set n [slave recursionlimit]
interp delete slave
set n
} 1000
test interp-29.6.3 {safe interpreter recursion limit} {
interp create slave -safe
set n1 [interp recursionlimit slave 42]
set n2 [interp recursionlimit slave]
interp delete slave
list $n1 $n2
} {42 42}
test interp-29.6.4 {safe interpreter recursion limit} {
interp create slave -safe
set n1 [slave recursionlimit 42]
set n2 [interp recursionlimit slave]
interp delete slave
list $n1 $n2
} {42 42}
test interp-29.6.5 {safe interpreter recursion limit} {
interp create slave -safe
set n1 [interp recursionlimit slave 42]
set n2 [slave recursionlimit]
interp delete slave
list $n1 $n2
} {42 42}
test interp-29.6.6 {safe interpreter recursion limit} {
interp create slave -safe
set n1 [slave recursionlimit 42]
set n2 [slave recursionlimit]
interp delete slave
list $n1 $n2
} {42 42}
test interp-29.6.7 {safe interpreter recursion limit} {
interp create slave -safe
set n1 [slave recursionlimit 42]
set n2 [slave recursionlimit]
interp delete slave
list $n1 $n2
} {42 42}
test interp-29.6.8 {safe interpreter recursion limit} {
interp create slave -safe
set n [catch {slave eval {interp recursionlimit {} 42}} msg]
interp delete slave
list $n $msg
} {1 {permission denied: safe interpreters cannot change recursion limit}}
test interp-29.6.9 {safe interpreter recursion limit} {
interp create slave -safe
set result [
slave eval {
interp create slave2 -safe
set n [catch {
interp recursionlimit slave2 42
} msg]
list $n $msg
}
]
interp delete slave
set result
} {1 {permission denied: safe interpreters cannot change recursion limit}}
test interp-29.6.10 {safe interpreter recursion limit} {
interp create slave -safe
set result [
slave eval {
interp create slave2 -safe
set n [catch {
slave2 recursionlimit 42
} msg]
list $n $msg
}
]
interp delete slave
set result
} {1 {permission denied: safe interpreters cannot change recursion limit}}
# # Deep recursion (into interps when the regular one fails):
# # still crashes...
# proc p {} {
# if {[catch p ret]} {
# catch {
# set i [interp create]
# interp eval $i [list proc p {} [info body p]]
# interp eval $i p
# }
# interp delete $i
# return ok
# }
# return $ret
# }
# p
# more tests needed...
# Interp & stack
#test interp-29.1 {interp and stack (info level)} {
#} {}
# End of stack-recursion tests
# This test dumps core in Tcl 8.0.3!
test interp-30.1 {deletion of aliases inside namespaces} {
set i [interp create]
$i alias ns::cmd list
$i alias ns::cmd {}
} {}
test interp-31.1 {alias invocation scope} {
proc mySet {varName value} {
upvar 1 $varName localVar
set localVar $value
}
interp alias {} myNewSet {} mySet
proc testMyNewSet {value} {
myNewSet a $value
return $a
}
catch {unset a}
set result [testMyNewSet "ok"]
rename testMyNewSet {}
rename mySet {}
rename myNewSet {}
set result
} ok
test interp-32.1 { parent's working directory should
be inherited by a child interp } {
cd [temporaryDirectory]
set parent [pwd]
set i [interp create]
set child [$i eval pwd]
interp delete $i
file mkdir cwd_test
cd cwd_test
lappend parent [pwd]
set i [interp create]
lappend child [$i eval pwd]
cd ..
file delete cwd_test
interp delete $i
cd [workingDirectory]
expr {[string equal $parent $child] ? 1 :
"\{$parent\} != \{$child\}"}
} 1
test interp-33.1 {refCounting for target words of alias [Bug 730244]} {
# This test will panic if Bug 730244 is not fixed.
set i [interp create]
proc testHelper args {rename testHelper {}; return $args}
# Note: interp names are simple words by default
trace add execution testHelper enter "interp alias $i alias {} ;#"
interp alias $i alias {} testHelper this
$i eval alias
} this
# cleanup
foreach i [interp slaves] {
interp delete $i
}
::tcltest::cleanupTests
return
tcl8.4.20/tests/license.terms 0000644 0036047 0045461 00000004321 11737050674 014557 0 ustar dgp 771div This software is copyrighted by the Regents of the University of
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
Corporation and other parties. The following terms apply to all files
associated with the software unless explicitly disclaimed in
individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that this
notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
and need not follow the licensing terms described here, provided that
the new terms are clearly indicated on the first page of each file where
they apply.
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.
tcl8.4.20/tests/proc.test 0000644 0036047 0045461 00000027171 11737050674 013735 0 ustar dgp 771div # This file contains tests for the tclProc.c source file. Tests appear in
# the same order as the C code that they test. The set of tests is
# currently incomplete since it includes only new tests, in particular
# tests for code changed for the addition of Tcl namespaces. Other
# procedure-related tests appear in other test files such as proc-old.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}
test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {}
}
proc test_ns_1::baz::p {} {
return "p in [namespace current]"
}
list [test_ns_1::baz::p] \
[namespace eval test_ns_1 {baz::p}] \
[info commands test_ns_1::baz::*]
} {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p}
test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {proc test_ns_1::baz::p {} {}} msg] $msg
} {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}}
test proc-1.3 {Tcl_ProcObjCmd, empty proc name} {
catch {eval namespace delete [namespace children :: test_ns_*]}
proc :: {} {
return "empty called"
}
list [::] \
[info body {}]
} {{empty called} {
return "empty called"
}}
test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {
return "p in [namespace current]"
}
}
}
list [test_ns_1::baz::p] \
[info commands test_ns_1::baz::*]
} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p}
test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::baz {}
namespace eval test_ns_1 {
proc baz::p {} {
return "p in [namespace current]"
}
}
list [test_ns_1::baz::p] \
[info commands test_ns_1::baz::*] \
[namespace eval test_ns_1::baz {namespace which p}]
} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p}
test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc q: {} {return "q:"}
proc value:at: {} {return "value:at:"}
}
list [namespace eval test_ns_1 {q:}] \
[namespace eval test_ns_1 {value:at:}] \
[test_ns_1::q:] \
[test_ns_1::value:at:] \
[lsort [info commands test_ns_1::*]] \
[namespace eval test_ns_1 {namespace which q:}] \
[namespace eval test_ns_1 {namespace which value:at:}]
} {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:}
test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} {
catch {rename p ""}
list [catch {proc p {a(1) a(2)} {
set z [expr $a(1)+$a(2)]
puts "$z=z, $a(1)=$a(1)"
}} msg] $msg
} {1 {procedure "p" has formal parameter "a(1)" that is an array element}}
test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} {
catch {rename p ""}
list [catch {proc p {b:a b::a} {
}} msg] $msg
} {1 {procedure "p" has formal parameter "b::a" that is not a simple name}}
test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {return "p in [namespace current]"}
info body p
} {return "p in [namespace current]"}
test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {return "p in [namespace current]"}
}
}
namespace eval test_ns_1::baz {info body p}
} {return "p in [namespace current]"}
test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::baz {}
namespace eval test_ns_1 {
proc baz::p {} {return "p in [namespace current]"}
}
namespace eval test_ns_1 {info body baz::p}
} {return "p in [namespace current]"}
test proc-2.4 {TclFindProc, global proc and executing in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {return "global p"}
namespace eval test_ns_1::baz {info body p}
} {return "global p"}
test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
proc p {} {return "p in [namespace current]"}
p
} {p in ::}
test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::baz {
proc p {} {return "p in [namespace current]"}
p
}
} {p in ::test_ns_1::baz}
test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {return "p in [namespace current]"}
namespace eval test_ns_1::baz {
p
}
} {p in ::}
test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
namespace eval test_ns_1::baz {
proc p {} {return "p in [namespace current]"}
rename ::test_ns_1::baz::p ::p
list [p] [namespace which p]
}
} {{p in ::} ::p}
test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {
proc p {x} {info commands 3m}
list [catch {p} msg] $msg
} {1 {wrong # args: should be "p x"}}
test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} {
proc {a b c} {x} {info commands 3m}
list [catch {{a b c}} msg] $msg
} {1 {wrong # args: should be "{a b c} x"}}
test proc-3.7 {TclObjInterpProc, wrong num args, Bug 3366265} {
proc {} {x} {}
list [catch {{}} msg] $msg
} {1 {wrong # args: should be "{} x"}}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {rename {a b c} {}}
catch {unset msg}
if {[catch {package require procbodytest}]} {
puts "This application couldn't load the \"procbodytest\" package, so I"
puts "can't test creation of procs whose bodies have type \"procbody\"."
::tcltest::cleanupTests
return
}
catch {rename p ""}
catch {rename t ""}
# Note that the test require that procedures whose body is used to create
# procbody objects must be executed before the procbodytest::proc command
# is executed, so that the Proc struct is populated correctly (CompiledLocals
# are added at compile time).
test proc-4.1 {TclCreateProc, procbody obj} {
catch {
proc p x {return "$x:$x"}
set rv [p P]
procbodytest::proc t x p
lappend rv [t T]
set rv
} result
catch {rename p ""}
catch {rename t ""}
set result
} {P:P T:T}
test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} {
catch {
proc p x {
set y [string tolower $x]
return "$x:$y"
}
set rv [p P]
procbodytest::proc t x p
lappend rv [t T]
set rv
} result
catch {rename p ""}
catch {rename t ""}
set result
} {P:p T:t}
test proc-4.3 {TclCreateProc, procbody obj, too many args} {
catch {
proc p x {
set y [string tolower $x]
return "$x:$y"
}
set rv [p P]
procbodytest::proc t {x x1 x2} p
lappend rv [t T]
set rv
} result
catch {rename p ""}
catch {rename t ""}
set result
} {procedure "t": arg list contains 3 entries, precompiled header expects 1}
test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} {
catch {
proc p {x y z} {
set v [join [list $x $y $z]]
set w [string tolower $v]
return "$v:$w"
}
set rv [p P Q R]
procbodytest::proc t {x x1 z} p
lappend rv [t S T U]
set rv
} result
catch {rename p ""}
catch {rename t ""}
set result
} {procedure "t": formal parameter 1 is inconsistent with precompiled body}
test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} {
catch {
proc p {x y {z Z}} {
set v [join [list $x $y $z]]
set w [string tolower $v]
return "$v:$w"
}
set rv [p P Q R]
procbodytest::proc t {x y z} p
lappend rv [t S T U]
set rv
} result
catch {rename p ""}
catch {rename t ""}
set result
} {procedure "t": formal parameter 2 is inconsistent with precompiled body}
test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} {
catch {
proc p {x y z} {
set v [join [list $x $y $z]]
set w [string tolower $v]
return "$v:$w"
}
set rv [p P Q R]
procbodytest::proc t {x y {z Z}} p
lappend rv [t S T U]
set rv
} result
catch {rename p ""}
catch {rename t ""}
set result
} {procedure "t": formal parameter 2 is inconsistent with precompiled body}
test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} {
catch {
proc p {x y {z Z}} {
set v [join [list $x $y $z]]
set w [string tolower $v]
return "$v:$w"
}
set rv [p P Q R]
procbodytest::proc t {x y {z ZZ}} p
lappend rv [t S T U]
set rv
} result
catch {rename p ""}
catch {rename t ""}
set result
} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}
test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup {
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex $lines 3 3
}
proc px x {
set y [string tolower $x]
return "$x:$y"
}
px x
} -constraints memory -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
procbodytest::proc tx x px
set tmp $end
set end [getbytes]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
rename getbytes {}
} -result 0
test proc-5.1 {Bytecompiling noop; test for correct argument substitution} {
proc p args {} ; # this will be bytecompiled into t
proc t {} {
set res {}
set a 0
set b 0
trace add variable a read {append res a ;#}
trace add variable b write {append res b ;#}
p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello
set res
}
set result [t]
catch {rename p ""}
catch {rename t ""}
set result
} {aba}
test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} {
proc a {} {return -code -5}
proc b {} a
set result [catch b]
rename a {}
rename b {}
set result
} -5
# cleanup
catch {rename p ""}
catch {rename t ""}
::tcltest::cleanupTests
return
tcl8.4.20/tests/string.test 0000644 0036047 0045461 00000132632 11737050674 014277 0 ustar dgp 771div # Commands covered: string
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Some tests require the testobj command
set ::tcltest::testConstraints(testobj) \
[expr {[info commands testobj] != {}}]
set ::tcltest::testConstraints(testindexobj) \
[expr {[info commands testindexobj] != {}}]
test string-1.1 {error conditions} {
list [catch {string gorp a b} msg] $msg
} {1 {bad option "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2 {error conditions} {
list [catch {string} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}
test string-2.1 {string compare, too few args} {
list [catch {string compare a} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.2 {string compare, bad args} {
list [catch {string compare a b c} msg] $msg
} {1 {bad option "a": must be -nocase or -length}}
test string-2.3 {string compare, bad args} {
list [catch {string compare -length -nocase str1 str2} msg] $msg
} {1 {expected integer but got "-nocase"}}
test string-2.4 {string compare, too many args} {
list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.5 {string compare with length unspecified} {
list [catch {string compare -length 10 10} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.6 {string compare} {
string compare abcde abdef
} -1
test string-2.7 {string compare, shortest method name} {
string c abcde ABCDE
} 1
test string-2.8 {string compare} {
string compare abcde abcde
} 0
test string-2.9 {string compare with length} {
string compare -length 2 abcde abxyz
} 0
test string-2.10 {string compare with special index} {
list [catch {string compare -length end-3 abcde abxyz} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-2.11 {string compare, unicode} {
string compare ab\u7266 ab\u7267
} -1
test string-2.12 {string compare, high bit} {
# This test will fail if the underlying comparaison
# is using signed chars instead of unsigned chars.
# (like SunOS's default memcmp thus the compat/memcmp.c)
string compare "\x80" "@"
# Nb this tests works also in utf8 space because \x80 is
# translated into a 2 or more bytelength but whose first byte has
# the high bit set.
} 1
test string-2.13 {string compare -nocase} {
string compare -nocase abcde abdef
} -1
test string-2.14 {string compare -nocase} {
string c -nocase abcde ABCDE
} 0
test string-2.15 {string compare -nocase} {
string compare -nocase abcde abcde
} 0
test string-2.16 {string compare -nocase with length} {
string compare -length 2 -nocase abcde Abxyz
} 0
test string-2.17 {string compare -nocase with length} {
string compare -nocase -length 3 abcde Abxyz
} -1
test string-2.18 {string compare -nocase with length <= 0} {
string compare -nocase -length -1 abcde AbCdEf
} -1
test string-2.19 {string compare -nocase with excessive length} {
string compare -nocase -length 50 AbCdEf abcde
} 1
test string-2.20 {string compare -len unicode} {
# These are strings that are 6 BYTELENGTH long, but the length
# shouldn't make a different because there are actually 3 CHARS long
string compare -len 5 \334\334\334 \334\334\374
} -1
test string-2.21 {string compare -nocase with special index} {
list [catch {string compare -nocase -length end-3 Abcde abxyz} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-2.22 {string compare, null strings} {
string compare "" ""
} 0
test string-2.23 {string compare, null strings} {
string compare "" foo
} -1
test string-2.24 {string compare, null strings} {
string compare foo ""
} 1
test string-2.25 {string compare -nocase, null strings} {
string compare -nocase "" ""
} 0
test string-2.26 {string compare -nocase, null strings} {
string compare -nocase "" foo
} -1
test string-2.27 {string compare -nocase, null strings} {
string compare -nocase foo ""
} 1
test string-2.28 {string compare with length, unequal strings} {
string compare -length 2 abc abde
} 0
test string-2.29 {string compare with length, unequal strings} {
string compare -length 2 ab abde
} 0
test string-2.30 {string compare with NUL character vs. other ASCII} {
# Be careful here, since UTF-8 rep comparison with memcmp() of
# these puts chars in the wrong order
string compare \x00 \x01
} -1
test string-2.31 {string compare, high bit} {
proc foo {} {string compare "a\x80" "a@"}
foo
} 1
test string-2.32 {string compare, high bit} {
proc foo {} {string compare "a\x00" "a\x01"}
foo
} -1
test string-2.33 {string compare, high bit} {
proc foo {} {string compare "\x00\x00" "\x00\x01"}
foo
} -1
# only need a few tests on equal, since it uses the same code as
# string compare, but just modifies the return output
test string-3.1 {string equal} {
string equal abcde abdef
} 0
test string-3.2 {string equal} {
string eq abcde ABCDE
} 0
test string-3.3 {string equal} {
string equal abcde abcde
} 1
test string-3.4 {string equal -nocase} {
string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334
} 1
test string-3.5 {string equal -nocase} {
string equal -nocase abcde abdef
} 0
test string-3.6 {string equal -nocase} {
string eq -nocase abcde ABCDE
} 1
test string-3.7 {string equal -nocase} {
string equal -nocase abcde abcde
} 1
test string-3.8 {string equal with length, unequal strings} {
string equal -length 2 abc abde
} 1
test string-4.1 {string first, too few args} {
list [catch {string first a} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test string-4.2 {string first, bad args} {
list [catch {string first a b c} msg] $msg
} {1 {bad index "c": must be integer or end?-integer?}}
test string-4.3 {string first, too many args} {
list [catch {string first a b 5 d} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test string-4.4 {string first} {
string first bq abcdefgbcefgbqrs
} 12
test string-4.5 {string first} {
string fir bcd abcdefgbcefgbqrs
} 1
test string-4.6 {string first} {
string f b abcdefgbcefgbqrs
} 1
test string-4.7 {string first} {
string first xxx x123xx345xxx789xxx012
} 9
test string-4.8 {string first} {
string first "" x123xx345xxx789xxx012
} -1
test string-4.9 {string first, unicode} {
string first x abc\u7266x
} 4
test string-4.10 {string first, unicode} {
string first \u7266 abc\u7266x
} 3
test string-4.11 {string first, start index} {
string first \u7266 abc\u7266x 3
} 3
test string-4.12 {string first, start index} {
string first \u7266 abc\u7266x 4
} -1
test string-4.13 {string first, start index} {
string first \u7266 abc\u7266x end-2
} 3
test string-4.14 {string first, negative start index} {
string first b abc -1
} 1
test string-4.15 {string first, ability to two-byte encoded utf-8 chars} {
# Test for a bug in Tcl 8.3 where test for all-single-byte-encoded
# strings was incorrect, leading to an index returned by [string first]
# which pointed past the end of the string.
set uchar \u057e ;# character with two-byte encoding in utf-8
string first % %#$uchar$uchar#$uchar$uchar#% 3
} 8
test string-5.1 {string index} {
list [catch {string index} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.2 {string index} {
list [catch {string index a b c} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.3 {string index} {
string index abcde 0
} a
test string-5.4 {string index} {
string in abcde 4
} e
test string-5.5 {string index} {
string index abcde 5
} {}
test string-5.6 {string index} {
list [catch {string index abcde -10} msg] $msg
} {0 {}}
test string-5.7 {string index} {
list [catch {string index a xyz} msg] $msg
} {1 {bad index "xyz": must be integer or end?-integer?}}
test string-5.8 {string index} {
string index abc end
} c
test string-5.9 {string index} {
string index abc end-1
} b
test string-5.10 {string index, unicode} {
string index abc\u7266d 4
} d
test string-5.11 {string index, unicode} {
string index abc\u7266d 3
} \u7266
test string-5.12 {string index, unicode over char length, under byte length} {
string index \334\374\334\374 6
} {}
test string-5.13 {string index, bytearray object} {
string index [binary format a5 fuz] 0
} f
test string-5.14 {string index, bytearray object} {
string index [binary format I* {0x50515253 0x52}] 3
} S
test string-5.15 {string index, bytearray object} {
set b [binary format I* {0x50515253 0x52}]
set i1 [string index $b end-6]
set i2 [string index $b 1]
string compare $i1 $i2
} 0
test string-5.16 {string index, bytearray object with string obj shimmering} {
set str "0123456789\x00 abcdedfghi"
binary scan $str H* dump
string compare [string index $str 10] \x00
} 0
test string-5.17 {string index, bad integer} {
list [catch {string index "abc" 08} msg] $msg
} {1 {bad index "08": must be integer or end?-integer? (looks like invalid octal number)}}
test string-5.18 {string index, bad integer} {
list [catch {string index "abc" end-00289} msg] $msg
} {1 {bad index "end-00289": must be integer or end?-integer? (looks like invalid octal number)}}
test string-5.19 {string index, bytearray object out of bounds} {
string index [binary format I* {0x50515253 0x52}] -1
} {}
test string-5.20 {string index, bytearray object out of bounds} {
string index [binary format I* {0x50515253 0x52}] 20
} {}
proc largest_int {} {
# This will give us what the largest valid int on this machine is,
# so we can test for overflow properly below on >32 bit systems
set int 1
set exp 7; # assume we get at least 8 bits
while {$int > 0} { set int [expr {wide(1) << [incr exp]}] }
return [expr {$int-1}]
}
test string-6.1 {string is, too few args} {
list [catch {string is} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.2 {string is, too few args} {
list [catch {string is alpha} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.3 {string is, bad args} {
list [catch {string is alpha -failin str} msg] $msg
} {1 {wrong # args: should be "string is alpha ?-strict? ?-failindex var? str"}}
test string-6.4 {string is, too many args} {
list [catch {string is alpha -failin var -strict str more} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.5 {string is, class check} {
list [catch {string is bogus str} msg] $msg
} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, lower, print, punct, space, true, upper, wordchar, or xdigit}}
test string-6.6 {string is, ambiguous class} {
list [catch {string is al str} msg] $msg
} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, lower, print, punct, space, true, upper, wordchar, or xdigit}}
test string-6.7 {string is alpha, all ok} {
string is alpha -strict -failindex var abc
} 1
test string-6.8 {string is, error in var} {
list [string is alpha -failindex var abc5def] $var
} {0 3}
test string-6.9 {string is, var shouldn't get set} {
catch {unset var}
list [catch {string is alpha -failindex var abc; set var} msg] $msg
} {1 {can't read "var": no such variable}}
test string-6.10 {string is, ok on empty} {
string is alpha {}
} 1
test string-6.11 {string is, -strict check against empty} {
string is alpha -strict {}
} 0
test string-6.12 {string is alnum, true} {
string is alnum abc123
} 1
test string-6.13 {string is alnum, false} {
list [string is alnum -failindex var abc1.23] $var
} {0 4}
test string-6.14 {string is alnum, unicode} {
string is alnum abcќ
} 1
test string-6.15 {string is alpha, true} {
string is alpha abc
} 1
test string-6.16 {string is alpha, false} {
list [string is alpha -fail var a1bcde] $var
} {0 1}
test string-6.17 {string is alpha, unicode} {
string is alpha abc\374
} 1
test string-6.18 {string is ascii, true} {
string is ascii abc\u007Fend
} 1
test string-6.19 {string is ascii, false} {
list [string is ascii -fail var abcdef\u0080more] $var
} {0 6}
test string-6.20 {string is boolean, true} {
string is boolean true
} 1
test string-6.21 {string is boolean, true} {
string is boolean f
} 1
test string-6.22 {string is boolean, true based on type} {
string is bool [string compare a a]
} 1
test string-6.23 {string is boolean, false} {
list [string is bool -fail var yada] $var
} {0 0}
test string-6.24 {string is digit, true} {
string is digit 0123456789
} 1
test string-6.25 {string is digit, false} {
list [string is digit -fail var 0123м567] $var
} {0 4}
test string-6.26 {string is digit, false} {
list [string is digit -fail var +123567] $var
} {0 0}
test string-6.27 {string is double, true} {
string is double 1
} 1
test string-6.28 {string is double, true} {
string is double [expr double(1)]
} 1
test string-6.29 {string is double, true} {
string is double 1.0
} 1
test string-6.30 {string is double, true} {
string is double [string compare a a]
} 1
test string-6.31 {string is double, true} {
string is double " +1.0e-1 "
} 1
test string-6.32 {string is double, true} {
string is double "\n1.0\v"
} 1
test string-6.33 {string is double, false} {
list [string is double -fail var 1abc] $var
} {0 1}
test string-6.34 {string is double, false} {
list [string is double -fail var abc] $var
} {0 0}
test string-6.35 {string is double, false} {
list [string is double -fail var " 1.0e4e4 "] $var
} {0 8}
test string-6.36 {string is double, false} {
list [string is double -fail var "\n"] $var
} {0 0}
test string-6.37 {string is double, false on int overflow} {
# Make it the largest int recognizable, with one more digit for overflow
list [string is double -fail var [largest_int]0] $var
} {0 -1}
test string-6.38 {string is double, false on underflow} {
catch {unset var}
list [string is double -fail var 123e-9999] $var
} {0 -1}
test string-6.39 {string is double, false} {nonPortable} {
# This test is non-portable because IRIX thinks
# that .e1 is a valid double - this is really a bug
# on IRIX as .e1 should NOT be a valid double
list [string is double -fail var .e1] $var
} {0 0}
test string-6.40 {string is false, true} {
string is false false
} 1
test string-6.41 {string is false, true} {
string is false FaLsE
} 1
test string-6.42 {string is false, true} {
string is false N
} 1
test string-6.43 {string is false, true} {
string is false 0
} 1
test string-6.44 {string is false, true} {
string is false off
} 1
test string-6.45 {string is false, false} {
list [string is false -fail var abc] $var
} {0 0}
test string-6.46 {string is false, false} {
catch {unset var}
list [string is false -fail var Y] $var
} {0 0}
test string-6.47 {string is false, false} {
catch {unset var}
list [string is false -fail var offensive] $var
} {0 0}
test string-6.48 {string is integer, true} {
string is integer +1234567890
} 1
test string-6.49 {string is integer, true on type} {
string is integer [expr int(50.0)]
} 1
test string-6.50 {string is integer, true} {
string is integer [list -10]
} 1
test string-6.51 {string is integer, true as hex} {
string is integer 0xabcdef
} 1
test string-6.52 {string is integer, true as octal} {
string is integer 012345
} 1
test string-6.53 {string is integer, true with whitespace} {
string is integer " \n1234\v"
} 1
test string-6.54 {string is integer, false} {
list [string is integer -fail var 123abc] $var
} {0 3}
test string-6.55 {string is integer, false on overflow} {
list [string is integer -fail var +[largest_int]0] $var
} {0 -1}
test string-6.56 {string is integer, false} {
list [string is integer -fail var [expr double(1)]] $var
} {0 1}
test string-6.57 {string is integer, false} {
list [string is integer -fail var " "] $var
} {0 0}
test string-6.58 {string is integer, false on bad octal} {
list [string is integer -fail var 036963] $var
} {0 3}
test string-6.59 {string is integer, false on bad hex} {
list [string is integer -fail var 0X345XYZ] $var
} {0 5}
test string-6.60 {string is lower, true} {
string is lower abc
} 1
test string-6.61 {string is lower, unicode true} {
string is lower abcќue
} 1
test string-6.62 {string is lower, false} {
list [string is lower -fail var aBc] $var
} {0 1}
test string-6.63 {string is lower, false} {
list [string is lower -fail var abc1] $var
} {0 3}
test string-6.64 {string is lower, unicode false} {
list [string is lower -fail var abмUE] $var
} {0 2}
test string-6.65 {string is space, true} {
string is space " \t\n\v\f"
} 1
test string-6.66 {string is space, false} {
list [string is space -fail var " \t\n\v1\f"] $var
} {0 4}
test string-6.67 {string is true, true} {
string is true true
} 1
test string-6.68 {string is true, true} {
string is true TrU
} 1
test string-6.69 {string is true, true} {
string is true ye
} 1
test string-6.70 {string is true, true} {
string is true 1
} 1
test string-6.71 {string is true, true} {
string is true on
} 1
test string-6.72 {string is true, false} {
list [string is true -fail var onto] $var
} {0 0}
test string-6.73 {string is true, false} {
catch {unset var}
list [string is true -fail var 25] $var
} {0 0}
test string-6.74 {string is true, false} {
catch {unset var}
list [string is true -fail var no] $var
} {0 0}
test string-6.75 {string is upper, true} {
string is upper ABC
} 1
test string-6.76 {string is upper, unicode true} {
string is upper ABCмUE
} 1
test string-6.77 {string is upper, false} {
list [string is upper -fail var AbC] $var
} {0 1}
test string-6.78 {string is upper, false} {
list [string is upper -fail var AB2C] $var
} {0 2}
test string-6.79 {string is upper, unicode false} {
list [string is upper -fail var ABCќue] $var
} {0 3}
test string-6.80 {string is wordchar, true} {
string is wordchar abc_123
} 1
test string-6.81 {string is wordchar, unicode true} {
string is wordchar abcќabмAB\u5001
} 1
test string-6.82 {string is wordchar, false} {
list [string is wordchar -fail var abcd.ef] $var
} {0 4}
test string-6.83 {string is wordchar, unicode false} {
list [string is wordchar -fail var abc\u0080def] $var
} {0 3}
test string-6.84 {string is control} {
## Control chars are in the ranges
## 00..1F && 7F..9F
list [string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60] $var
} {0 7}
test string-6.85 {string is control} {
string is control \u0100
} 0
test string-6.86 {string is graph} {
## graph is any print char, except space
list [string is gra -fail var "0123abc!@#\$\u0100 "] $var
} {0 12}
test string-6.87 {string is print} {
## basically any printable char
list [string is print -fail var "0123abc!@#\$\u0100 \u0010"] $var
} {0 13}
test string-6.88 {string is punct} {
## any graph char that isn't alnum
list [string is punct -fail var "_!@#\u00beq0"] $var
} {0 4}
test string-6.89 {string is xdigit} {
list [string is xdigit -fail var 0123456789\u0061bcdefABCDEFg] $var
} {0 22}
test string-6.90 {string is integer, bad integers} {
# SF bug #634856
set result ""
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
foreach num $numbers {
lappend result [string is int -strict $num]
}
set result
} {1 1 0 0 0 1 0 0}
test string-6.91 {string is double, bad doubles} {
set result ""
set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"]
foreach num $numbers {
lappend result [string is double -strict $num]
}
set result
} {1 1 0 0 0 1 0 0}
test string-6.92 {string is integer, 32-bit overflow} {
# Bug 718878
set x 0x100000000
list [string is integer -failindex var $x] $var
} {0 -1}
test string-6.93 {string is integer, 32-bit overflow} {
# Bug 718878
set x 0x100000000
append x ""
list [string is integer -failindex var $x] $var
} {0 -1}
test string-6.94 {string is integer, 32-bit overflow} {
# Bug 718878
set x 0x100000000
list [string is integer -failindex var [expr {$x}]] $var
} {0 -1}
catch {rename largest_int {}}
test string-7.1 {string last, too few args} {
list [catch {string last a} msg] $msg
} {1 {wrong # args: should be "string last subString string ?startIndex?"}}
test string-7.2 {string last, bad args} {
list [catch {string last a b c} msg] $msg
} {1 {bad index "c": must be integer or end?-integer?}}
test string-7.3 {string last, too many args} {
list [catch {string last a b c d} msg] $msg
} {1 {wrong # args: should be "string last subString string ?startIndex?"}}
test string-7.4 {string last} {
string la xxx xxxx123xx345x678
} 1
test string-7.5 {string last} {
string last xx xxxx123xx345x678
} 7
test string-7.6 {string last} {
string las x xxxx123xx345x678
} 12
test string-7.7 {string last, unicode} {
string las x xxxx12\u7266xx345x678
} 12
test string-7.8 {string last, unicode} {
string las \u7266 xxxx12\u7266xx345x678
} 6
test string-7.9 {string last, stop index} {
string las \u7266 xxxx12\u7266xx345x678
} 6
test string-7.10 {string last, unicode} {
string las \u7266 xxxx12\u7266xx345x678
} 6
test string-7.11 {string last, start index} {
string last \u7266 abc\u7266x 3
} 3
test string-7.12 {string last, start index} {
string last \u7266 abc\u7266x 2
} -1
test string-7.13 {string last, start index} {
## Constrain to last 'a' should work
string last ba badbad end-1
} 3
test string-7.14 {string last, start index} {
## Constrain to last 'b' should skip last 'ba'
string last ba badbad end-2
} 0
test string-7.15 {string last, start index} {
string last \334a \334ad\334ad 0
} -1
test string-7.16 {string last, start index} {
string last \334a \334ad\334ad end-1
} 3
test string-8.1 {string bytelength} {
list [catch {string bytelength} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.2 {string bytelength} {
list [catch {string bytelength a b} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.3 {string bytelength} {
string bytelength "\u00c7"
} 2
test string-8.4 {string bytelength} {
string b ""
} 0
test string-9.1 {string length} {
list [catch {string length} msg] $msg
} {1 {wrong # args: should be "string length string"}}
test string-9.2 {string length} {
list [catch {string length a b} msg] $msg
} {1 {wrong # args: should be "string length string"}}
test string-9.3 {string length} {
string length "a little string"
} 15
test string-9.4 {string length} {
string le ""
} 0
test string-9.5 {string length, unicode} {
string le "abcd\u7266"
} 5
test string-9.6 {string length, bytearray object} {
string length [binary format a5 foo]
} 5
test string-9.7 {string length, bytearray object} {
string length [binary format I* {0x50515253 0x52}]
} 8
test string-10.1 {string map, too few args} {
list [catch {string map} msg] $msg
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
test string-10.2 {string map, bad args} {
list [catch {string map {a b} abba oops} msg] $msg
} {1 {bad option "a b": must be -nocase}}
test string-10.3 {string map, too many args} {
list [catch {string map -nocase {a b} str1 str2} msg] $msg
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
test string-10.4 {string map} {
string map {a b} abba
} {bbbb}
test string-10.5 {string map} {
string map {a b} a
} {b}
test string-10.6 {string map -nocase} {
string map -nocase {a b} Abba
} {bbbb}
test string-10.7 {string map} {
string map {abc 321 ab * a A} aabcabaababcab
} {A321*A*321*}
test string-10.8 {string map -nocase} {
string map -nocase {aBc 321 Ab * a A} aabcabaababcab
} {A321*A*321*}
test string-10.9 {string map -nocase} {
string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb
} {A321*A*321*}
test string-10.10 {string map} {
list [catch {string map {a b c} abba} msg] $msg
} {1 {char map list unbalanced}}
test string-10.11 {string map, nulls} {
string map {\x00 NULL blah \x00nix} {qwerty}
} {qwerty}
test string-10.12 {string map, unicode} {
string map [list \374 ue UE \334] "a\374ueUE\000EU"
} aueue\334\0EU
test string-10.13 {string map, -nocase unicode} {
string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU"
} aue\334\334\0EU
test string-10.14 {string map, -nocase null arguments} {
string map -nocase {{} abc} foo
} foo
test string-10.15 {string map, one pair case} {
string map -nocase {abc 32} aAbCaBaAbAbcAb
} {a32aBaAb32Ab}
test string-10.16 {string map, one pair case} {
string map -nocase {ab 4321} aAbCaBaAbAbcAb
} {a4321C4321a43214321c4321}
test string-10.17 {string map, one pair case} {
string map {Ab 4321} aAbCaBaAbAbcAb
} {a4321CaBa43214321c4321}
test string-10.18 {string map, empty argument} {
string map -nocase {{} abc} foo
} foo
test string-10.19 {string map, empty arguments} {
string map -nocase {{} abc f bar {} def} foo
} baroo
test string-10.20 {string map, nasty sharing crash from [Bug 1018562]} {
set a {a b}
string map $a $a
} {b b}
test string-10.21 {string map, ABR checks} {
string map {longstring foob} long
} long
test string-10.22 {string map, ABR checks} {
string map {long foob} long
} foob
test string-10.23 {string map, ABR checks} {
string map {lon foob} long
} foobg
test string-10.24 {string map, ABR checks} {
string map {lon foob} longlo
} foobglo
test string-10.25 {string map, ABR checks} {
string map {lon foob} longlon
} foobgfoob
test string-10.26 {string map, ABR checks} {
string map {longstring foob longstring bar} long
} long
test string-10.27 {string map, ABR checks} {
string map {long foob longstring bar} long
} foob
test string-10.28 {string map, ABR checks} {
string map {lon foob longstring bar} long
} foobg
test string-10.29 {string map, ABR checks} {
string map {lon foob longstring bar} longlo
} foobglo
test string-10.30 {string map, ABR checks} {
string map {lon foob longstring bar} longlon
} foobgfoob
test string-11.1 {string match, too few args} {
list [catch {string match a} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test string-11.2 {string match, too many args} {
list [catch {string match a b c d} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test string-11.3 {string match} {
string match abc abc
} 1
test string-11.4 {string match} {
string mat abc abd
} 0
test string-11.5 {string match} {
string match ab*c abc
} 1
test string-11.6 {string match} {
string match ab**c abc
} 1
test string-11.7 {string match} {
string match ab* abcdef
} 1
test string-11.8 {string match} {
string match *c abc
} 1
test string-11.9 {string match} {
string match *3*6*9 0123456789
} 1
test string-11.10 {string match} {
string match *3*6*9 01234567890
} 0
test string-11.11 {string match} {
string match a?c abc
} 1
test string-11.12 {string match} {
string match a??c abc
} 0
test string-11.13 {string match} {
string match ?1??4???8? 0123456789
} 1
test string-11.14 {string match} {
string match {[abc]bc} abc
} 1
test string-11.15 {string match} {
string match {a[abc]c} abc
} 1
test string-11.16 {string match} {
string match {a[xyz]c} abc
} 0
test string-11.17 {string match} {
string match {12[2-7]45} 12345
} 1
test string-11.18 {string match} {
string match {12[ab2-4cd]45} 12345
} 1
test string-11.19 {string match} {
string match {12[ab2-4cd]45} 12b45
} 1
test string-11.20 {string match} {
string match {12[ab2-4cd]45} 12d45
} 1
test string-11.21 {string match} {
string match {12[ab2-4cd]45} 12145
} 0
test string-11.22 {string match} {
string match {12[ab2-4cd]45} 12545
} 0
test string-11.23 {string match} {
string match {a\*b} a*b
} 1
test string-11.24 {string match} {
string match {a\*b} ab
} 0
test string-11.25 {string match} {
string match {a\*\?\[\]\\\x} "a*?\[\]\\x"
} 1
test string-11.26 {string match} {
string match ** ""
} 1
test string-11.27 {string match} {
string match *. ""
} 0
test string-11.28 {string match} {
string match "" ""
} 1
test string-11.29 {string match} {
string match \[a a
} 1
test string-11.30 {string match, bad args} {
list [catch {string match - b c} msg] $msg
} {1 {bad option "-": must be -nocase}}
test string-11.31 {string match case} {
string match a A
} 0
test string-11.32 {string match nocase} {
string match -n a A
} 1
test string-11.33 {string match nocase} {
string match -nocase a\334 A\374
} 1
test string-11.34 {string match nocase} {
string match -nocase a*f ABCDEf
} 1
test string-11.35 {string match case, false hope} {
# This is true because '_' lies between the A-Z and a-z ranges
string match {[A-z]} _
} 1
test string-11.36 {string match nocase range} {
# This is false because although '_' lies between the A-Z and a-z ranges,
# we lower case the end points before checking the ranges.
string match -nocase {[A-z]} _
} 0
test string-11.37 {string match nocase} {
string match -nocase {[A-fh-Z]} g
} 0
test string-11.38 {string match case, reverse range} {
string match {[A-fh-Z]} g
} 1
test string-11.39 {string match, *\ case} {
string match {*\abc} abc
} 1
test string-11.40 {string match, *special case} {
string match {*[ab]} abc
} 0
test string-11.41 {string match, *special case} {
string match {*[ab]*} abc
} 1
test string-11.42 {string match, *special case} {
string match "*\\" "\\"
} 0
test string-11.43 {string match, *special case} {
string match "*\\\\" "\\"
} 1
test string-11.44 {string match, *special case} {
string match "*???" "12345"
} 1
test string-11.45 {string match, *special case} {
string match "*???" "12"
} 0
test string-11.46 {string match, *special case} {
string match "*\\*" "abc*"
} 1
test string-11.47 {string match, *special case} {
string match "*\\*" "*"
} 1
test string-11.48 {string match, *special case} {
string match "*\\*" "*abc"
} 0
test string-11.49 {string match, *special case} {
string match "?\\*" "a*"
} 1
test string-11.50 {string match, *special case} {
string match "\\" "\\"
} 0
test string-11.51 {string match; *, -nocase and UTF-8} {
string match -nocase [binary format I 717316707] \
[binary format I 2028036707]
} 1
test string-11.52 {string match, null char in string} {
set out ""
set ptn "*abc*"
foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] {
lappend out [string match $ptn $elem]
}
set out
} {1 1 1 1}
test string-11.53 {string match, null char in pattern} {
set out ""
foreach {ptn elem} [list \
"*\u0000abc\u0000" "\u0000abc\u0000" \
"*\u0000abc\u0000" "\u0000abc\u0000ef" \
"*\u0000abc\u0000*" "\u0000abc\u0000ef" \
"*\u0000abc\u0000" "@\u0000abc\u0000ef" \
"*\u0000abc\u0000*" "@\u0000abc\u0000ef" \
] {
lappend out [string match $ptn $elem]
}
set out
} {1 0 1 0 1}
test string-11.54 {string match, failure} {
set longString ""
for {set i 0} {$i < 10} {incr i} {
append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123"
}
string first $longString 123
list [string match *cba* $longString] \
[string match *a*l*\u0000* $longString] \
[string match *a*l*\u0000*123 $longString] \
[string match *a*l*\u0000*123* $longString] \
[string match *a*l*\u0000*cba* $longString] \
[string match *===* $longString]
} {0 1 1 1 0 0}
test string-12.1 {string range} {
list [catch {string range} msg] $msg
} {1 {wrong # args: should be "string range string first last"}}
test string-12.2 {string range} {
list [catch {string range a 1} msg] $msg
} {1 {wrong # args: should be "string range string first last"}}
test string-12.3 {string range} {
list [catch {string range a 1 2 3} msg] $msg
} {1 {wrong # args: should be "string range string first last"}}
test string-12.4 {string range} {
string range abcdefghijklmnop 2 14
} {cdefghijklmno}
test string-12.5 {string range, last > length} {
string range abcdefghijklmnop 7 1000
} {hijklmnop}
test string-12.6 {string range} {
string range abcdefghijklmnop 10 e
} {klmnop}
test string-12.7 {string range, last < first} {
string range abcdefghijklmnop 10 9
} {}
test string-12.8 {string range, first < 0} {
string range abcdefghijklmnop -3 2
} {abc}
test string-12.9 {string range} {
string range abcdefghijklmnop -3 -2
} {}
test string-12.10 {string range} {
string range abcdefghijklmnop 1000 1010
} {}
test string-12.11 {string range} {
string range abcdefghijklmnop -100 end
} {abcdefghijklmnop}
test string-12.12 {string range} {
list [catch {string range abc abc 1} msg] $msg
} {1 {bad index "abc": must be integer or end?-integer?}}
test string-12.13 {string range} {
list [catch {string range abc 1 eof} msg] $msg
} {1 {bad index "eof": must be integer or end?-integer?}}
test string-12.14 {string range} {
string range abcdefghijklmnop end-1 end
} {op}
test string-12.15 {string range} {
string range abcdefghijklmnop e 1000
} {p}
test string-12.16 {string range} {
string range abcdefghijklmnop end end-1
} {}
test string-12.17 {string range, unicode} {
string range ab\u7266cdefghijklmnop 5 5
} e
test string-12.18 {string range, unicode} {
string range ab\u7266cdefghijklmnop 2 3
} \u7266c
test string-12.19 {string range, bytearray object} {
set b [binary format I* {0x50515253 0x52}]
set r1 [string range $b 1 end-1]
set r2 [string range $b 1 6]
string equal $r1 $r2
} 1
test string-12.20 {string range, out of bounds indices} {
string range \u00ff 0 1
} \u00ff
test string-12.21 {string range, regenerates correct reps, bug 1410553} {
set bytes "\x00 \x03 \x41"
set rxBuffer {}
foreach ch $bytes {
append rxBuffer $ch
if {$ch eq "\x03"} {
string length $rxBuffer
}
}
set rxCRC [string range $rxBuffer end-1 end]
binary scan [join $bytes {}] "H*" input_hex
binary scan $rxBuffer "H*" rxBuffer_hex
binary scan $rxCRC "H*" rxCRC_hex
list $input_hex $rxBuffer_hex $rxCRC_hex
} {000341 000341 0341}
test string-13.1 {string repeat} {
list [catch {string repeat} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
test string-13.2 {string repeat} {
list [catch {string repeat abc 10 oops} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
test string-13.3 {string repeat} {
string repeat {} 100
} {}
test string-13.4 {string repeat} {
string repeat { } 5
} { }
test string-13.5 {string repeat} {
string repeat abc 3
} {abcabcabc}
test string-13.6 {string repeat} {
string repeat abc -1
} {}
test string-13.7 {string repeat} {
list [catch {string repeat abc end} msg] $msg
} {1 {expected integer but got "end"}}
test string-13.8 {string repeat} {
string repeat {} -1000
} {}
test string-13.9 {string repeat} {
string repeat {} 0
} {}
test string-13.10 {string repeat} {
string repeat def 0
} {}
test string-13.11 {string repeat} {
string repeat def 1
} def
test string-13.12 {string repeat} {
string repeat ab\u7266cd 3
} ab\u7266cdab\u7266cdab\u7266cd
test string-13.13 {string repeat} {
string repeat \x00 3
} \x00\x00\x00
test string-13.14 {string repeat} {
# The string range will ensure us that string repeat gets a unicode string
string repeat [string range ab\u7266cd 2 3] 3
} \u7266c\u7266c\u7266c
test string-14.1 {string replace} {
list [catch {string replace} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.2 {string replace} {
list [catch {string replace a 1} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.3 {string replace} {
list [catch {string replace a 1 2 3 4} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.4 {string replace} {
} {}
test string-14.5 {string replace} {
string replace abcdefghijklmnop 2 14
} {abp}
test string-14.6 {string replace} {
string replace abcdefghijklmnop 7 1000
} {abcdefg}
test string-14.7 {string replace} {
string replace abcdefghijklmnop 10 e
} {abcdefghij}
test string-14.8 {string replace} {
string replace abcdefghijklmnop 10 9
} {abcdefghijklmnop}
test string-14.9 {string replace} {
string replace abcdefghijklmnop -3 2
} {defghijklmnop}
test string-14.10 {string replace} {
string replace abcdefghijklmnop -3 -2
} {abcdefghijklmnop}
test string-14.11 {string replace} {
string replace abcdefghijklmnop 1000 1010
} {abcdefghijklmnop}
test string-14.12 {string replace} {
string replace abcdefghijklmnop -100 end
} {}
test string-14.13 {string replace} {
list [catch {string replace abc abc 1} msg] $msg
} {1 {bad index "abc": must be integer or end?-integer?}}
test string-14.14 {string replace} {
list [catch {string replace abc 1 eof} msg] $msg
} {1 {bad index "eof": must be integer or end?-integer?}}
test string-14.15 {string replace} {
string replace abcdefghijklmnop end-10 end-2 NEW
} {abcdeNEWop}
test string-14.16 {string replace} {
string replace abcdefghijklmnop 0 e foo
} {foo}
test string-14.17 {string replace} {
string replace abcdefghijklmnop end end-1
} {abcdefghijklmnop}
test string-15.1 {string tolower too few args} {
list [catch {string tolower} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
test string-15.2 {string tolower bad args} {
list [catch {string tolower a b} msg] $msg
} {1 {bad index "b": must be integer or end?-integer?}}
test string-15.3 {string tolower too many args} {
list [catch {string tolower ABC 1 end oops} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
test string-15.4 {string tolower} {
string tolower ABCDeF
} {abcdef}
test string-15.5 {string tolower} {
string tolower "ABC XyZ"
} {abc xyz}
test string-15.6 {string tolower} {
string tolower {123#$&*()}
} {123#$&*()}
test string-15.7 {string tolower} {
string tolower ABC 1
} AbC
test string-15.8 {string tolower} {
string tolower ABC 1 end
} Abc
test string-15.9 {string tolower} {
string tolower ABC 0 end-1
} abC
test string-15.10 {string tolower, unicode} {
string tolower ABCabc\xc7\xe7
} "abcabc\xe7\xe7"
test string-16.1 {string toupper} {
list [catch {string toupper} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.2 {string toupper} {
list [catch {string toupper a b} msg] $msg
} {1 {bad index "b": must be integer or end?-integer?}}
test string-16.3 {string toupper} {
list [catch {string toupper a 1 end oops} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.4 {string toupper} {
string toupper abCDEf
} {ABCDEF}
test string-16.5 {string toupper} {
string toupper "abc xYz"
} {ABC XYZ}
test string-16.6 {string toupper} {
string toupper {123#$&*()}
} {123#$&*()}
test string-16.7 {string toupper} {
string toupper abc 1
} aBc
test string-16.8 {string toupper} {
string toupper abc 1 end
} aBC
test string-16.9 {string toupper} {
string toupper abc 0 end-1
} ABc
test string-16.10 {string toupper, unicode} {
string toupper ABCabc\xc7\xe7
} "ABCABC\xc7\xc7"
test string-17.1 {string totitle} {
list [catch {string totitle} msg] $msg
} {1 {wrong # args: should be "string totitle string ?first? ?last?"}}
test string-17.2 {string totitle} {
list [catch {string totitle a b} msg] $msg
} {1 {bad index "b": must be integer or end?-integer?}}
test string-17.3 {string totitle} {
string totitle abCDEf
} {Abcdef}
test string-17.4 {string totitle} {
string totitle "abc xYz"
} {Abc xyz}
test string-17.5 {string totitle} {
string totitle {123#$&*()}
} {123#$&*()}
test string-17.6 {string totitle, unicode} {
string totitle ABCabc\xc7\xe7
} "Abcabc\xe7\xe7"
test string-17.7 {string totitle, unicode} {
string totitle \u01f3BCabc\xc7\xe7
} "\u01f2bcabc\xe7\xe7"
test string-18.1 {string trim} {
list [catch {string trim} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
test string-18.2 {string trim} {
list [catch {string trim a b c} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
test string-18.3 {string trim} {
string trim " XYZ "
} {XYZ}
test string-18.4 {string trim} {
string trim "\t\nXYZ\t\n\r\n"
} {XYZ}
test string-18.5 {string trim} {
string trim " A XYZ A "
} {A XYZ A}
test string-18.6 {string trim} {
string trim "XXYYZZABC XXYYZZ" ZYX
} {ABC }
test string-18.7 {string trim} {
string trim " \t\r "
} {}
test string-18.8 {string trim} {
string trim {abcdefg} {}
} {abcdefg}
test string-18.9 {string trim} {
string trim {}
} {}
test string-18.10 {string trim} {
string trim ABC DEF
} {ABC}
test string-18.11 {string trim, unicode} {
string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8
} " AB\xe7C "
test string-19.1 {string trimleft} {
list [catch {string trimleft} msg] $msg
} {1 {wrong # args: should be "string trimleft string ?chars?"}}
test string-19.2 {string trimleft} {
string trimleft " XYZ "
} {XYZ }
test string-20.1 {string trimright errors} {
list [catch {string trimright} msg] $msg
} {1 {wrong # args: should be "string trimright string ?chars?"}}
test string-20.2 {string trimright errors} {
list [catch {string trimg a} msg] $msg
} {1 {bad option "trimg": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}}
test string-20.3 {string trimright} {
string trimright " XYZ "
} { XYZ}
test string-20.4 {string trimright} {
string trimright " "
} {}
test string-20.5 {string trimright} {
string trimright ""
} {}
test string-21.1 {string wordend} {
list [catch {string wordend a} msg] $msg
} {1 {wrong # args: should be "string wordend string index"}}
test string-21.2 {string wordend} {
list [catch {string wordend a b c} msg] $msg
} {1 {wrong # args: should be "string wordend string index"}}
test string-21.3 {string wordend} {
list [catch {string wordend a gorp} msg] $msg
} {1 {bad index "gorp": must be integer or end?-integer?}}
test string-21.4 {string wordend} {
string wordend abc. -1
} 3
test string-21.5 {string wordend} {
string wordend abc. 100
} 4
test string-21.6 {string wordend} {
string wordend "word_one two three" 2
} 8
test string-21.7 {string wordend} {
string wordend "one .&# three" 5
} 6
test string-21.8 {string wordend} {
string worde "x.y" 0
} 1
test string-21.9 {string wordend} {
string worde "x.y" end-1
} 2
test string-21.10 {string wordend, unicode} {
string wordend "xyz\u00c7de fg" 0
} 6
test string-21.11 {string wordend, unicode} {
string wordend "xyz\uc700de fg" 0
} 6
test string-21.12 {string wordend, unicode} {
string wordend "xyz\u203fde fg" 0
} 6
test string-21.13 {string wordend, unicode} {
string wordend "xyz\u2045de fg" 0
} 3
test string-21.14 {string wordend, unicode} {
string wordend "\uc700\uc700 abc" 8
} 6
test string-22.1 {string wordstart} {
list [catch {string word a} msg] $msg
} {1 {ambiguous option "word": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2 {string wordstart} {
list [catch {string wordstart a} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.3 {string wordstart} {
list [catch {string wordstart a b c} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.4 {string wordstart} {
list [catch {string wordstart a gorp} msg] $msg
} {1 {bad index "gorp": must be integer or end?-integer?}}
test string-22.5 {string wordstart} {
string wordstart "one two three_words" 400
} 8
test string-22.6 {string wordstart} {
string wordstart "one two three_words" 2
} 0
test string-22.7 {string wordstart} {
string wordstart "one two three_words" -2
} 0
test string-22.8 {string wordstart} {
string wordstart "one .*&^ three" 6
} 6
test string-22.9 {string wordstart} {
string wordstart "one two three" 4
} 4
test string-22.10 {string wordstart} {
string wordstart "one two three" end-5
} 7
test string-22.11 {string wordstart, unicode} {
string wordstart "one tw\u00c7o three" 7
} 4
test string-22.12 {string wordstart, unicode} {
string wordstart "ab\uc700\uc700 cdef ghi" 12
} 10
test string-22.13 {string wordstart, unicode} {
string wordstart "\uc700\uc700 abc" 8
} 3
test string-23.0 {string is boolean, Bug 1187123} testindexobj {
set x 5
catch {testindexobj $x foo bar soom}
string is boolean $x
} 0
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/safe.test 0000644 0036047 0045461 00000042150 11737050674 013702 0 ustar dgp 771div # safe.test --
#
# This file contains a collection of tests for safe Tcl, packages loading,
# and using safe interpreters. Sourcing this file into tcl runs the tests
# and generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
foreach i [interp slaves] {
interp delete $i
}
set saveAutoPath $::auto_path
set ::auto_path [info library]
# Force actual loading of the safe package
# because we use un exported (and thus un-autoindexed) APIs
# in this test result arguments:
catch {safe::interpConfigure}
proc equiv {x} {return $x}
test safe-1.1 {safe::interpConfigure syntax} {
list [catch {safe::interpConfigure} msg] $msg;
} {1 {no value given for parameter "slave" (use -help for full usage) :
slave name () name of the slave}}
test safe-1.2 {safe::interpCreate syntax} {
list [catch {safe::interpCreate -help} msg] $msg;
} {1 {Usage information:
Var/FlagName Type Value Help
------------ ---- ----- ----
( -help gives this help )
?slave? name () name of the slave (optional)
-accessPath list () access path for the slave
-noStatics boolflag (false) prevent loading of statically linked pkgs
-statics boolean (true) loading of statically linked pkgs
-nestedLoadOk boolflag (false) allow nested loading
-nested boolean (false) nested loading
-deleteHook script () delete hook}}
test safe-1.3 {safe::interpInit syntax} {
list [catch {safe::interpInit -noStatics} msg] $msg;
} {1 {bad value "-noStatics" for parameter
slave name () name of the slave}}
test safe-2.1 {creating interpreters, should have no aliases} {
interp aliases
} ""
test safe-2.2 {creating interpreters, should have no aliases} {
catch {safe::interpDelete a}
interp create a
set l [a aliases]
safe::interpDelete a
set l
} ""
test safe-2.3 {creating safe interpreters, should have no aliases} {
catch {safe::interpDelete a}
interp create a -safe
set l [a aliases]
interp delete a
set l
} ""
test safe-3.1 {calling safe::interpInit is safe} {
catch {safe::interpDelete a}
interp create a -safe
safe::interpInit a
catch {interp eval a exec ls} msg
safe::interpDelete a
set msg
} {invalid command name "exec"}
test safe-3.2 {calling safe::interpCreate on trusted interp} {
catch {safe::interpDelete a}
safe::interpCreate a
set l [lsort [a aliases]]
safe::interpDelete a
set l
} {encoding exit file load source}
test safe-3.3 {calling safe::interpCreate on trusted interp} {
catch {safe::interpDelete a}
safe::interpCreate a
set x [interp eval a {source [file join $tcl_library init.tcl]}]
safe::interpDelete a
set x
} ""
test safe-3.4 {calling safe::interpCreate on trusted interp} {
catch {safe::interpDelete a}
safe::interpCreate a
catch {set x \
[interp eval a {source [file join $tcl_library init.tcl]}]} msg
safe::interpDelete a
list $x $msg
} {{} {}}
test safe-4.1 {safe::interpDelete} {
catch {safe::interpDelete a}
interp create a
safe::interpDelete a
} ""
test safe-4.2 {safe::interpDelete, indirectly} {
catch {safe::interpDelete a}
interp create a
a alias exit safe::interpDelete a
a eval exit
} ""
test safe-4.3 {safe::interpDelete, state array (not a public api)} {
catch {safe::interpDelete a}
namespace eval safe {set [InterpStateName a](foo) 33}
# not an error anymore to call it if interp is already
# deleted, to make trhings smooth if it's called twice...
catch {safe::interpDelete a} m1
catch {namespace eval safe {set [InterpStateName a](foo)}} m2
list $m1 $m2
} "{}\
{can't read \"[safe::InterpStateName a](foo)\": no such variable}"
test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} {
catch {safe::interpDelete a}
safe::interpCreate a
namespace eval safe {set [InterpStateName a](foo) 33}
a eval exit
catch {namespace eval safe {set [InterpStateName a](foo)}} msg
} 1
test safe-4.5 {safe::interpDelete} {
catch {safe::interpDelete a}
safe::interpCreate a
catch {safe::interpCreate a} msg
set msg
} {interpreter named "a" already exists, cannot create}
test safe-4.6 {safe::interpDelete, indirectly} {
catch {safe::interpDelete a}
safe::interpCreate a
a eval exit
} ""
# The following test checks whether the definition of tcl_endOfWord can be
# obtained from auto_loading.
test safe-5.1 {test auto-loading in safe interpreters} {
catch {safe::interpDelete a}
safe::interpCreate a
set r [catch {interp eval a {tcl_endOfWord "" 0}} msg]
safe::interpDelete a
list $r $msg
} {0 -1}
# test safe interps 'information leak'
proc SI {} {
global I
set I [interp create -safe];
}
proc DI {} {
global I;
interp delete $I;
}
test safe-6.1 {test safe interpreters knowledge of the world} {
SI; set r [lsort [$I eval {info globals}]]; DI; set r
} {tcl_interactive tcl_patchLevel tcl_platform tcl_version}
test safe-6.2 {test safe interpreters knowledge of the world} {
SI; set r [$I eval {info script}]; DI; set r
} {}
test safe-6.3 {test safe interpreters knowledge of the world} {
SI
set r [lsort [$I eval {array names tcl_platform}]]
DI
# If running a windows-debug shell, remove the "debug" element from r.
if {$tcl_platform(platform) == "windows" && \
[lsearch $r "debug"] != -1} {
set r [lreplace $r 1 1]
}
set threaded [lsearch $r "threaded"]
if {$threaded != -1} {
set r [lreplace $r $threaded $threaded]
}
set tip [lsearch $r "tip,268"]
if {$tip != -1} {
set r [lreplace $r $tip $tip]
}
set tip [lsearch $r "tip,280"]
if {$tip != -1} {
set r [lreplace $r $tip $tip]
}
set r
} {byteOrder platform wordSize}
# more test should be added to check that hostname, nameofexecutable,
# aren't leaking infos, but they still do...
# high level general test
test safe-7.1 {tests that everything works at high level} {
set i [safe::interpCreate];
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs
# so package require in a slave works like in the master)
set v [interp eval $i {package require http 1}]
# no error shall occur:
interp eval $i {http_config};
safe::interpDelete $i
set v
} 1.0
test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]];
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p1
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"];
# an error shall occur (http is not anymore in the secure 0-level
# provided deep path)
list $token1 $token2 \
[catch {interp eval $i {package require http 1}} msg] $msg \
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
# test source control on file name
test safe-8.1 {safe source control on file} {
set i "a";
catch {safe::interpDelete $i}
safe::interpCreate $i;
list [catch {$i eval {source}} msg] \
$msg \
[safe::interpDelete $i] ;
} {1 {wrong # args: should be "source fileName"} {}}
# test source control on file name
test safe-8.2 {safe source control on file} {
set i "a";
catch {safe::interpDelete $i}
safe::interpCreate $i;
list [catch {$i eval {source}} msg] \
$msg \
[safe::interpDelete $i] ;
} {1 {wrong # args: should be "source fileName"} {}}
test safe-8.3 {safe source control on file} {
set i "a";
catch {safe::interpDelete $i}
safe::interpCreate $i;
set log {};
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd];
safe::setLogCmd safe-test-log;
list [catch {$i eval {source .}} msg] \
$msg \
$log \
[safe::setLogCmd $prevlog; unset log] \
[safe::interpDelete $i] ;
} {1 {permission denied} {{ERROR for slave a : ".": is a directory}} {} {}}
test safe-8.4 {safe source control on file} {
set i "a";
catch {safe::interpDelete $i}
safe::interpCreate $i;
set log {};
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd];
safe::setLogCmd safe-test-log;
list [catch {$i eval {source /abc/def}} msg] \
$msg \
$log \
[safe::setLogCmd $prevlog; unset log] \
[safe::interpDelete $i] ;
} {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}} {} {}}
test safe-8.5 {safe source control on file} {
# This tested filename == *.tcl or tclIndex, but that restriction
# was removed in 8.4a4 - hobbs
set i "a";
catch {safe::interpDelete $i}
safe::interpCreate $i;
set log {};
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd];
safe::setLogCmd safe-test-log;
list [catch {$i eval {source [file join [info lib] blah]}} msg] \
$msg \
$log \
[safe::setLogCmd $prevlog; unset log] \
[safe::interpDelete $i] ;
} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"] {} {}]
test safe-8.6 {safe source control on file} {
set i "a";
catch {safe::interpDelete $i}
safe::interpCreate $i;
set log {};
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd];
safe::setLogCmd safe-test-log;
list [catch {$i eval {source [file join [info lib] blah.tcl]}} msg] \
$msg \
$log \
[safe::setLogCmd $prevlog; unset log] \
[safe::interpDelete $i] ;
} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"] {} {}]
test safe-8.7 {safe source control on file} {
# This tested length of filename, but that restriction
# was removed in 8.4a4 - hobbs
set i "a";
catch {safe::interpDelete $i}
safe::interpCreate $i;
set log {};
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd];
safe::setLogCmd safe-test-log;
list [catch {$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}}\
msg] \
$msg \
$log \
[safe::setLogCmd $prevlog; unset log] \
[safe::interpDelete $i] ;
} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"] {} {}]
test safe-8.8 {safe source forbids -rsrc} {
set i "a";
catch {safe::interpDelete $i}
safe::interpCreate $i;
list [catch {$i eval {source -rsrc Init}} msg] \
$msg \
[safe::interpDelete $i] ;
} {1 {wrong # args: should be "source fileName"} {}}
test safe-9.1 {safe interps' deleteHook} {
set i "a";
catch {safe::interpDelete $i}
set res {}
proc testDelHook {args} {
global res;
# the interp still exists at that point
interp eval a {set delete 1}
# mark that we've been here (successfully)
set res $args;
}
safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";
list [interp eval $i exit] $res
} {{} {arg1 arg2 a}}
test safe-9.2 {safe interps' error in deleteHook} {
set i "a";
catch {safe::interpDelete $i}
set res {}
proc testDelHook {args} {
global res;
# the interp still exists at that point
interp eval a {set delete 1}
# mark that we've been here (successfully)
set res $args;
# create an exception
error "being catched";
}
set log {};
proc safe-test-log {str} {global log; lappend log $str}
safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";
set prevlog [safe::setLogCmd];
safe::setLogCmd safe-test-log;
list [safe::interpDelete $i] $res \
$log \
[safe::setLogCmd $prevlog; unset log];
} {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}} {}}
test safe-9.3 {dual specification of statics} {
list [catch {safe::interpCreate -stat true -nostat} msg] $msg
} {1 {conflicting values given for -statics and -noStatics}}
test safe-9.4 {dual specification of statics} {
# no error shall occur
safe::interpDelete [safe::interpCreate -stat false -nostat]
} {}
test safe-9.5 {dual specification of nested} {
list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg
} {1 {conflicting values given for -nested and -nestedLoadOk}}
test safe-9.6 {interpConfigure widget like behaviour} {
# this test shall work, don't try to "fix it" unless
# you *really* know what you are doing (ie you are me :p) -- dl
list [set i [safe::interpCreate \
-noStatics \
-nestedLoadOk \
-deleteHook {foo bar}];
safe::interpConfigure $i -accessPath /foo/bar ;
safe::interpConfigure $i]\
[safe::interpConfigure $i -aCCess]\
[safe::interpConfigure $i -nested]\
[safe::interpConfigure $i -statics]\
[safe::interpConfigure $i -DEL]\
[safe::interpConfigure $i -accessPath /blah -statics 1;
safe::interpConfigure $i]\
[safe::interpConfigure $i -deleteHook toto -nosta -nested 0;
safe::interpConfigure $i]
} {{-accessPath /foo/bar -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath /foo/bar} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath /blah -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath /blah -statics 0 -nested 0 -deleteHook toto}}
# testing that nested and statics do what is advertised
# (we use a static package : Tcltest)
if {[catch {package require Tcltest} msg]} {
puts "This application hasn't been compiled with Tcltest"
puts "skipping remining safe test that relies on it."
} else {
# we use the Tcltest package , which has no Safe_Init
test safe-10.1 {testing statics loading} {
set i [safe::interpCreate]
list \
[catch {interp eval $i {load {} Tcltest}} msg] \
$msg \
[safe::interpDelete $i];
} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}
test safe-10.2 {testing statics loading / -nostatics} {
set i [safe::interpCreate -nostatics]
list \
[catch {interp eval $i {load {} Tcltest}} msg] \
$msg \
[safe::interpDelete $i];
} {1 {permission denied (static package)} {}}
test safe-10.3 {testing nested statics loading / no nested by default} {
set i [safe::interpCreate]
list \
[catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
$msg \
[safe::interpDelete $i];
} {1 {permission denied (nested load)} {}}
test safe-10.4 {testing nested statics loading / -nestedloadok} {
set i [safe::interpCreate -nestedloadok]
list \
[catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
$msg \
[safe::interpDelete $i];
} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}
}
test safe-11.1 {testing safe encoding} {
set i [safe::interpCreate]
list \
[catch {interp eval $i encoding} msg] \
$msg \
[safe::interpDelete $i];
} {1 {wrong # args: should be "encoding option ?arg ...?"} {}}
test safe-11.2 {testing safe encoding} {
set i [safe::interpCreate]
list \
[catch {interp eval $i encoding system cp775} msg] \
$msg \
[safe::interpDelete $i];
} {1 {wrong # args: should be "encoding system"} {}}
test safe-11.3 {testing safe encoding} {
set i [safe::interpCreate]
set result [catch {
string match [encoding system] [interp eval $i encoding system]
} msg]
list $result $msg [safe::interpDelete $i]
} {0 1 {}}
test safe-11.4 {testing safe encoding} {
set i [safe::interpCreate]
set result [catch {
string match [encoding names] [interp eval $i encoding names]
} msg]
list $result $msg [safe::interpDelete $i]
} {0 1 {}}
test safe-11.5 {testing safe encoding} {
set i [safe::interpCreate]
list \
[catch {interp eval $i encoding convertfrom cp1258 foobar} msg] \
$msg \
[safe::interpDelete $i];
} {0 foobar {}}
test safe-11.6 {testing safe encoding} {
set i [safe::interpCreate]
list \
[catch {interp eval $i encoding convertto cp1258 foobar} msg] \
$msg \
[safe::interpDelete $i];
} {0 foobar {}}
test safe-11.7 {testing safe encoding} {
set i [safe::interpCreate]
list \
[catch {interp eval $i encoding convertfrom} msg] \
$msg \
[safe::interpDelete $i];
} {1 {wrong # args: should be "encoding convertfrom ?encoding? data"} {}}
test safe-11.8 {testing safe encoding} {
set i [safe::interpCreate]
list \
[catch {interp eval $i encoding convertto} msg] \
$msg \
[safe::interpDelete $i];
} {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}}
set ::auto_path $saveAutoPath
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/history.test 0000644 0036047 0045461 00000015331 11737050674 014466 0 ustar dgp 771div # Commands covered: history
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {[catch {history}]} {
puts stdout "This version of Tcl was built without the history command;\n"
puts stdout "history tests will be skipped.\n"
::tcltest::cleanupTests
return
}
set num [history nextid]
history keep 3
history add {set a 12345}
history add {set b [format {A test %s} string]}
history add {Another test}
# "history event"
test history-1.1 {event option} {history event -1} \
{set b [format {A test %s} string]}
test history-1.2 {event option} {history event $num} \
{set a 12345}
test history-1.3 {event option} {history event [expr $num+2]} \
{Another test}
test history-1.4 {event option} {history event set} \
{set b [format {A test %s} string]}
test history-1.5 {event option} {history e "* a*"} \
{set a 12345}
test history-1.6 {event option} {catch {history event *gorp} msg} 1
test history-1.7 {event option} {
catch {history event *gorp} msg
set msg
} {no event matches "*gorp"}
test history-1.8 {event option} {history event} \
{set b [format {A test %s} string]}
test history-1.9 {event option} {catch {history event 123 456} msg} 1
test history-1.10 {event option} {
catch {history event 123 456} msg
set msg
} {wrong # args: should be "history event ?event?"}
# "history redo"
set a 0
history redo -2
test history-2.1 {redo option} {set a} 12345
set b 0
history redo
test history-2.2 {redo option} {set b} {A test string}
test history-2.3 {redo option} {catch {history redo -3 -4}} 1
test history-2.4 {redo option} {
catch {history redo -3 -4} msg
set msg
} {wrong # args: should be "history redo ?event?"}
# "history add"
history add "set a 444" exec
test history-3.1 {add option} {set a} 444
test history-3.2 {add option} {catch {history add "set a 444" execGorp}} 1
test history-3.3 {add option} {
catch {history add "set a 444" execGorp} msg
set msg
} {bad argument "execGorp": should be "exec"}
test history-3.4 {add option} {catch {history add "set a 444" a} msg} 1
test history-3.5 {add option} {
catch {history add "set a 444" a} msg
set msg
} {bad argument "a": should be "exec"}
history add "set a 555" e
test history-3.6 {add option} {set a} 555
history add "set a 666"
test history-3.7 {add option} {set a} 555
test history-3.8 {add option} {catch {history add "set a 666" e f} msg} 1
test history-3.9 {add option} {
catch {history add "set a 666" e f} msg
set msg
} {wrong # args: should be "history add event ?exec?"}
# "history change"
history change "A test value"
test history-4.1 {change option} {history event [expr {[history n]-1}]} \
"A test value"
history ch "Another test" -1
test history-4.2 {change option} {history e} "Another test"
test history-4.3 {change option} {history event [expr {[history n]-1}]} \
"A test value"
test history-4.4 {change option} {catch {history change Foo 4 10}} 1
test history-4.5 {change option} {
catch {history change Foo 4 10} msg
set msg
} {wrong # args: should be "history change newValue ?event?"}
test history-4.6 {change option} {
catch {history change Foo [expr {[history n]-4}]}
} 1
set num [expr {[history n]-4}]
test history-4.7 {change option} {
catch {history change Foo $num} msg
set msg
} "event \"$num\" is too far in the past"
# "history info"
set num [history n]
history add set\ a\ {b\nc\ d\ e}
history add {set b 1234}
history add set\ c\ {a\nb\nc}
test history-5.1 {info option} {history info} [format {%6d set a {b
c d e}
%6d set b 1234
%6d set c {a
b
c}} $num [expr $num+1] [expr $num+2]]
test history-5.2 {info option} {history i 2} [format {%6d set b 1234
%6d set c {a
b
c}} [expr $num+1] [expr $num+2]]
test history-5.3 {info option} {catch {history i 2 3}} 1
test history-5.4 {info option} {
catch {history i 2 3} msg
set msg
} {wrong # args: should be "history info ?count?"}
test history-5.5 {info option} {history} [format {%6d set a {b
c d e}
%6d set b 1234
%6d set c {a
b
c}} $num [expr $num+1] [expr $num+2]]
# "history keep"
history add "foo1"
history add "foo2"
history add "foo3"
history keep 2
test history-6.1 {keep option} {history event [expr [history n]-1]} foo3
test history-6.2 {keep option} {history event -1} foo2
test history-6.3 {keep option} {catch {history event -3}} 1
test history-6.4 {keep option} {
catch {history event -3} msg
set msg
} {event "-3" is too far in the past}
history k 5
test history-6.5 {keep option} {history event -1} foo2
test history-6.6 {keep option} {history event -2} {}
test history-6.7 {keep option} {history event -3} {}
test history-6.8 {keep option} {history event -4} {}
test history-6.9 {keep option} {catch {history event -5}} 1
test history-6.10 {keep option} {catch {history keep 4 6}} 1
test history-6.11 {keep option} {
catch {history keep 4 6} msg
set msg
} {wrong # args: should be "history keep ?count?"}
test history-6.12 {keep option} {catch {history keep}} 0
test history-6.13 {keep option} {
history keep
} {5}
test history-6.14 {keep option} {catch {history keep -3}} 1
test history-6.15 {keep option} {
catch {history keep -3} msg
set msg
} {illegal keep count "-3"}
test history-6.16 {keep option} {
catch {history keep butter} msg
set msg
} {illegal keep count "butter"}
# "history nextid"
set num [history n]
history add "Testing"
history add "Testing2"
test history-7.1 {nextid option} {history event} "Testing"
test history-7.2 {nextid option} {history next} [expr $num+2]
test history-7.3 {nextid option} {catch {history nextid garbage}} 1
test history-7.4 {nextid option} {
catch {history nextid garbage} msg
set msg
} {wrong # args: should be "history nextid"}
# "history clear"
set num [history n]
history add "Testing"
history add "Testing2"
test history-8.1 {clear option} {catch {history clear junk}} 1
test history-8.2 {clear option} {history clear} {}
history add "Testing"
test history-8.3 {clear option} {history} { 1 Testing}
# miscellaneous
test history-9.1 {miscellaneous} {catch {history gorp} msg} 1
test history-9.2 {miscellaneous} {
catch {history gorp} msg
set msg
} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/format.test 0000644 0036047 0045461 00000046210 11737050674 014255 0 ustar dgp 771div # Commands covered: format
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 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.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
# fail. Someday I hope this code shouldn't be necessary (code added
# 9/9/91).
set ::tcltest::testConstraints(roundOffBug) \
[expr {"[format %7.1e 68.514]" != "6.8e+01"}]
test format-1.1 {integer formatting} {
format "%*d %d %d %d" 6 34 16923 -12 -1
} { 34 16923 -12 -1}
test format-1.2 {integer formatting} {nonPortable} {
format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
} { 6 34 16923 -12 -1 0xe 0XC}
# %u output depends on word length, so this test is not portable.
test format-1.3 {integer formatting} {nonPortable} {
format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} { 6 34 16923 4294967284 -1 0}
test format-1.4 {integer formatting} {
format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1
} {6 34 16923 -12 }
test format-1.5 {integer formatting} {
format "%04d %04d %04d %04i" 6 34 16923 -12 -1
} {0006 0034 16923 -012}
test format-1.6 {integer formatting} {
format "%00*d" 6 34
} {000034}
# Printing negative numbers in hex or octal format depends on word
# length, so these tests are not portable.
test format-1.7 {integer formatting} {nonPortable} {
format "%4x %4x %4x %4x" 6 34 16923 -12 -1
} { 6 22 421b fffffff4}
test format-1.8 {integer formatting} {nonPortable} {
format "%#x %#X %#X %#x" 6 34 16923 -12 -1
} {0x6 0X22 0X421B 0xfffffff4}
test format-1.9 {integer formatting} {nonPortable} {
format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1
} { 0x6 0x22 0x421b 0xfffffff4}
test format-1.10 {integer formatting} {nonPortable} {
format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1
} {0x6 0x22 0x421b 0xfffffff4 }
test format-1.11 {integer formatting} {nonPortable} {
format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
} {06 042 041033 037777777764 }
test format-2.1 {string formatting} {
format "%s %s %c %s" abcd {This is a very long test string.} 120 x
} {abcd This is a very long test string. x x}
test format-2.2 {string formatting} {
format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x
} { abcd This is a very long test string. x x}
test format-2.3 {string formatting} {
format "%.10s %.10s %c %.10s" abcd {This is a very long test string.} 120 x
} {abcd This is a x x}
test format-2.4 {string formatting} {
format "%s %s %% %c %s" abcd {This is a very long test string.} 120 x
} {abcd This is a very long test string. % x x}
test format-2.5 {string formatting, embedded nulls} {
format "%10s" abc\0def
} " abc\0def"
test format-2.6 {string formatting, international chars} {
format "%10s" abc\ufeffdef
} " abc\ufeffdef"
test format-2.7 {string formatting, international chars} {
format "%.5s" abc\ufeffdef
} "abc\ufeffd"
test format-2.8 {string formatting, international chars} {
format "foo\ufeffbar%s" baz
} "foo\ufeffbarbaz"
test format-2.9 {string formatting, width} {
format "a%5sa" f
} "a fa"
test format-2.10 {string formatting, width} {
format "a%-5sa" f
} "af a"
test format-2.11 {string formatting, width} {
format "a%2sa" foo
} "afooa"
test format-2.12 {string formatting, width} {
format "a%0sa" foo
} "afooa"
test format-2.13 {string formatting, precision} {
format "a%.2sa" foobarbaz
} "afoa"
test format-2.14 {string formatting, precision} {
format "a%.sa" foobarbaz
} "aa"
test format-2.15 {string formatting, precision} {
list [catch {format "a%.-2sa" foobarbaz} msg] $msg
} {1 {bad field specifier "-"}}
test format-2.16 {string formatting, width and precision} {
format "a%5.2sa" foobarbaz
} "a foa"
test format-2.17 {string formatting, width and precision} {
format "a%5.7sa" foobarbaz
} "afoobarba"
test format-3.1 {Tcl_FormatObjCmd: character formatting} {
format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 65 65 65 65 65 65 3 65 -4 65
} "|A|A|A|A|A | A| A|A |"
test format-3.2 {Tcl_FormatObjCmd: international character formatting} {
format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xa2 0x4e4e 0x25a 0xc3 0xff08 0 3 0x6575 -4 0x4e4f
} "|\ua2|\u4e4e|\u25a|\uc3|\uff08 | \0| \u6575|\u4e4f |"
test format-4.1 {e and f formats} {eformat} {
format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053
} {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04}
test format-4.2 {e and f formats} {eformat} {
format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053
} { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04}
test format-4.3 {e and f formats} {eformat roundOffBug} {
format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053
} {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
test format-4.4 {e and f formats} {eformat roundOffBug} {
format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053
} {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04}
test format-4.5 {e and f formats} {eformat roundOffBug} {
format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053
} {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
test format-4.6 {e and f formats roundOffBug} {
format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053
} {34200000000000.000000 68.514000 -0.125000 -16000.000000}
test format-4.7 {e and f formats} {nonPortable} {
format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053
} {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001}
test format-4.8 {e and f formats} {eformat} {
format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996
} {-1.0000e+01 -9.99996e+00 9.999960e+00}
test format-4.9 {e and f formats} {
format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996
} {-10.0000 -9.99996 9.999960}
test format-4.10 {e and f formats} {
format "%20f %-20f %020f" -9.99996 -9.99996 9.99996
} { -9.999960 -9.999960 0000000000009.999960}
test format-4.11 {e and f formats} {
format "%-020f %020f" -9.99996 -9.99996 9.99996
} {-9.999960 -000000000009.999960}
test format-4.12 {e and f formats} {eformat} {
format "%.0e %#.0e" -9.99996 -9.99996 9.99996
} {-1e+01 -1.e+01}
test format-4.13 {e and f formats} {
format "%.0f %#.0f" -9.99996 -9.99996 9.99996
} {-10 -10.}
test format-4.14 {e and f formats} {
format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996
} {-10.0000 -9.99996 9.999960}
test format-4.15 {e and f formats} {
format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001
} { 1 1 1 1}
test format-4.16 {e and f formats} {
format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001
} {0.0 0.1 0.0 0.0}
test format-5.1 {g-format} {eformat} {
format "%.3g" 12341.0
} {1.23e+04}
test format-5.2 {g-format} {eformat} {
format "%.3G" 1234.12345
} {1.23E+03}
test format-5.3 {g-format} {
format "%.3g" 123.412345
} {123}
test format-5.4 {g-format} {
format "%.3g" 12.3412345
} {12.3}
test format-5.5 {g-format} {
format "%.3g" 1.23412345
} {1.23}
test format-5.6 {g-format} {
format "%.3g" 1.23412345
} {1.23}
test format-5.7 {g-format} {
format "%.3g" .123412345
} {0.123}
test format-5.8 {g-format} {
format "%.3g" .012341
} {0.0123}
test format-5.9 {g-format} {
format "%.3g" .0012341
} {0.00123}
test format-5.10 {g-format} {
format "%.3g" .00012341
} {0.000123}
test format-5.11 {g-format} {eformat} {
format "%.3g" .00001234
} {1.23e-05}
test format-5.12 {g-format} {eformat} {
format "%.4g" 9999.6
} {1e+04}
test format-5.13 {g-format} {
format "%.4g" 999.96
} {1000}
test format-5.14 {g-format} {
format "%.3g" 1.0
} {1}
test format-5.15 {g-format} {
format "%.3g" .1
} {0.1}
test format-5.16 {g-format} {
format "%.3g" .01
} {0.01}
test format-5.17 {g-format} {
format "%.3g" .001
} {0.001}
test format-5.18 {g-format} {eformat} {
format "%.3g" .00001
} {1e-05}
test format-5.19 {g-format} {eformat} {
format "%#.3g" 1234.0
} {1.23e+03}
test format-5.20 {g-format} {eformat} {
format "%#.3G" 9999.5
} {1.00E+04}
test format-6.1 {floating-point zeroes} {eformat} {
format "%e %f %g" 0.0 0.0 0.0 0.0
} {0.000000e+00 0.000000 0}
test format-6.2 {floating-point zeroes} {eformat} {
format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0
} {0.0000e+00 0.0000 0}
test format-6.3 {floating-point zeroes} {eformat} {
format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0
} {0.0000e+00 0.0000 0.000}
test format-6.4 {floating-point zeroes} {eformat} {
format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0
} {0e+00 0 0}
test format-6.5 {floating-point zeroes} {eformat} {
format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0
} {0.e+00 0. 0.}
test format-6.6 {floating-point zeroes} {
format "%3.0f %3.0f %3.0f %3.0f" 0.0 0.0 0.0 0.0
} { 0 0 0 0}
test format-6.7 {floating-point zeroes} {
format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001
} { 1 1 1 1}
test format-6.8 {floating-point zeroes} {
format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001
} {0.0 0.1 0.0 0.0}
test format-7.1 {various syntax features} {
format "%*.*f" 12 3 12.345678901
} { 12.346}
test format-7.2 {various syntax features} {
format "%0*.*f" 12 3 12.345678901
} {00000012.346}
test format-7.3 {various syntax features} {
format "\*\t\\n"
} {* \n}
test format-8.1 {error conditions} {
catch format
} 1
test format-8.2 {error conditions} {
catch format msg
set msg
} {wrong # args: should be "format formatString ?arg arg ...?"}
test format-8.3 {error conditions} {
catch {format %*d}
} 1
test format-8.4 {error conditions} {
catch {format %*d} msg
set msg
} {not enough arguments for all format specifiers}
test format-8.5 {error conditions} {
catch {format %*.*f 12}
} 1
test format-8.6 {error conditions} {
catch {format %*.*f 12} msg
set msg
} {not enough arguments for all format specifiers}
test format-8.7 {error conditions} {
catch {format %*.*f 12 3}
} 1
test format-8.8 {error conditions} {
catch {format %*.*f 12 3} msg
set msg
} {not enough arguments for all format specifiers}
test format-8.9 {error conditions} {
list [catch {format %*d x 3} msg] $msg
} {1 {expected integer but got "x"}}
test format-8.10 {error conditions} {
list [catch {format %*.*f 2 xyz 3} msg] $msg
} {1 {expected integer but got "xyz"}}
test format-8.11 {error conditions} {
catch {format %d 2a}
} 1
test format-8.12 {error conditions} {
catch {format %d 2a} msg
set msg
} {expected integer but got "2a"}
test format-8.13 {error conditions} {
catch {format %c 2x}
} 1
test format-8.14 {error conditions} {
catch {format %c 2x} msg
set msg
} {expected integer but got "2x"}
test format-8.15 {error conditions} {
catch {format %f 2.1z}
} 1
test format-8.16 {error conditions} {
catch {format %f 2.1z} msg
set msg
} {expected floating-point number but got "2.1z"}
test format-8.17 {error conditions} {
catch {format ab%}
} 1
test format-8.18 {error conditions} {
catch {format ab% 12} msg
set msg
} {format string ended in middle of field specifier}
test format-8.19 {error conditions} {
catch {format %q x}
} 1
test format-8.20 {error conditions} {
catch {format %q x} msg
set msg
} {bad field specifier "q"}
test format-8.21 {error conditions} {
catch {format %d}
} 1
test format-8.22 {error conditions} {
catch {format %d} msg
set msg
} {not enough arguments for all format specifiers}
test format-8.23 {error conditions} {
catch {format "%d %d" 24 xyz} msg
set msg
} {expected integer but got "xyz"}
test format-9.1 {long result} {
set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s} $a $a
} {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
test format-10.1 {"h" format specifier} {nonPortable} {
format %hd 0xffff
} -1
test format-10.2 {"h" format specifier} {nonPortable} {
format %hx 0x10fff
} fff
test format-10.3 {"h" format specifier} {nonPortable} {
format %hd 0x10000
} 0
test format-10.4 {"h" format specifier} {
# Bug 1154163: This is minimal behaviour for %hx specifier!
format %hx 1
} 1
test format-10.5 {"h" format specifier} {
# Bug 1284178: Highly out-of-range values shouldn't cause errors
format %hu 0x100000000
} 0
test format-11.1 {XPG3 %$n specifiers} {
format {%2$d %1$d} 4 5
} {5 4}
test format-11.2 {XPG3 %$n specifiers} {
format {%2$d %1$d %1$d %3$d} 4 5 6
} {5 4 4 6}
test format-11.3 {XPG3 %$n specifiers} {
list [catch {format {%2$d %3$d} 4 5} msg] $msg
} {1 {"%n$" argument index out of range}}
test format-11.4 {XPG3 %$n specifiers} {
list [catch {format {%2$d %0$d} 4 5 6} msg] $msg
} {1 {"%n$" argument index out of range}}
test format-11.5 {XPG3 %$n specifiers} {
list [catch {format {%d %1$d} 4 5 6} msg] $msg
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
test format-11.6 {XPG3 %$n specifiers} {
list [catch {format {%2$d %d} 4 5 6} msg] $msg
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
test format-11.7 {XPG3 %$n specifiers} {
list [catch {format {%2$d %3d} 4 5 6} msg] $msg
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
test format-11.8 {XPG3 %$n specifiers} {
format {%2$*d %3$d} 1 10 4
} { 4 4}
test format-11.9 {XPG3 %$n specifiers} {
format {%2$.*s %4$d} 1 5 abcdefghijklmnop 44
} {abcde 44}
test format-11.10 {XPG3 %$n specifiers} {
list [catch {format {%2$*d} 4} msg] $msg
} {1 {"%n$" argument index out of range}}
test format-11.11 {XPG3 %$n specifiers} {
list [catch {format {%2$*d} 4 5} msg] $msg
} {1 {"%n$" argument index out of range}}
test format-11.12 {XPG3 %$n specifiers} {
list [catch {format {%2$*d} 4 5 6} msg] $msg
} {0 { 6}}
test format-12.1 {negative width specifiers} {
format "%*d" -47 25
} {25 }
test format-13.1 {tcl_precision fuzzy comparison} {
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
set a 0.0000000000001
set b 0.00000000000001
set c 0.00000000000000001
set d [expr $a + $b + $c]
format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d
} {0.0000000000 0.000000000000 0.000000000000110 0.00000000000011001}
test format-13.2 {tcl_precision fuzzy comparison} {
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
set a 0.000000000001
set b 0.000000000000005
set c 0.0000000000000008
set d [expr $a + $b + $c]
format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d
} {0.0000000000 0.000000000001 0.000000000001006 0.00000000000100580}
test format-13.3 {tcl_precision fuzzy comparison} {
catch {unset a}
catch {unset b}
catch {unset c}
set a 0.00000000000099
set b 0.000000000000011
set c [expr $a + $b]
format {%0.10f %0.12f %0.15f %0.17f} $c $c $c $c
} {0.0000000000 0.000000000001 0.000000000001001 0.00000000000100100}
test format-13.4 {tcl_precision fuzzy comparison} {
catch {unset a}
catch {unset b}
catch {unset c}
set a 0.444444444444
set b 0.33333333333333
set c [expr $a + $b]
format {%0.10f %0.12f %0.15f %0.16f} $c $c $c $c
} {0.7777777778 0.777777777777 0.777777777777330 0.7777777777773300}
test format-13.5 {tcl_precision fuzzy comparison} {
catch {unset a}
catch {unset b}
catch {unset c}
set a 0.444444444444
set b 0.99999999999999
set c [expr $a + $b]
format {%0.10f %0.12f %0.15f} $c $c $c
} {1.4444444444 1.444444444444 1.444444444443990}
test format-14.1 {testing MAX_FLOAT_SIZE for 0 and 1} {
format {%s} ""
} {}
test format-14.2 {testing MAX_FLOAT_SIZE for 0 and 1} {
format {%s} "a"
} {a}
test format-15.1 {testing %0..s 0 padding for chars/strings} {
format %05s a
} {0000a}
test format-15.2 {testing %0..s 0 padding for chars/strings} {
format "% 5s" a
} { a}
test format-15.3 {testing %0..s 0 padding for chars/strings} {
format %5s a
} { a}
test format-15.4 {testing %0..s 0 padding for chars/strings} {
format %05c 61
} {0000=}
set a "0123456789"
set b ""
for {set i 0} {$i < 290} {incr i} {
append b $a
}
for {set i 290} {$i < 400} {incr i} {
test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
format {%s} $b
} $b
append b "x"
}
::tcltest::testConstraint 64bitInts \
[expr {0x80000000 > 0}]
::tcltest::testConstraint wideIntExpressions \
[expr {wide(0x80000000) != int(0x80000000)}]
test format-17.1 {testing %d with wide} {64bitInts wideIntExpressions} {
format %d 7810179016327718216
} 1819043144
test format-17.2 {testing %ld with wide} {64bitInts} {
format %ld 7810179016327718216
} 7810179016327718216
test format-17.3 {testing %ld with non-wide} {64bitInts} {
format %ld 42
} 42
test format-17.4 {testing %l with non-integer} {
format %lf 1
} 1.000000
test format-17.5 {type conversions with wides} {
set a 0xAAAAAAAA ;# NB: Careful to make separate objects here!
set b 0xAAAAAAA; append b A
set result [expr {$a == $b}]
format %x $a
lappend result [expr {$a == $b}]
} {1 1}
test format-18.1 {do not demote existing numeric values} {
set a 0xaaaaaaaa
# Ensure $a and $b are separate objects
set b 0xaaaa
append b aaaa
set result [expr {$a == $b}]
format %08lx $b
lappend result [expr {$a == $b}]
set b 0xaaaa
append b aaaa
lappend result [expr {$a == $b}]
format %08x $b
lappend result [expr {$a == $b}]
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideIntExpressions} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
test format-19.1 {
regression test - tcl-core message by Brian Griffin on
26 0ctober 2004
} -body {
set x 0x8fedc654
list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}
# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
::tcltest::cleanupTests
return
tcl8.4.20/tests/compile.test 0000644 0036047 0045461 00000033600 11737050674 014414 0 ustar dgp 771div # This file contains tests for the files tclCompile.c, tclCompCmds.c
# and tclLiteral.c
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
namespace import -force ::tcltest::*
# The following tests are very incomplete, although the rest of the
# test suite covers this file fairly well.
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} {
catch {namespace delete test_ns_compile}
catch {unset x}
set x 123
namespace eval test_ns_compile {
proc set {args} {
global x
lappend x test_ns_compile::set
}
proc p {} {
set 0
}
}
list [test_ns_compile::p] [set x]
} {{123 test_ns_compile::set} {123 test_ns_compile::set}}
test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} {
proc p {x} {info commands 3m}
list [catch {p} msg] $msg
} {1 {wrong # args: should be "p x"}}
test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} {
catch {unset x}
set x 123
list $::x [expr {[lsearch -exact [info globals] x] != 0}]
} {123 1}
test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} {
catch {unset y}
proc p {} {
set ::y 789
return $::y
}
list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}]
} {789 789 1}
test compile-2.3 {TclCompileDollarVar: global array name with ::s} {
catch {unset a}
set ::a(1) 2
list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {[lsearch -exact [info globals] a] != 0}]
} {2 3 3 1}
test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} {
catch {unset a}
proc p {} {
set ::a(1) 1
return $::a($::a(1))
}
list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {1 1 1}
test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} {
catch {unset a}
proc p {} {
global a
set a(1) 1
return ${a(1)}$::a(1)$a(1)
}
list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {111 1 1}
test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} {
catch {unset a}
set a(1) xyzzyx
proc p {} {
global a
catch {set x 123} a(1)
}
list [p] $a(1)
} {0 123}
test compile-3.2 {TclCompileCatchCmd: non-local variables} {
set ::foo 1
proc catch-test {} {
catch {set x 3} ::foo
}
catch-test
set ::foo
} 3
test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} {
proc catch-test {str} {
catch [eval $str GOOD]
error BAD
}
catch {catch-test error} ::foo
set ::foo
} {GOOD}
test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} {
proc foo {} {
set fail [catch {
return 1
}] ; # {}
return 2
}
foo
} {2}
test compile-3.5 {TclCompileCatchCmd: recover from error, [Bug 705406]} {
proc foo {} {
catch {
if {[a]} {
if b {}
}
}
}
list [catch foo msg] $msg
} {0 1}
test compile-4.1 {TclCompileForCmd: command substituted test expression} {
set i 0
set j 0
# Should be "forever"
for {} [expr $i < 3] {} {
set j [incr i]
if {$j > 3} break
}
set j
} {4}
test compile-5.1 {TclCompileForeachCmd: exception stack} {
proc foreach-exception-test {} {
foreach array(index) [list 1 2 3] break
foreach array(index) [list 1 2 3] break
foreach scalar [list 1 2 3] break
}
list [catch foreach-exception-test result] $result
} {0 {}}
test compile-5.2 {TclCompileForeachCmd: non-local variables} {
set ::foo 1
proc foreach-test {} {
foreach ::foo {1 2 3} {}
}
foreach-test
set ::foo
} 3
test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} {
catch {unset x}
catch {unset y}
set x 123
proc p {} {
set ::y 789
return $::y
}
list $::x [expr {[lsearch -exact [info globals] x] != 0}] \
[p] $::y [expr {[lsearch -exact [info globals] y] != 0}]
} {123 1 789 789 1}
test compile-6.2 {TclCompileSetCmd: global array names with ::s} {
catch {unset a}
set ::a(1) 2
proc p {} {
set ::a(1) 1
return $::a($::a(1))
}
list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {2 1 3 3 1}
test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} {
catch {namespace delete test_ns_compile}
catch {unset x}
namespace eval test_ns_compile {
variable v hello
variable arr
set ::x $::test_ns_compile::v
set ::test_ns_compile::arr(1) 123
}
list $::x $::test_ns_compile::arr(1)
} {hello 123}
test compile-7.1 {TclCompileWhileCmd: command substituted test expression} {
set i 0
set j 0
# Should be "forever"
while [expr $i < 3] {
set j [incr i]
if {$j > 3} break
}
set j
} {4}
test compile-8.1 {CollectArgInfo: binary data} {
list [catch "string length \000foo" msg] $msg
} {0 4}
test compile-8.2 {CollectArgInfo: binary data} {
list [catch "string length foo\000" msg] $msg
} {0 4}
test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} {
set x ]
} {]}
test compile-9.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} {
proc p {} {
set x {}
eval $x
append x { }
eval $x
}
p
} {}
test compile-10.1 {BLACKBOX: exception stack overflow} {
set x {{0}}
set y 0
while {$y < 100} {
if !$x {incr y}
}
} {}
test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
proc p {} {
# shared object - Interp result && Var 'r'
set r [list foobar]
# command that will add error to result
lindex a bogus
}
list [catch {p} msg] $msg
} {1 {bad index "bogus": must be integer or end?-integer?}}
test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
proc p {} { set r [list foobar] ; string index a bogus }
list [catch {p} msg] $msg
} {1 {bad index "bogus": must be integer or end?-integer?}}
test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
proc p {} { set r [list foobar] ; string index a 09 }
list [catch {p} msg] $msg
} {1 {bad index "09": must be integer or end?-integer? (looks like invalid octal number)}}
test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
proc p {} { set r [list foobar] ; array set var {one two many} }
list [catch {p} msg] $msg
} {1 {list must have an even number of elements}}
test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
proc p {} { set r [list foobar] ; incr foo }
list [catch {p} msg] $msg
} {1 {can't read "foo": no such variable}}
test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
proc p {} { set r [list foobar] ; incr foo bogus }
list [catch {p} msg] $msg
} {1 {expected integer but got "bogus"}}
test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
proc p {} { set r [list foobar] ; expr !a }
list [catch {p} msg] $msg
} {1 {syntax error in expression "!a": variable references require preceding $}}
test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
proc p {} { set r [list foobar] ; expr {!a} }
list [catch {p} msg] $msg
} {1 {syntax error in expression "!a": variable references require preceding $}}
test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
proc p {} { set r [list foobar] ; llength "\{" }
list [catch {p} msg] $msg
} {1 {unmatched open brace in list}}
#
# Special section for tests of tclLiteral.c
# The following tests check for incorrect memory handling in
# TclReleaseLiteral. They are only effective when tcl is compiled
# with TCL_MEM_DEBUG
#
# Special test for leak on interp delete [Bug 467523].
::tcltest::testConstraint exec [llength [info commands exec]]
::tcltest::testConstraint memDebug [llength [info commands memory]]
test compile-12.1 {testing literal leak on interp delete} {memDebug} {
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex [lindex $lines 3] 3
}
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
interp create foo
foo eval {
namespace eval bar {}
}
interp delete foo
set tmp $end
set end [getbytes]
}
rename getbytes {}
set leak [expr {$end - $tmp}]
} 0
# Special test for a memory error in a preliminary fix of [Bug 467523].
# It requires executing a helpfile. Presumably the child process is
# used because when this test fails, it crashes.
test compile-12.2 {testing error on literal deletion} {memDebug exec} {
makeFile {
for {set i 0} {$i < 5} {incr i} {
namespace eval bar {}
namespace delete bar
}
puts 0
} source.file
set res [catch {
exec [interpreter] source.file
}]
catch {removeFile source.file}
set res
} 0
# Test to catch buffer overrun in TclCompileTokens from buf 530320
test compile-12.3 {check for a buffer overrun} {
proc crash {} {
puts $array([expr {a+2}])
}
list [catch crash msg] $msg
} {1 {syntax error in expression "a+2": variable references require preceding $}}
test compile-12.4 {TclCleanupLiteralTable segfault} {
# Tcl Bug 1001997
# Here, we're trying to test a case that causes a crash in
# TclCleanupLiteralTable. The conditions that we're trying to
# establish are:
# - TclCleanupLiteralTable is attempting to clean up a bytecode
# object in the literal table.
# - The bytecode object in question contains the only reference
# to another literal.
# - The literal in question is in the same hash bucket as the bytecode
# object, and immediately follows it in the chain.
# Since newly registered literals are added at the FRONT of the
# bucket chains, and since the bytecode object is registered before
# its literals, this is difficult to achieve. What we do is:
# (a) do a [namespace eval] of a string that's calculated to
# hash into the same bucket as a literal that it contains.
# In this case, the script and the variable 'bugbug'
# land in the same bucket.
# (b) do a [namespace eval] of a string that contains enough
# literals to force TclRegisterLiteral to rebuild the global
# literal table. The newly created hash buckets will contain
# the literals, IN REVERSE ORDER, thus putting the bytecode
# immediately ahead of 'bugbug' and 'bug4345bug'. The bytecode
# object will contain the only references to those two literals.
# (c) Delete the interpreter to invoke TclCleanupLiteralTable
# and tickle the bug.
proc foo {} {
set i [interp create]
$i eval {
namespace eval ::w {concat 4649; variable bugbug}
namespace eval ::w {
concat x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 \
x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 \
x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 \
x31 x32 X33 X34 X35 X36 X37 X38 X39 X40 \
x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 \
x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 \
x61 x62 x63 x64
concat y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 \
y11 y12 y13 y14 y15 y16 y17 y18 y19 y20 \
y21 y22 y23 y24 y25 y26 y27 y28 y29 y30 \
y31 y32 Y33 Y34 Y35 Y36 Y37 Y38 Y39 Y40 \
y41 y42 y43 y44 y45 y46 y47 y48 y49 y50 \
y51 y52 y53 y54 y55 y56 y57 y58 y59 y60 \
y61 y62 y63 y64
concat z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 \
z11 z12 z13 z14 z15 z16 z17 z18 z19 z20 \
z21 z22 z23 z24 z25 z26 z27 z28 z29 z30 \
z31 z32
}
}
interp delete $i; # must not crash
return ok
}
foo
} ok
# Special test for underestimating the maxStackSize required for a
# compiled command. A failure will cause a segfault in the child
# process.
test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
set body {set x [list}
for {set i 0} {$i < 3000} {incr i} {
append body " $i"
}
append body {]; puts OK}
regsub BODY {proc crash {} {BODY}; crash} $body script
list [catch {exec [interpreter] << $script} msg] $msg
} {0 OK}
# Special test for compiling tokens from a copy of the source
# string [Bug #599788]
test compile-14.1 {testing errors in element name; segfault?} {} {
catch {set a([error])} msg1
catch {set bubba([join $abba $jubba]) $vol} msg2
list $msg1 $msg2
} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}}
# Next 4 tests cover Tcl Bug 633204
test compile-15.1 {proper TCL_RETURN code from [return]} {
proc p {} {catch return}
set result [p]
rename p {}
set result
} 2
test compile-15.2 {proper TCL_RETURN code from [return]} {
proc p {} {catch {return foo}}
set result [p]
rename p {}
set result
} 2
test compile-15.3 {proper TCL_RETURN code from [return]} {
proc p {} {catch {return $::tcl_library}}
set result [p]
rename p {}
set result
} 2
test compile-15.4 {proper TCL_RETURN code from [return]} {
proc p {} {catch {return [info library]}}
set result [p]
rename p {}
set result
} 2
test compile-15.5 {proper TCL_RETURN code from [return]} {
proc p {} {catch {set a 1}; return}
set result [p]
rename p {}
set result
} ""
# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
::tcltest::cleanupTests
return
tcl8.4.20/tests/split.test 0000644 0036047 0045461 00000004567 11737050674 014131 0 ustar dgp 771div # Commands covered: split
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test split-1.1 {basic split commands} {
split "a\n b\t\r c\n "
} {a {} b {} {} c {} {}}
test split-1.2 {basic split commands} {
split "word 1xyzword 2zword 3" xyz
} {{word 1} {} {} {word 2} {word 3}}
test split-1.3 {basic split commands} {
split "12345" {}
} {1 2 3 4 5}
test split-1.4 {basic split commands} {
split "a\}b\[c\{\]\$"
} "a\\}b\\\[c\\{\\\]\\\$"
test split-1.5 {basic split commands} {
split {} {}
} {}
test split-1.6 {basic split commands} {
split {}
} {}
test split-1.7 {basic split commands} {
split { }
} {{} {} {} {}}
test split-1.8 {basic split commands} {
proc foo {} {
set x {}
foreach f [split {]\n} {}] {
append x $f
}
return $x
}
foo
} {]\n}
test split-1.9 {basic split commands} {
proc foo {} {
set x ab\000c
set y [split $x {}]
return $y
}
foo
} "a b \000 c"
test split-1.10 {basic split commands} {
split "a0ab1b2bbb3\000c4" ab\000c
} {{} 0 {} 1 2 {} {} 3 {} 4}
test split-1.11 {basic split commands} {
split "12,3,45" {,}
} {12 3 45}
test split-1.12 {basic split commands} {
split "\u0001ab\u0001cd\u0001\u0001ef\u0001" \1
} {{} ab cd {} ef {}}
test split-1.13 {basic split commands} {
split "12,34,56," {,}
} {12 34 56 {}}
test split-1.14 {basic split commands} {
split ",12,,,34,56," {,}
} {{} 12 {} {} 34 56 {}}
test split-2.1 {split errors} {
list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test split-2.2 {split errors} {
list [catch {split a b c} msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
# cleanup
catch {rename foo {}}
::tcltest::cleanupTests
return
tcl8.4.20/tests/parseExpr.test 0000644 0036047 0045461 00000131433 11737050674 014740 0 ustar dgp 771div # This file contains a collection of tests for the procedures in the
# file tclParseExpr.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Note that the Tcl expression parser (tclParseExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.
if {[info commands testexprparser] == {}} {
puts "This application hasn't been compiled with the \"testexprparser\""
puts "command, so I can't test the Tcl expression parser."
::tcltest::cleanupTests
return
}
# Some tests only work if wide integers (>32bit) are not found to be
# integers at all.
set ::tcltest::testConstraints(wideIntegerUnparsed) \
[expr {-1 == 0xffffffff}]
test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {
testexprparser [bytestring "1+2\0 +3"] -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} {
testexprparser "1 + 2" -1
} {- {} 0 subexpr {1 + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {wideIntegerUnparsed} {
list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} {
list [catch {testexprparser {foo+} -1} msg] $msg
} {1 {syntax error in expression "foo+": variable references require preceding $}}
test parseExpr-1.5 {Tcl_ParseExpr procedure, lexemes after the expression} {
list [catch {testexprparser {1+2 345} -1} msg] $msg
} {1 {syntax error in expression "1+2 345": extra tokens at end of expression}}
test parseExpr-2.1 {ParseCondExpr procedure, valid test subexpr} {
testexprparser {2>3? 1 : 0} -1
} {- {} 0 subexpr {2>3? 1 : 0} 11 operator ? 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} {
list [catch {testexprparser {0 || foo} -1} msg] $msg
} {1 {syntax error in expression "0 || foo": variable references require preceding $}}
test parseExpr-2.3 {ParseCondExpr procedure, next lexeme isn't "?"} {
testexprparser {1+2} -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-2.4 {ParseCondExpr procedure, next lexeme is "?"} {
testexprparser {1+2 ? 3 : 4} -1
} {- {} 0 subexpr {1+2 ? 3 : 4} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {wideIntegerUnparsed} {
list [catch {testexprparser {1+2 ? 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-2.6 {ParseCondExpr procedure, valid "then" subexpression} {
testexprparser {1? 3 : 4} -1
} {- {} 0 subexpr {1? 3 : 4} 7 operator ? 0 subexpr 1 1 text 1 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} {
list [catch {testexprparser {1? fred : martha} -1} msg] $msg
} {1 {syntax error in expression "1? fred : martha": variable references require preceding $}}
test parseExpr-2.8 {ParseCondExpr procedure, lexeme after "then" subexpr isn't ":"} {
list [catch {testexprparser {1? 2 martha 3} -1} msg] $msg
} {1 {syntax error in expression "1? 2 martha 3": missing colon from ternary conditional}}
test parseExpr-2.9 {ParseCondExpr procedure, valid "else" subexpression} {
testexprparser {27||3? 3 : 4&&9} -1
} {- {} 0 subexpr {27||3? 3 : 4&&9} 15 operator ? 0 subexpr 27||3 5 operator || 0 subexpr 27 1 text 27 0 subexpr 3 1 text 3 0 subexpr 3 1 text 3 0 subexpr 4&&9 5 operator && 0 subexpr 4 1 text 4 0 subexpr 9 1 text 9 0 {}}
test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} {
list [catch {testexprparser {1? 2 : martha} -1} msg] $msg
} {1 {syntax error in expression "1? 2 : martha": variable references require preceding $}}
test parseExpr-3.1 {ParseLorExpr procedure, valid logical and subexpr} {
testexprparser {1&&2 || 3} -1
} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} {
list [catch {testexprparser {1&&foo || 3} -1} msg] $msg
} {1 {syntax error in expression "1&&foo || 3": variable references require preceding $}}
test parseExpr-3.3 {ParseLorExpr procedure, next lexeme isn't "||"} {
testexprparser {1&&2? 1 : 0} -1
} {- {} 0 subexpr {1&&2? 1 : 0} 11 operator ? 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-3.4 {ParseLorExpr procedure, next lexeme is "||"} {
testexprparser {1&&2 || 3} -1
} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {wideIntegerUnparsed} {
list [catch {testexprparser {1&&2 || 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-3.6 {ParseLorExpr procedure, valid RHS subexpression} {
testexprparser {1&&2 || 3 || 4} -1
} {- {} 0 subexpr {1&&2 || 3 || 4} 13 operator || 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1&&2 || 3 || martha} -1} msg] $msg
} {1 {syntax error in expression "1&&2 || 3 || martha": variable references require preceding $}}
test parseExpr-4.1 {ParseLandExpr procedure, valid LHS "|" subexpr} {
testexprparser {1|2 && 3} -1
} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} {
list [catch {testexprparser {1&&foo && 3} -1} msg] $msg
} {1 {syntax error in expression "1&&foo && 3": variable references require preceding $}}
test parseExpr-4.3 {ParseLandExpr procedure, next lexeme isn't "&&"} {
testexprparser {1|2? 1 : 0} -1
} {- {} 0 subexpr {1|2? 1 : 0} 11 operator ? 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-4.4 {ParseLandExpr procedure, next lexeme is "&&"} {
testexprparser {1|2 && 3} -1
} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {wideIntegerUnparsed} {
list [catch {testexprparser {1|2 && 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-4.6 {ParseLandExpr procedure, valid RHS subexpression} {
testexprparser {1|2 && 3 && 4} -1
} {- {} 0 subexpr {1|2 && 3 && 4} 13 operator && 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1|2 && 3 && martha} -1} msg] $msg
} {1 {syntax error in expression "1|2 && 3 && martha": variable references require preceding $}}
test parseExpr-5.1 {ParseBitOrExpr procedure, valid LHS "^" subexpr} {
testexprparser {1^2 | 3} -1
} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} {
list [catch {testexprparser {1|foo | 3} -1} msg] $msg
} {1 {syntax error in expression "1|foo | 3": variable references require preceding $}}
test parseExpr-5.3 {ParseBitOrExpr procedure, next lexeme isn't "|"} {
testexprparser {1^2? 1 : 0} -1
} {- {} 0 subexpr {1^2? 1 : 0} 11 operator ? 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-5.4 {ParseBitOrExpr procedure, next lexeme is "|"} {
testexprparser {1^2 | 3} -1
} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {wideIntegerUnparsed} {
list [catch {testexprparser {1^2 | 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-5.6 {ParseBitOrExpr procedure, valid RHS subexpression} {
testexprparser {1^2 | 3 | 4} -1
} {- {} 0 subexpr {1^2 | 3 | 4} 13 operator | 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1^2 | 3 | martha} -1} msg] $msg
} {1 {syntax error in expression "1^2 | 3 | martha": variable references require preceding $}}
test parseExpr-6.1 {ParseBitXorExpr procedure, valid LHS "&" subexpr} {
testexprparser {1&2 ^ 3} -1
} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} {
list [catch {testexprparser {1^foo ^ 3} -1} msg] $msg
} {1 {syntax error in expression "1^foo ^ 3": variable references require preceding $}}
test parseExpr-6.3 {ParseBitXorExpr procedure, next lexeme isn't "^"} {
testexprparser {1&2? 1 : 0} -1
} {- {} 0 subexpr {1&2? 1 : 0} 11 operator ? 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-6.4 {ParseBitXorExpr procedure, next lexeme is "^"} {
testexprparser {1&2 ^ 3} -1
} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {wideIntegerUnparsed} {
list [catch {testexprparser {1&2 ^ 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-6.6 {ParseBitXorExpr procedure, valid RHS subexpression} {
testexprparser {1&2 ^ 3 ^ 4} -1
} {- {} 0 subexpr {1&2 ^ 3 ^ 4} 13 operator ^ 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1&2 ^ 3 ^ martha} -1} msg] $msg
} {1 {syntax error in expression "1&2 ^ 3 ^ martha": variable references require preceding $}}
test parseExpr-7.1 {ParseBitAndExpr procedure, valid LHS equality subexpr} {
testexprparser {1==2 & 3} -1
} {- {} 0 subexpr {1==2 & 3} 9 operator & 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} {
list [catch {testexprparser {1!=foo & 3} -1} msg] $msg
} {1 {syntax error in expression "1!=foo & 3": variable references require preceding $}}
test parseExpr-7.3 {ParseBitAndExpr procedure, next lexeme isn't "&"} {
testexprparser {1==2? 1 : 0} -1
} {- {} 0 subexpr {1==2? 1 : 0} 11 operator ? 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-7.4 {ParseBitAndExpr procedure, next lexeme is "&"} {
testexprparser {1>2 & 3} -1
} {- {} 0 subexpr {1>2 & 3} 9 operator & 0 subexpr 1>2 5 operator > 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {wideIntegerUnparsed} {
list [catch {testexprparser {1==2 & 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-7.6 {ParseBitAndExpr procedure, valid RHS subexpression} {
testexprparser {1<2 & 3 & 4} -1
} {- {} 0 subexpr {1<2 & 3 & 4} 13 operator & 0 subexpr {1<2 & 3} 9 operator & 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1==2 & 3>2 & martha} -1} msg] $msg
} {1 {syntax error in expression "1==2 & 3>2 & martha": variable references require preceding $}}
test parseExpr-8.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} {
testexprparser {1<2 == 3} -1
} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} {
list [catch {testexprparser {1>=foo == 3} -1} msg] $msg
} {1 {syntax error in expression "1>=foo == 3": variable references require preceding $}}
test parseExpr-8.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} {
testexprparser {1<2? 1 : 0} -1
} {- {} 0 subexpr {1<2? 1 : 0} 11 operator ? 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-8.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} {
testexprparser {1<2 == 3} -1
} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} {
testexprparser {1<2 != 3} -1
} {- {} 0 subexpr {1<2 != 3} 9 operator != 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-8.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {wideIntegerUnparsed} {
list [catch {testexprparser {1<2 == 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-8.7 {ParseEqualityExpr procedure, valid RHS subexpression} {
testexprparser {1<2 == 3 == 4} -1
} {- {} 0 subexpr {1<2 == 3 == 4} 13 operator == 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-8.8 {ParseEqualityExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1<2 == 3 != martha} -1} msg] $msg
} {1 {syntax error in expression "1<2 == 3 != martha": variable references require preceding $}}
test parseExpr-9.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} {
testexprparser {1<<2 < 3} -1
} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} {
list [catch {testexprparser {1>=foo < 3} -1} msg] $msg
} {1 {syntax error in expression "1>=foo < 3": variable references require preceding $}}
test parseExpr-9.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} {
testexprparser {1<<2? 1 : 0} -1
} {- {} 0 subexpr {1<<2? 1 : 0} 11 operator ? 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-9.4 {ParseRelationalExpr procedure, next lexeme is relational op} {
testexprparser {1<<2 < 3} -1
} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.5 {ParseRelationalExpr procedure, next lexeme is relational op} {
testexprparser {1>>2 > 3} -1
} {- {} 0 subexpr {1>>2 > 3} 9 operator > 0 subexpr 1>>2 5 operator >> 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.6 {ParseRelationalExpr procedure, next lexeme is relational op} {
testexprparser {1<<2 <= 3} -1
} {- {} 0 subexpr {1<<2 <= 3} 9 operator <= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.7 {ParseRelationalExpr procedure, next lexeme is relational op} {
testexprparser {1<<2 >= 3} -1
} {- {} 0 subexpr {1<<2 >= 3} 9 operator >= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-9.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {wideIntegerUnparsed} {
list [catch {testexprparser {1<<2 < 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-9.9 {ParseRelationalExpr procedure, valid RHS subexpression} {
testexprparser {1<<2 < 3 < 4} -1
} {- {} 0 subexpr {1<<2 < 3 < 4} 13 operator < 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-9.10 {ParseRelationalExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1<<2 < 3 > martha} -1} msg] $msg
} {1 {syntax error in expression "1<<2 < 3 > martha": variable references require preceding $}}
test parseExpr-10.1 {ParseShiftExpr procedure, valid LHS add subexpr} {
testexprparser {1+2 << 3} -1
} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.2 {ParseShiftExpr procedure, error in LHS add subexpr} {
list [catch {testexprparser {1-foo << 3} -1} msg] $msg
} {1 {syntax error in expression "1-foo << 3": variable references require preceding $}}
test parseExpr-10.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} {
testexprparser {1+2? 1 : 0} -1
} {- {} 0 subexpr {1+2? 1 : 0} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-10.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} {
testexprparser {1+2 << 3} -1
} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} {
testexprparser {1+2 >> 3} -1
} {- {} 0 subexpr {1+2 >> 3} 9 operator >> 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-10.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {wideIntegerUnparsed} {
list [catch {testexprparser {1+2 << 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-10.7 {ParseShiftExpr procedure, valid RHS subexpression} {
testexprparser {1+2 << 3 << 4} -1
} {- {} 0 subexpr {1+2 << 3 << 4} 13 operator << 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-10.8 {ParseShiftExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1+2 << 3 >> martha} -1} msg] $msg
} {1 {syntax error in expression "1+2 << 3 >> martha": variable references require preceding $}}
test parseExpr-11.1 {ParseAddExpr procedure, valid LHS multiply subexpr} {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.2 {ParseAddExpr procedure, error in LHS multiply subexpr} {
list [catch {testexprparser {1/foo + 3} -1} msg] $msg
} {1 {syntax error in expression "1/foo + 3": variable references require preceding $}}
test parseExpr-11.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} {
testexprparser {1*2? 1 : 0} -1
} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-11.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} {
testexprparser {1*2 - 3} -1
} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-11.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {wideIntegerUnparsed} {
list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-11.7 {ParseAddExpr procedure, valid RHS subexpression} {
testexprparser {1*2 + 3 + 4} -1
} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-11.8 {ParseAddExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg
} {1 {syntax error in expression "1*2 + 3 - martha": variable references require preceding $}}
test parseExpr-12.1 {ParseAddExpr procedure, valid LHS multiply subexpr} {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.2 {ParseAddExpr procedure, error in LHS multiply subexpr} {
list [catch {testexprparser {1/foo + 3} -1} msg] $msg
} {1 {syntax error in expression "1/foo + 3": variable references require preceding $}}
test parseExpr-12.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} {
testexprparser {1*2? 1 : 0} -1
} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-12.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} {
testexprparser {1*2 - 3} -1
} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-12.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {wideIntegerUnparsed} {
list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-12.7 {ParseAddExpr procedure, valid RHS subexpression} {
testexprparser {1*2 + 3 + 4} -1
} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-12.8 {ParseAddExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg
} {1 {syntax error in expression "1*2 + 3 - martha": variable references require preceding $}}
test parseExpr-13.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} {
testexprparser {+2 * 3} -1
} {- {} 0 subexpr {+2 * 3} 7 operator * 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {wideIntegerUnparsed} {
list [catch {testexprparser {-12345678901234567890 * 3} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-13.3 {ParseMultiplyExpr procedure, next lexeme isn't "*", "/", or "%"} {
testexprparser {+2? 1 : 0} -1
} {- {} 0 subexpr {+2? 1 : 0} 9 operator ? 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-13.4 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} {
testexprparser {-123 * 3} -1
} {- {} 0 subexpr {-123 * 3} 7 operator * 0 subexpr -123 3 operator - 0 subexpr 123 1 text 123 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.5 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} {
testexprparser {+-456 / 3} -1
} {- {} 0 subexpr {+-456 / 3} 9 operator / 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.6 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} {
testexprparser {+-456 % 3} -1
} {- {} 0 subexpr {+-456 % 3} 9 operator % 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}}
test parseExpr-13.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {wideIntegerUnparsed} {
list [catch {testexprparser {--++5 / 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-13.8 {ParseMultiplyExpr procedure, valid RHS subexpression} {
testexprparser {-2 / 3 % 4} -1
} {- {} 0 subexpr {-2 / 3 % 4} 11 operator % 0 subexpr {-2 / 3} 7 operator / 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-13.9 {ParseMultiplyExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {++2 / 3 * martha} -1} msg] $msg
} {1 {syntax error in expression "++2 / 3 * martha": variable references require preceding $}}
test parseExpr-14.1 {ParseUnaryExpr procedure, first token is unary operator} {
testexprparser {+2} -1
} {- {} 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.2 {ParseUnaryExpr procedure, first token is unary operator} {
testexprparser {-2} -1
} {- {} 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.3 {ParseUnaryExpr procedure, first token is unary operator} {
testexprparser {~2} -1
} {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.4 {ParseUnaryExpr procedure, first token is unary operator} {
testexprparser {!2} -1
} {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {wideIntegerUnparsed} {
list [catch {testexprparser {-12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-14.6 {ParseUnaryExpr procedure, simple unary expr after unary op} {
testexprparser {+"1234"} -1
} {- {} 0 subexpr +\"1234\" 3 operator + 0 subexpr {"1234"} 1 text 1234 0 {}}
test parseExpr-14.7 {ParseUnaryExpr procedure, another unary expr after unary op} {
testexprparser {~!{fred}} -1
} {- {} 0 subexpr ~!{fred} 5 operator ~ 0 subexpr !{fred} 3 operator ! 0 subexpr {{fred}} 1 text fred 0 {}}
test parseExpr-14.8 {ParseUnaryExpr procedure, error in unary expr after unary op} {
list [catch {testexprparser {+-||27} -1} msg] $msg
} {1 {syntax error in expression "+-||27": unexpected operator ||}}
test parseExpr-14.9 {ParseUnaryExpr procedure, error in unary expr after unary op} {
list [catch {testexprparser {+-||27} -1} msg] $msg
} {1 {syntax error in expression "+-||27": unexpected operator ||}}
test parseExpr-14.10 {ParseUnaryExpr procedure, first token is not unary op} {
testexprparser {123} -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-14.11 {ParseUnaryExpr procedure, not unary expr, complex primary expr} {
testexprparser {(1+2)} -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-14.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {wideIntegerUnparsed} {
list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.1 {ParsePrimaryExpr procedure, just parenthesized subexpr} {
testexprparser {({abc}/{def})} -1
} {- {} 0 subexpr {{abc}/{def}} 5 operator / 0 subexpr {{abc}} 1 text abc 0 subexpr {{def}} 1 text def 0 {}}
test parseExpr-15.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {wideIntegerUnparsed} {
list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.3 {ParsePrimaryExpr procedure, valid parenthesized subexpr} {
testexprparser {({abc}? 2*4 : -6)} -1
} {- {} 0 subexpr {{abc}? 2*4 : -6} 13 operator ? 0 subexpr {{abc}} 1 text abc 0 subexpr 2*4 5 operator * 0 subexpr 2 1 text 2 0 subexpr 4 1 text 4 0 subexpr -6 3 operator - 0 subexpr 6 1 text 6 0 {}}
test parseExpr-15.4 {ParsePrimaryExpr procedure, error in parenthesized subexpr} {
list [catch {testexprparser {(? 123 : 456)} -1} msg] $msg
} {1 {syntax error in expression "(? 123 : 456)": unexpected ternary 'then' separator}}
test parseExpr-15.5 {ParsePrimaryExpr procedure, missing ")" after in parenthesized subexpr} {
list [catch {testexprparser {({abc}/{def}} -1} msg] $msg
} {1 {syntax error in expression "({abc}/{def}": looking for close parenthesis}}
test parseExpr-15.6 {ParsePrimaryExpr procedure, primary is literal} {
testexprparser {12345} -1
} {- {} 0 subexpr 12345 1 text 12345 0 {}}
test parseExpr-15.7 {ParsePrimaryExpr procedure, primary is literal} {
testexprparser {12345.6789} -1
} {- {} 0 subexpr 12345.6789 1 text 12345.6789 0 {}}
test parseExpr-15.8 {ParsePrimaryExpr procedure, primary is var reference} {
testexprparser {$a} -1
} {- {} 0 subexpr {$a} 2 variable {$a} 1 text a 0 {}}
test parseExpr-15.9 {ParsePrimaryExpr procedure, primary is var reference} {
testexprparser {$a(hello$there)} -1
} {- {} 0 subexpr {$a(hello$there)} 5 variable {$a(hello$there)} 4 text a 0 text hello 0 variable {$there} 1 text there 0 {}}
test parseExpr-15.10 {ParsePrimaryExpr procedure, primary is var reference} {
testexprparser {$a()} -1
} {- {} 0 subexpr {$a()} 3 variable {$a()} 2 text a 0 text {} 0 {}}
test parseExpr-15.11 {ParsePrimaryExpr procedure, error in var reference} {
list [catch {testexprparser {$a(} -1} msg] $msg
} {1 {missing )}}
test parseExpr-15.12 {ParsePrimaryExpr procedure, primary is quoted string} {
testexprparser {"abc $xyz def"} -1
} {- {} 0 subexpr {"abc $xyz def"} 5 word {"abc $xyz def"} 4 text {abc } 0 variable {$xyz} 1 text xyz 0 text { def} 0 {}}
test parseExpr-15.13 {ParsePrimaryExpr procedure, error in quoted string} {
list [catch {testexprparser {"$a(12"} -1} msg] $msg
} {1 {missing )}}
test parseExpr-15.14 {ParsePrimaryExpr procedure, quoted string has multiple tokens} {
testexprparser {"abc [xyz] $def"} -1
} {- {} 0 subexpr {"abc [xyz] $def"} 6 word {"abc [xyz] $def"} 5 text {abc } 0 command {[xyz]} 0 text { } 0 variable {$def} 1 text def 0 {}}
test parseExpr-15.15 {ParsePrimaryExpr procedure, primary is command} {
testexprparser {[def]} -1
} {- {} 0 subexpr {[def]} 1 command {[def]} 0 {}}
test parseExpr-15.16 {ParsePrimaryExpr procedure, primary is multiple commands} {
testexprparser {[one; two; three; four;]} -1
} {- {} 0 subexpr {[one; two; three; four;]} 1 command {[one; two; three; four;]} 0 {}}
test parseExpr-15.17 {ParsePrimaryExpr procedure, primary is multiple commands} {
testexprparser {[one; two; three; four;]} -1
} {- {} 0 subexpr {[one; two; three; four;]} 1 command {[one; two; three; four;]} 0 {}}
test parseExpr-15.18 {ParsePrimaryExpr procedure, missing close bracket} {
list [catch {testexprparser {[one} -1} msg] $msg
} {1 {missing close-bracket}}
test parseExpr-15.19 {ParsePrimaryExpr procedure, primary is braced string} {
testexprparser {{hello world}} -1
} {- {} 0 subexpr {{hello world}} 1 text {hello world} 0 {}}
test parseExpr-15.20 {ParsePrimaryExpr procedure, error in primary, which is braced string} {
list [catch {testexprparser "\{abc\\\n" -1} msg] $msg
} {1 {missing close-brace}}
test parseExpr-15.21 {ParsePrimaryExpr procedure, primary is braced string with multiple tokens} {
testexprparser "\{ \\
+123 \}" -1
} {- {} 0 subexpr \{\ \ \\\n\ +123\ \} 4 word \{\ \ \\\n\ +123\ \} 3 text { } 0 backslash \\\n\ 0 text {+123 } 0 {}}
test parseExpr-15.22 {ParsePrimaryExpr procedure, primary is function call} {
testexprparser {foo(123)} -1
} {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}}
test parseExpr-15.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {wideIntegerUnparsed} {
list [catch {testexprparser {foo 12345678901234567890 123)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} {
list [catch {testexprparser {foo 27.4 123)} -1} msg] $msg
} {1 {syntax error in expression "foo 27.4 123)": variable references require preceding $}}
test parseExpr-15.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {wideIntegerUnparsed} {
list [catch {testexprparser {foo(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.26 {ParsePrimaryExpr procedure, function call, one arg} {
testexprparser {foo(27*4)} -1
} {- {} 0 subexpr foo(27*4) 7 operator foo 0 subexpr 27*4 5 operator * 0 subexpr 27 1 text 27 0 subexpr 4 1 text 4 0 {}}
test parseExpr-15.27 {ParsePrimaryExpr procedure, error in function arg} {
list [catch {testexprparser {foo(*1-2)} -1} msg] $msg
} {1 {syntax error in expression "foo(*1-2)": unexpected operator *}}
test parseExpr-15.28 {ParsePrimaryExpr procedure, error in function arg} {
list [catch {testexprparser {foo(*1-2)} -1} msg] $msg
} {1 {syntax error in expression "foo(*1-2)": unexpected operator *}}
test parseExpr-15.29 {ParsePrimaryExpr procedure, function call, comma after arg} {
testexprparser {foo(27-2, (-2*[foo]))} -1
} {- {} 0 subexpr {foo(27-2, (-2*[foo]))} 15 operator foo 0 subexpr 27-2 5 operator - 0 subexpr 27 1 text 27 0 subexpr 2 1 text 2 0 subexpr {-2*[foo]} 7 operator * 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr {[foo]} 1 command {[foo]} 0 {}}
test parseExpr-15.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {wideIntegerUnparsed} {
list [catch {testexprparser {foo(123, 12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.31 {ParsePrimaryExpr procedure, lexeme not "," or ")" after arg} {
list [catch {testexprparser {foo(123 [foo])} -1} msg] $msg
} {1 {syntax error in expression "foo(123 [foo])": missing close parenthesis at end of function call}}
test parseExpr-15.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {wideIntegerUnparsed} {
list [catch {testexprparser {123 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-15.33 {ParsePrimaryExpr procedure, comma-specific message} {
list [catch {testexprparser {123+,456} -1} msg] $msg
} {1 {syntax error in expression "123+,456": commas can only separate function arguments}}
test parseExpr-15.34 {ParsePrimaryExpr procedure, single equal-specific message} {
list [catch {testexprparser {123+=456} -1} msg] $msg
} {1 {syntax error in expression "123+=456": single equality character not legal in expressions}}
test parseExpr-15.35 {ParsePrimaryExpr procedure, error in parenthesized subexpr} {
list [catch {testexprparser {(: 123 : 456)} -1} msg] $msg
} {1 {syntax error in expression "(: 123 : 456)": unexpected ternary 'else' separator}}
test parseExpr-15.36 {ParsePrimaryExpr procedure, missing close-bracket} {
# Test for Bug 681841
list [catch {testexprparser {[set a [format bc]} -1} msg] $msg
} {1 {missing close-bracket}}
test parseExpr-16.1 {GetLexeme procedure, whitespace before lexeme} {
testexprparser { 123} -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-16.2 {GetLexeme procedure, whitespace before lexeme} {
testexprparser { \
456} -1
} {- {} 0 subexpr 456 1 text 456 0 {}}
test parseExpr-16.3 {GetLexeme procedure, no lexeme after whitespace} {
testexprparser { 123 \
} -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-16.4 {GetLexeme procedure, integer lexeme} {
testexprparser {000} -1
} {- {} 0 subexpr 000 1 text 000 0 {}}
test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {wideIntegerUnparsed} {
list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-16.6 {GetLexeme procedure, bad integer lexeme} -body {
testexprparser {0999} -1
} -returnCodes error -match glob -result {*invalid octal number*}
test parseExpr-16.7 {GetLexeme procedure, double lexeme} {
testexprparser {0.999} -1
} {- {} 0 subexpr 0.999 1 text 0.999 0 {}}
test parseExpr-16.8 {GetLexeme procedure, double lexeme} {
testexprparser {.123} -1
} {- {} 0 subexpr .123 1 text .123 0 {}}
test parseExpr-16.9 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} {
testexprparser {nan} -1
} {- {} 0 subexpr nan 1 text nan 0 {}}
test parseExpr-16.10 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} {
testexprparser {NaN} -1
} {- {} 0 subexpr NaN 1 text NaN 0 {}}
test parseExpr-16.11 {GetLexeme procedure, bad double lexeme too big} {
list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg
} {1 {floating-point value too large to represent}}
test parseExpr-16.12 {GetLexeme procedure, bad double lexeme} {
list [catch {testexprparser {123.4x56} -1} msg] $msg
} {1 {syntax error in expression "123.4x56": extra tokens at end of expression}}
test parseExpr-16.13 {GetLexeme procedure, lexeme is "["} {
testexprparser {[foo]} -1
} {- {} 0 subexpr {[foo]} 1 command {[foo]} 0 {}}
test parseExpr-16.14 {GetLexeme procedure, lexeme is open brace} {
testexprparser {{bar}} -1
} {- {} 0 subexpr {{bar}} 1 text bar 0 {}}
test parseExpr-16.15 {GetLexeme procedure, lexeme is "("} {
testexprparser {(123)} -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-16.16 {GetLexeme procedure, lexeme is ")"} {
testexprparser {(2*3)} -1
} {- {} 0 subexpr 2*3 5 operator * 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.17 {GetLexeme procedure, lexeme is "$"} {
testexprparser {$wombat} -1
} {- {} 0 subexpr {$wombat} 2 variable {$wombat} 1 text wombat 0 {}}
test parseExpr-16.18 "GetLexeme procedure, lexeme is '\"'" {
testexprparser {"fred"} -1
} {- {} 0 subexpr {"fred"} 1 text fred 0 {}}
test parseExpr-16.19 {GetLexeme procedure, lexeme is ","} {
testexprparser {foo(1,2)} -1
} {- {} 0 subexpr foo(1,2) 5 operator foo 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-16.20 {GetLexeme procedure, lexeme is "*"} {
testexprparser {$a*$b} -1
} {- {} 0 subexpr {$a*$b} 7 operator * 0 subexpr {$a} 2 variable {$a} 1 text a 0 subexpr {$b} 2 variable {$b} 1 text b 0 {}}
test parseExpr-16.21 {GetLexeme procedure, lexeme is "/"} {
testexprparser {5/6} -1
} {- {} 0 subexpr 5/6 5 operator / 0 subexpr 5 1 text 5 0 subexpr 6 1 text 6 0 {}}
test parseExpr-16.22 {GetLexeme procedure, lexeme is "%"} {
testexprparser {5%[xxx]} -1
} {- {} 0 subexpr {5%[xxx]} 5 operator % 0 subexpr 5 1 text 5 0 subexpr {[xxx]} 1 command {[xxx]} 0 {}}
test parseExpr-16.23 {GetLexeme procedure, lexeme is "+"} {
testexprparser {1+2} -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-16.24 {GetLexeme procedure, lexeme is "-"} {
testexprparser {.12-0e27} -1
} {- {} 0 subexpr .12-0e27 5 operator - 0 subexpr .12 1 text .12 0 subexpr 0e27 1 text 0e27 0 {}}
test parseExpr-16.25 {GetLexeme procedure, lexeme is "?" or ":"} {
testexprparser {$b? 1 : 0} -1
} {- {} 0 subexpr {$b? 1 : 0} 8 operator ? 0 subexpr {$b} 2 variable {$b} 1 text b 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-16.26 {GetLexeme procedure, lexeme is "<"} {
testexprparser {2<3} -1
} {- {} 0 subexpr 2<3 5 operator < 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.27 {GetLexeme procedure, lexeme is "<<"} {
testexprparser {2<<3} -1
} {- {} 0 subexpr 2<<3 5 operator << 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.28 {GetLexeme procedure, lexeme is "<="} {
testexprparser {2<=3} -1
} {- {} 0 subexpr 2<=3 5 operator <= 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.29 {GetLexeme procedure, lexeme is ">"} {
testexprparser {2>3} -1
} {- {} 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.30 {GetLexeme procedure, lexeme is ">>"} {
testexprparser {2>>3} -1
} {- {} 0 subexpr 2>>3 5 operator >> 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.31 {GetLexeme procedure, lexeme is ">="} {
testexprparser {2>=3} -1
} {- {} 0 subexpr 2>=3 5 operator >= 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.32 {GetLexeme procedure, lexeme is "=="} {
testexprparser {2==3} -1
} {- {} 0 subexpr 2==3 5 operator == 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.33 {GetLexeme procedure, bad lexeme starting with "="} {
list [catch {testexprparser {2=+3} -1} msg] $msg
} {1 {syntax error in expression "2=+3": extra tokens at end of expression}}
test parseExpr-16.34 {GetLexeme procedure, lexeme is "!="} {
testexprparser {2!=3} -1
} {- {} 0 subexpr 2!=3 5 operator != 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.35 {GetLexeme procedure, lexeme is "!"} {
testexprparser {!2} -1
} {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}}
test parseExpr-16.36 {GetLexeme procedure, lexeme is "&&"} {
testexprparser {2&&3} -1
} {- {} 0 subexpr 2&&3 5 operator && 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.37 {GetLexeme procedure, lexeme is "&"} {
testexprparser {1&2} -1
} {- {} 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-16.38 {GetLexeme procedure, lexeme is "^"} {
testexprparser {1^2} -1
} {- {} 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-16.39 {GetLexeme procedure, lexeme is "||"} {
testexprparser {2||3} -1
} {- {} 0 subexpr 2||3 5 operator || 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.40 {GetLexeme procedure, lexeme is "|"} {
testexprparser {1|2} -1
} {- {} 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-16.41 {GetLexeme procedure, lexeme is "~"} {
testexprparser {~2} -1
} {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}}
test parseExpr-16.42 {GetLexeme procedure, lexeme is func name} {
testexprparser {george()} -1
} {- {} 0 subexpr george() 1 operator george 0 {}}
test parseExpr-16.43 {GetLexeme procedure, lexeme is func name} {
testexprparser {harmonic_ratio(2,3)} -1
} {- {} 0 subexpr harmonic_ratio(2,3) 5 operator harmonic_ratio 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-16.44 {GetLexeme procedure, unknown lexeme} {
list [catch {testexprparser {@27} -1} msg] $msg
} {1 {syntax error in expression "@27": character not legal in expressions}}
test parseExpr-17.1 {PrependSubExprTokens procedure, expand token array} {
testexprparser {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} -1
} {- {} 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 13 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 9 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 5 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 {}}
test parseExpr-18.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
list [catch {testexprparser {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1} msg] $msg
} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012...": premature end of expression}}
test parseExpr-19.1 {TclParseInteger: [Bug 648441]} {
# Should see this as integer "0" followed by incomplete function "x"
# Thus, syntax error.
# If Bug 648441 is not fixed, "0x" will be seen as floating point 0.0
list [catch {expr 0x} result] $result
} [list 1 {syntax error in expression "0x": extra tokens at end of expression}]
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/subst.test 0000644 0036047 0045461 00000021345 11737050674 014127 0 ustar dgp 771div # Commands covered: subst
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 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.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test subst-1.1 {basics} {
list [catch {subst} msg] $msg
} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}}
test subst-1.2 {basics} {
list [catch {subst a b c} msg] $msg
} {1 {bad switch "a": must be -nobackslashes, -nocommands, or -novariables}}
test subst-2.1 {simple strings} {
subst {}
} {}
test subst-2.2 {simple strings} {
subst a
} a
test subst-2.3 {simple strings} {
subst abcdefg
} abcdefg
test subst-2.4 {simple strings} {
# Tcl Bug 685106
subst [bytestring bar\x00soom]
} [bytestring bar\x00soom]
test subst-3.1 {backslash substitutions} {
subst {\x\$x\[foo bar]\\}
} "x\$x\[foo bar]\\"
test subst-3.2 {backslash substitutions with utf chars} {
# 'j' is just a char that doesn't mean anything, and \344 is 'ф'
# that also doesn't mean anything, but is multi-byte in UTF-8.
list [subst \j] [subst \\j] [subst \\344] [subst \\\344]
} "j j \344 \344"
test subst-4.1 {variable substitutions} {
set a 44
subst {$a}
} {44}
test subst-4.2 {variable substitutions} {
set a 44
subst {x$a.y{$a}.z}
} {x44.y{44}.z}
test subst-4.3 {variable substitutions} {
catch {unset a}
set a(13) 82
set i 13
subst {x.$a($i)}
} {x.82}
catch {unset a}
set long {This is a very long string, intentionally made so long that it
will overflow the static character size for dstrings, so that
additional memory will have to be allocated by subst. That way,
if the subst procedure forgets to free up memory while returning
an error, there will be memory that isn't freed (this will be
detected when the tests are run under a checking memory allocator
such as Purify).}
test subst-4.4 {variable substitutions} {
list [catch {subst {$long $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test subst-5.1 {command substitutions} {
subst {[concat {}]}
} {}
test subst-5.2 {command substitutions} {
subst {[concat A test string]}
} {A test string}
test subst-5.3 {command substitutions} {
subst {x.[concat foo].y.[concat bar].z}
} {x.foo.y.bar.z}
test subst-5.4 {command substitutions} {
list [catch {subst {$long [set long] [bogus_command]}} msg] $msg
} {1 {invalid command name "bogus_command"}}
test subst-5.5 {command substitutions} {
set a 0
list [catch {subst {[set a 1}} msg] $a $msg
} {1 0 {missing close-bracket}}
test subst-5.6 {command substitutions} {
set a 0
list [catch {subst {0[set a 1}} msg] $a $msg
} {1 0 {missing close-bracket}}
test subst-5.7 {command substitutions} {
set a 0
list [catch {subst {0[set a 1; set a 2}} msg] $a $msg
} {1 1 {missing close-bracket}}
# repeat the tests above simulating cmd line input
test subst-5.8 {command substitutions} {
set script {[subst {[set a 1}]}
list [catch {exec [info nameofexecutable] << $script} msg] $msg
} {1 {missing close-bracket}}
test subst-5.9 {command substitutions} {
set script {[subst {0[set a 1}]}
list [catch {exec [info nameofexecutable] << $script} msg] $msg
} {1 {missing close-bracket}}
test subst-5.10 {command substitutions} {
set script {[subst {0[set a 1; set a 2}]}
list [catch {exec [info nameofexecutable] << $script} msg] $msg
} {1 {missing close-bracket}}
test subst-6.1 {clear the result after command substitution} {
catch {unset a}
list [catch {subst {[concat foo] $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test subst-7.1 {switches} {
list [catch {subst foo bar} msg] $msg
} {1 {bad switch "foo": must be -nobackslashes, -nocommands, or -novariables}}
test subst-7.2 {switches} {
list [catch {subst -no bar} msg] $msg
} {1 {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables}}
test subst-7.3 {switches} {
list [catch {subst -bogus bar} msg] $msg
} {1 {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables}}
test subst-7.4 {switches} {
set x 123
subst -nobackslashes {abc $x [expr 1+2] \\\x41}
} {abc 123 3 \\\x41}
test subst-7.5 {switches} {
set x 123
subst -nocommands {abc $x [expr 1+2] \\\x41}
} {abc 123 [expr 1+2] \A}
test subst-7.6 {switches} {
set x 123
subst -novariables {abc $x [expr 1+2] \\\x41}
} {abc $x 3 \A}
test subst-7.7 {switches} {
set x 123
subst -nov -nob -noc {abc $x [expr 1+2] \\\x41}
} {abc $x [expr 1+2] \\\x41}
test subst-8.1 {return in a subst} {
subst {foo [return {x}; bogus code] bar}
} {foo x bar}
test subst-8.2 {return in a subst} {
subst {foo [return x ; bogus code] bar}
} {foo x bar}
test subst-8.3 {return in a subst} {
subst {foo [if 1 { return {x}; bogus code }] bar}
} {foo x bar}
test subst-8.4 {return in a subst} {
subst {[eval {return hi}] there}
} {hi there}
test subst-8.5 {return in a subst} {
subst {foo [return {]}; bogus code] bar}
} {foo ] bar}
test subst-8.6 {return in a subst} {
list [catch {subst {foo [return {x}; bogus code bar}} msg] $msg
} {1 {missing close-bracket}}
test subst-8.7 {return in a subst, parse error} {
subst {foo [return {x} ; set a {}" ; stuff] bar}
} {foo xset a {}" ; stuff] bar}
test subst-8.8 {return in a subst, parse error} {
subst {foo [return {x} ; set bar baz ; set a {}" ; stuff] bar}
} {foo xset bar baz ; set a {}" ; stuff] bar}
test subst-8.9 {return in a variable subst} {
subst {foo $var([return {x}]) bar}
} {foo x bar}
test subst-9.1 {error in a subst} {
list [catch {subst {[error foo; bogus code]bar}} msg] $msg
} {1 foo}
test subst-9.2 {error in a subst} {
list [catch {subst {[if 1 { error foo; bogus code}]bar}} msg] $msg
} {1 foo}
test subst-9.3 {error in a variable subst} {
list [catch {subst {foo $var([error foo]) bar}} msg] $msg
} {1 foo}
test subst-10.1 {break in a subst} {
subst {foo [break; bogus code] bar}
} {foo }
test subst-10.2 {break in a subst} {
subst {foo [break; return x; bogus code] bar}
} {foo }
test subst-10.3 {break in a subst} {
subst {foo [if 1 { break; bogus code}] bar}
} {foo }
test subst-10.4 {break in a subst, parse error} {
subst {foo [break ; set a {}{} ; stuff] bar}
} {foo }
test subst-10.5 {break in a subst, parse error} {
subst {foo [break ;set bar baz ;set a {}{} ; stuff] bar}
} {foo }
test subst-10.6 {break in a variable subst} {
subst {foo $var([break]) bar}
} {foo }
test subst-11.1 {continue in a subst} {
subst {foo [continue; bogus code] bar}
} {foo bar}
test subst-11.2 {continue in a subst} {
subst {foo [continue; return x; bogus code] bar}
} {foo bar}
test subst-11.3 {continue in a subst} {
subst {foo [if 1 { continue; bogus code}] bar}
} {foo bar}
test subst-11.4 {continue in a subst, parse error} {
subst {foo [continue ; set a {}{} ; stuff] bar}
} {foo set a {}{} ; stuff] bar}
test subst-11.5 {continue in a subst, parse error} {
subst {foo [continue ;set bar baz ;set a {}{} ; stuff] bar}
} {foo set bar baz ;set a {}{} ; stuff] bar}
test subst-11.6 {continue in a variable subst} {
subst {foo $var([continue]) bar}
} {foo bar}
test subst-12.1 {nasty case, Bug 1036649} {
for {set i 0} {$i < 10} {incr i} {
set res [list [catch {subst "\[subst {};"} msg] $msg]
if {$msg ne "missing close-bracket"} break
}
set res
} {1 {missing close-bracket}}
test subst-12.2 {nasty case, Bug 1036649} {
for {set i 0} {$i < 10} {incr i} {
set res [list [catch {subst "\[subst {}; "} msg] $msg]
if {$msg ne "missing close-bracket"} break
}
set res
} {1 {missing close-bracket}}
test subst-12.3 {nasty case, Bug 1036649} {
set x 0
for {set i 0} {$i < 10} {incr i} {
set res [list [catch {subst "\[incr x;"} msg] $msg]
if {$msg ne "missing close-bracket"} break
}
list $res $x
} {{1 {missing close-bracket}} 10}
test subst-12.4 {nasty case, Bug 1036649} {
set x 0
for {set i 0} {$i < 10} {incr i} {
set res [list [catch {subst "\[incr x; "} msg] $msg]
if {$msg ne "missing close-bracket"} break
}
list $res $x
} {{1 {missing close-bracket}} 10}
test subst-12.5 {nasty case, Bug 1036649} {
set x 0
for {set i 0} {$i < 10} {incr i} {
set res [list [catch {subst "\[incr x"} msg] $msg]
if {$msg ne "missing close-bracket"} break
}
list $res $x
} {{1 {missing close-bracket}} 0}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/platform.test 0000644 0036047 0045461 00000004033 12052456744 014605 0 ustar dgp 771div # The file tests the tcl_platform variable
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
i eval {catch {unset tcl_platform(tip,268)}}
i eval {catch {unset tcl_platform(tip,280)}}
set result [i eval {lsort [array names tcl_platform]}]
interp delete i
set result
} {byteOrder machine os osVersion platform user wordSize}
# Test assumes twos-complement arithmetic, which is true of virtually
# everything these days. Note that this does *not* use wide(), and
# this is intentional since that could make Tcl's numbers wider than
# the machine-integer on some platforms...
test platform-2.1 {tcl_platform(wordSize) indicates size of native word} {
set result [expr {1 << (8 * $tcl_platform(wordSize) - 1)}]
# Result must be the largest bit in a machine word, which this checks
# without assuming how wide the word really is
list [expr {$result < 0}] [expr {$result ^ ($result - 1)}]
} {1 -1}
# On Windows/UNIX, test that the CPU ID works
test platform-3.1 {CPU ID on Windows/UNIX} \
-constraints testCPUID \
-body {
set cpudata [testcpuid 0]
binary format iii \
[lindex $cpudata 1] \
[lindex $cpudata 3] \
[lindex $cpudata 2]
} \
-match regexp \
-result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
tcl8.4.20/tests/basic.test 0000644 0036047 0045461 00000055770 11737050674 014061 0 ustar dgp 771div # This file contains tests for the tclBasic.c source file. Tests appear in
# the same order as the C code that they test. The set of tests is
# currently incomplete since it currently includes only new tests for
# code changed for the addition of Tcl namespaces. Other variable-
# related tests appear in several other test files including
# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test,
# and trace.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
namespace import -force ::tcltest::*
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint exec [llength [info commands exec]]
# This variable needs to be changed when the major or minor version number for
# Tcl changes.
set tclvers 8.4
catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {unset x}
test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
namespace eval test_ns_basic {
proc p {} {
return [namespace current]
}
}
}
list [interp eval test_interp {test_ns_basic::p}] \
[interp delete test_interp]
} {::test_ns_basic {}}
test basic-2.1 {TclHideUnsafeCommands} {emptyTest} {
} {}
test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} {
} {}
test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {emptyTest} {
} {}
test basic-5.1 {Tcl_SetAssocData: see assoc.test} {emptyTest} {
} {}
test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {emptyTest} {
} {}
test basic-7.1 {Tcl_GetAssocData: see assoc.test} {emptyTest} {
} {}
test basic-8.1 {Tcl_InterpDeleted} {emptyTest} {
} {}
test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} {
} {}
test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
namespace eval test_ns_basic {
namespace export p
proc p {} {
return [namespace current]
}
}
namespace eval test_ns_2 {
namespace import ::test_ns_basic::p
variable v 27
proc q {} {
variable v
return "[p] $v"
}
}
}
list [interp eval test_interp {test_ns_2::q}] \
[interp eval test_interp {namespace delete ::}] \
[catch {interp eval test_interp {set a 123}} msg] $msg \
[interp delete test_interp]
} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}}
test basic-11.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
proc p {} {
return 27
}
}
interp alias {} localP test_interp p
list [interp eval test_interp {p}] \
[localP] \
[test_interp hide p] \
[catch {localP} msg] $msg \
[interp delete test_interp] \
[catch {localP} msg] $msg
} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}}
# NB: More tests about hide/expose are found in interp.test
test basic-12.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
namespace eval test_ns_basic {
proc p {} {
return [namespace current]
}
}
}
list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
[catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
[interp delete test_interp]
} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers in hidden command token (rename)} {}}
test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {
catch {namespace delete test_ns_basic}
catch {rename cmd ""}
proc cmd {} { ;# note that this is global
return [namespace current]
}
namespace eval test_ns_basic {
proc hideCmd {} {
interp hide {} cmd
}
proc exposeCmd {} {
interp expose {} cmd
}
proc callCmd {} {
cmd
}
}
list [test_ns_basic::callCmd] \
[test_ns_basic::hideCmd] \
[catch {cmd} msg] $msg \
[test_ns_basic::exposeCmd] \
[test_ns_basic::callCmd] \
[namespace delete test_ns_basic]
} {:: {} 1 {invalid command name "cmd"} {} :: {}}
test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} {
catch {namespace delete test_ns_basic}
catch {rename cmd ""}
proc cmd {} { ;# note that this is global
return [namespace current]
}
namespace eval test_ns_basic {
proc hideCmd {} {
interp hide {} cmd
}
proc exposeCmdFailing {} {
interp expose {} cmd ::test_ns_basic::newCmd
}
proc exposeCmdWorkAround {} {
interp expose {} cmd;
rename cmd ::test_ns_basic::newCmd;
}
proc callCmd {} {
cmd
}
}
list [test_ns_basic::callCmd] \
[test_ns_basic::hideCmd] \
[catch {test_ns_basic::exposeCmdFailing} msg] $msg \
[test_ns_basic::exposeCmdWorkAround] \
[test_ns_basic::newCmd] \
[namespace delete test_ns_basic]
} {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}}
test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} {
catch {rename p ""}
catch {rename cmd ""}
proc p {} {
cmd
}
proc cmd {} {
return 42
}
list [p] \
[interp hide {} cmd] \
[proc cmd {} {return Hello}] \
[cmd] \
[rename cmd ""] \
[interp expose {} cmd] \
[p]
} {42 {} {} Hello {} {} 42}
test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [testcreatecommand create] \
[test_ns_basic::createdcommand] \
[testcreatecommand delete]
} {{} {CreatedCommandProc in ::test_ns_basic} {}}
test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename value:at: ""}
list [testcreatecommand create2] \
[value:at:] \
[testcreatecommand delete2]
} {{} {CreatedCommandProc2 in ::} {}}
test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_basic {}
proc test_ns_basic::cmd {} { ;# proc requires that ns already exist
return [namespace current]
}
list [test_ns_basic::cmd] \
[namespace delete test_ns_basic]
} {::test_ns_basic {}}
test basic-16.1 {TclInvokeStringCommand} {emptyTest} {
} {}
test basic-17.1 {TclInvokeObjCommand} {emptyTest} {
} {}
test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename cmd ""}
namespace eval test_ns_basic {
proc p {} {
return "p in [namespace current]"
}
}
list [test_ns_basic::p] \
[rename test_ns_basic::p test_ns_basic::q] \
[test_ns_basic::q]
} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}}
test basic-18.2 {TclRenameCommand, existing cmd must be found} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg
} {1 {can't rename "test_ns_basic::p": command doesn't exist}}
test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_basic {
proc p {} {
return "p in [namespace current]"
}
}
list [info commands test_ns_basic::*] \
[rename test_ns_basic::p ""] \
[info commands test_ns_basic::*]
} {::test_ns_basic::p {} {}}
test basic-18.4 {TclRenameCommand, bad new name} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_basic {
proc p {} {
return "p in [namespace current]"
}
}
rename test_ns_basic::p :::george::martha
} {}
test basic-18.5 {TclRenameCommand, new name must not already exist} {
namespace eval test_ns_basic {
proc q {} {
return 42
}
}
list [catch {rename test_ns_basic::q :::george::martha} msg] $msg
} {1 {can't rename to ":::george::martha": command already exists}}
test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename q ""}
proc p {} {
return "p in [namespace current]"
}
proc q {} {
return "q in [namespace current]"
}
namespace eval test_ns_basic {
proc callP {} {
p
}
}
list [test_ns_basic::callP] \
[rename q test_ns_basic::p] \
[test_ns_basic::callP]
} {{p in ::} {} {q in ::test_ns_basic}}
test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} {
} {}
test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename q ""}
catch {unset x}
set x [namespace eval test_ns_basic::test_ns_basic2 {
# the following creates a cmd in the global namespace
testcmdtoken create p
}]
list [testcmdtoken name $x] \
[rename ::p q] \
[testcmdtoken name $x]
} {{p ::p} {} {q ::q}}
test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {testcmdtoken} {
catch {rename q ""}
set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
list [testcmdtoken name $x] \
[rename test_ns_basic::test_ns_basic2::p q] \
[testcmdtoken name $x]
} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
} {}
test basic-22.1 {Tcl_GetCommandFullName} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_basic1 {
namespace export cmd*
proc cmd1 {} {}
proc cmd2 {} {}
}
namespace eval test_ns_basic2 {
namespace export *
namespace import ::test_ns_basic1::*
proc p {} {}
}
namespace eval test_ns_basic3 {
namespace import ::test_ns_basic2::*
proc q {} {}
list [namespace which -command foreach] \
[namespace which -command q] \
[namespace which -command p] \
[namespace which -command cmd1] \
[namespace which -command ::test_ns_basic2::cmd2]
}
} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}
test basic-23.1 {Tcl_DeleteCommand} {emptyTest} {
} {}
test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
catch {interp delete test_interp}
catch {unset x}
interp create test_interp
interp eval test_interp {
proc useSet {} {
return [set a 123]
}
}
set x [interp eval test_interp {useSet}]
interp eval test_interp {
rename set ""
proc set {args} {
return "set called with $args"
}
}
list $x \
[interp eval test_interp {useSet}] \
[interp delete test_interp]
} {123 {set called with a 123} {}}
test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {
return "global p"
}
namespace eval test_ns_basic {
proc p {} {
return "namespace p"
}
proc callP {} {
p
}
}
list [test_ns_basic::callP] \
[rename test_ns_basic::p ""] \
[test_ns_basic::callP]
} {{namespace p} {} {global p}}
test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
namespace eval test_ns_basic {
namespace export p
proc p {} {return 42}
}
namespace eval test_ns_basic2 {
namespace import ::test_ns_basic::*
proc callP {} {
p
}
}
list [test_ns_basic2::callP] \
[info commands test_ns_basic2::*] \
[rename test_ns_basic::p ""] \
[catch {test_ns_basic2::callP} msg] $msg \
[info commands test_ns_basic2::*]
} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP}
test basic-25.1 {TclCleanupCommand} {emptyTest} {
} {}
test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} {
# If object isn't preserved, errorInfo would be set to
# "foo\n while executing\n\"garbage bytes\"" because the object's
# string would have been freed, leaving garbage bytes for the error
# message.
proc bgerror {args} {set ::x $::errorInfo}
set fName [makeFile {} test1]
set f [open $fName w]
fileevent $f writable "fileevent $f writable {}; error foo"
set x {}
vwait x
close $f
removeFile test1
rename bgerror {}
set x
} "foo\n while executing\n\"error foo\""
test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} {
#
# Follow the pure-list branch in a manner that
# a - the pure-list internal rep is destroyed by shimmering
# b - the command returns an error
# As the error code in Tcl_EvalObjv accesses the list elements, this will
# cause a segfault if [Bug 1119369] has not been fixed.
#
set SRC [list foo 1] ;# pure-list command
proc foo str {
# Shimmer pure-list to cmdName, cleanup and error
proc $::SRC {} {}; $::SRC
error "BAD CALL"
}
catch {eval $SRC}
} 1
test basic-27.1 {Tcl_ExprLong} {emptyTest} {
} {}
test basic-28.1 {Tcl_ExprDouble} {emptyTest} {
} {}
test basic-29.1 {Tcl_ExprBoolean} {emptyTest} {
} {}
test basic-30.1 {Tcl_ExprLongObj} {emptyTest} {
} {}
test basic-31.1 {Tcl_ExprDoubleObj} {emptyTest} {
} {}
test basic-32.1 {Tcl_ExprBooleanObj} {emptyTest} {
} {}
test basic-33.1 {TclInvoke} {emptyTest} {
} {}
test basic-34.1 {TclGlobalInvoke} {emptyTest} {
} {}
test basic-35.1 {TclObjInvokeGlobal} {emptyTest} {
} {}
test basic-36.1 {TclObjInvoke, lookup of "unknown" command} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
proc unknown {args} {
return "global unknown"
}
namespace eval test_ns_basic {
proc unknown {args} {
return "namespace unknown"
}
}
}
list [interp alias test_interp newAlias test_interp doesntExist] \
[catch {interp eval test_interp {newAlias}} msg] $msg \
[interp delete test_interp]
} {newAlias 0 {global unknown} {}}
test basic-37.1 {Tcl_ExprString: see expr.test} {emptyTest} {
} {}
test basic-38.1 {Tcl_ExprObj} {emptyTest} {
} {}
test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace tracetest {set stuff [expr 14 + 16]}
} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}}
test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace tracetest {set stuff [info tclversion]}
} [list {info tclversion} {info tclversion} {set stuff [info tclversion]} "set stuff $tclvers"]
test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace deletetest {set stuff [info tclversion]}
} $tclvers
test basic-39.4 {Tcl_CreateTrace, check that tracing doesn't cause memory faults} {testcmdtrace} {
# Note that the proc call is the same as the variable name, and that
# the call can be direct or indirect by way of another procedure
proc tracer {args} {}
proc tracedLoop {level} {
incr level
tracer
foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}
}
testcmdtrace tracetest {tracedLoop 0}
} {{tracedLoop 0} {tracedLoop 0} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {1 2} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}}}
catch {rename tracer {}}
catch {rename tracedLoop {}}
test basic-39.5 {Tcl_CreateObjTrace, status return TCL_ERROR} {testcmdtrace} {
proc Error { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {Error $x}} result] [set result]
} {1 {Error $x}}
test basic-39.6 {Tcl_CreateObjTrace, status return TCL_RETURN} {testcmdtrace} {
proc Return { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {Return $x}} result] [set result]
} {2 {}}
test basic-39.7 {Tcl_CreateObjTrace, status return TCL_BREAK} {testcmdtrace} {
proc Break { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {Break $x}} result] [set result]
} {3 {}}
test basic-39.8 {Tcl_CreateObjTrace, status return TCL_CONTINUE} {testcmdtrace} {
proc Continue { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {Continue $x}} result] [set result]
} {4 {}}
test basic-39.9 {Tcl_CreateObjTrace, status return unknown} {testcmdtrace} {
proc OtherStatus { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {OtherStatus $x}} result] [set result]
} {6 {}}
test basic-39.10 {Tcl_CreateTrace, correct level interpretation} {testcmdtrace} {
proc foo {} {uplevel 1 bar}
proc bar {} {uplevel 1 grok}
proc grok {} {uplevel 1 spock}
proc spock {} {uplevel 1 fascinating}
proc fascinating {} {}
testcmdtrace leveltest {foo}
} {foo {foo} {uplevel 1 bar} {uplevel 1 bar} bar {bar} {uplevel 1 grok} {uplevel 1 grok}}
test basic-39.11 {Tcl_CreateTrace, multiple traces} {testcmdtrace} {
testcmdtrace doubletest {format xx}
} {{format xx} {format xx}}
test basic-40.1 {Tcl_DeleteTrace} {emptyTest} {
# the above tests have tested Tcl_DeleteTrace
} {}
test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} {
} {}
test basic-42.1 {Tcl_AddObjErrorInfo} {emptyTest} {
} {}
test basic-43.1 {Tcl_VarEval} {emptyTest} {
} {}
test basic-44.1 {Tcl_GlobalEval} {emptyTest} {
} {}
test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
} {}
test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
catch {close $f}
set res [catch {
set f [open |[list [interpreter]] w+]
fconfigure $f -buffering line
puts $f {fconfigure stdout -buffering line}
puts $f continue
puts $f {puts $errorInfo}
puts $f {puts DONE}
set newMsg {}
set msg {}
while {$newMsg != "DONE"} {
set newMsg [gets $f]
append msg "${newMsg}\n"
}
close $f
} error]
list $res $msg
} {1 {invoked "continue" outside of a loop
while executing
"continue"
DONE
}}
test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
puts hello
break
} BREAKtest]
} -constraints {
exec
} -body {
exec [interpreter] $fName
} -cleanup {
removeFile BREAKtest
} -returnCodes error -match glob -result {hello
invoked "break" outside of a loop
while executing
"break"
(file "*BREAKtest" line 3)}
test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
interp alias {} patch {} info patchlevel
patch
break
} BREAKtest]
} -constraints {
exec
} -body {
exec [interpreter] $fName
} -cleanup {
removeFile BREAKtest
} -returnCodes error -match glob -result {invoked "break" outside of a loop
while executing
"break"
(file "*BREAKtest" line 4)}
test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
foo [set a 1] [break]
} BREAKtest]
} -constraints {
exec
} -body {
exec [interpreter] $fName
} -cleanup {
removeFile BREAKtest
} -returnCodes error -match glob -result {invoked "break" outside of a loop
while executing*
"foo \[set a 1] \[break]"
(file "*BREAKtest" line 2)}
test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
return -code return
} BREAKtest]
} -constraints {
exec
} -body {
exec [interpreter] $fName
} -cleanup {
removeFile BREAKtest
} -returnCodes error -match glob -result {command returned bad code: 2
while executing
"return -code return"
(file "*BREAKtest" line 2)}
test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body {
subst {a[set b [format cd]}
} -returnCodes error -result {missing close-bracket}
test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
set ::x global
namespace eval ns {
variable x namespace
testevalex {set x changed} global
set ::result [list $::x $x]
}
namespace delete ns
set ::result
} {changed namespace}
test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
set ::x global
namespace eval ns {
variable x namespace
testevalex {set ::context $x} global
}
namespace delete ns
set ::context
} {global}
# cleanup
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
::tcltest::cleanupTests
return
tcl8.4.20/tests/winNotify.test 0000644 0036047 0045461 00000007440 11737050674 014755 0 ustar dgp 771div # This file tests the tclWinNotify.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
set ::tcltest::testConstraints(testeventloop) \
[expr {[info commands testeventloop] != {}}]
# There is no explicit test for InitNotifier or NotifierExitHandler
test winNotify-1.1 {Tcl_SetTimer: positive timeout} {pcOnly} {
set done 0
after 1000 { set done 1 }
vwait done
set done
} 1
test winNotify-1.2 {Tcl_SetTimer: positive timeout, message pending} {pcOnly} {
set x 0
set y 1
set a1 [after 0 { incr y }]
after cancel $a1
after 500 { incr x }
vwait x
list $x $y
} {1 1}
test winNotify-1.3 {Tcl_SetTimer: cancelling positive timeout} {pcOnly} {
set x 0
set y 1
set id [after 10000 { incr y }]
after 0 { incr x }
vwait x
after cancel $id
list $x $y
} {1 1}
test winNotify-1.4 {Tcl_SetTimer: null timeout, message pending} {pcOnly} {
set x 0
set y 1
after 0 { incr x }
after 0 { incr y }
vwait x
list $x $y
} {1 2}
test winNotify-2.1 {Tcl_ResetIdleTimer} {pcOnly} {
set x 0
update
after idle { incr x }
vwait x
set x
} 1
test winNotify-2.2 {Tcl_ResetIdleTimer: message pending} {pcOnly} {
set x 0
set y 1
update
after idle { incr x }
after idle { incr y }
update
list $x $y
} {1 2}
test winNotify-3.1 {NotifierProc: non-modal normal timer} {pcOnly testeventloop} {
update
set x 0
foreach i [after info] {
after cancel $i
}
after 500 { incr x; testeventloop done }
testeventloop wait
set x
} 1
test winNotify-3.2 {NotifierProc: non-modal normal timer, rescheduled} {pcOnly testeventloop} {
update
set x 0
foreach i [after info] {
after cancel $i
}
after 500 { incr x; after 100 {incr x; testeventloop done }}
testeventloop wait
set x
} 2
test winNotify-3.3 {NotifierProc: modal normal timer} {pcOnly} {
update
set x 0
foreach i [after info] {
after cancel $i
}
after 500 { incr x }
vwait x
set x
} 1
test winNotify-3.4 {NotifierProc: modal normal timer, rescheduled} {pcOnly} {
update
set x 0
foreach i [after info] {
after cancel $i
}
set y 0
after 500 { incr y; after 100 {incr x}}
vwait x
list $x $y
} {1 1}
test winNotify-3.5 {NotifierProc: non-modal idle timer} {pcOnly testeventloop} {
update
set x 0
foreach i [after info] {
after cancel $i
}
after idle { incr x; testeventloop done }
testeventloop wait
set x
} 1
test winNotify-3.6 {NotifierProc: non-modal idle timer, rescheduled} {pcOnly testeventloop} {
update
set x 0
foreach i [after info] {
after cancel $i
}
after idle { incr x; after idle {incr x; testeventloop done }}
testeventloop wait
set x
} 2
test winNotify-3.7 {NotifierProc: modal idle timer} {pcOnly} {
update
set x 0
foreach i [after info] {
after cancel $i
}
after idle { incr x }
vwait x
set x
} 1
test winNotify-3.8 {NotifierProc: modal idle timer, rescheduled} {pcOnly} {
update
set x 0
foreach i [after info] {
after cancel $i
}
set y 0
after idle { incr y; after idle {incr x}}
vwait x
list $x $y
} {1 1}
# Tcl_DoOneEvent is tested by the timer.test, io.test, and event.test files
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/linsert.test 0000644 0036047 0045461 00000006625 11737050674 014453 0 ustar dgp 771div # Commands covered: linsert
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset lis}
catch {rename p ""}
test linsert-1.1 {linsert command} {
linsert {1 2 3 4 5} 0 a
} {a 1 2 3 4 5}
test linsert-1.2 {linsert command} {
linsert {1 2 3 4 5} 1 a
} {1 a 2 3 4 5}
test linsert-1.3 {linsert command} {
linsert {1 2 3 4 5} 2 a
} {1 2 a 3 4 5}
test linsert-1.4 {linsert command} {
linsert {1 2 3 4 5} 3 a
} {1 2 3 a 4 5}
test linsert-1.5 {linsert command} {
linsert {1 2 3 4 5} 4 a
} {1 2 3 4 a 5}
test linsert-1.6 {linsert command} {
linsert {1 2 3 4 5} 5 a
} {1 2 3 4 5 a}
test linsert-1.7 {linsert command} {
linsert {1 2 3 4 5} 2 one two \{three \$four
} {1 2 one two \{three {$four} 3 4 5}
test linsert-1.8 {linsert command} {
linsert {\{one \$two \{three \ four \ five} 2 a b c
} {\{one {$two} a b c \{three { four} { five}}
test linsert-1.9 {linsert command} {
linsert {{1 2} {3 4} {5 6} {7 8}} 2 {x y} {a b}
} {{1 2} {3 4} {x y} {a b} {5 6} {7 8}}
test linsert-1.10 {linsert command} {
linsert {} 2 a b c
} {a b c}
test linsert-1.11 {linsert command} {
linsert {} 2 {}
} {{}}
test linsert-1.12 {linsert command} {
linsert {a b "c c" d e} 3 1
} {a b {c c} 1 d e}
test linsert-1.13 {linsert command} {
linsert { a b c d} 0 1 2
} {1 2 a b c d}
test linsert-1.14 {linsert command} {
linsert {a b c {d e f}} 4 1 2
} {a b c {d e f} 1 2}
test linsert-1.15 {linsert command} {
linsert {a b c \{\ abc} 4 q r
} {a b c \{\ q r abc}
test linsert-1.16 {linsert command} {
linsert {a b c \{ abc} 4 q r
} {a b c \{ q r abc}
test linsert-1.17 {linsert command} {
linsert {a b c} end q r
} {a b c q r}
test linsert-1.18 {linsert command} {
linsert {a} end q r
} {a q r}
test linsert-1.19 {linsert command} {
linsert {} end q r
} {q r}
test linsert-1.20 {linsert command, use of end-int index} {
linsert {a b c d} end-2 e f
} {a b e f c d}
test linsert-2.1 {linsert errors} {
list [catch linsert msg] $msg
} {1 {wrong # args: should be "linsert list index element ?element ...?"}}
test linsert-2.2 {linsert errors} {
list [catch {linsert a b} msg] $msg
} {1 {wrong # args: should be "linsert list index element ?element ...?"}}
test linsert-2.3 {linsert errors} {
list [catch {linsert a 12x 2} msg] $msg
} {1 {bad index "12x": must be integer or end?-integer?}}
test linsert-2.4 {linsert errors} {
list [catch {linsert \{ 12 2} msg] $msg
} {1 {unmatched open brace in list}}
test linsert-3.1 {linsert won't modify shared argument objects} {
proc p {} {
linsert "a b c" 1 "x y"
return "a b c"
}
p
} "a b c"
test linsert-3.2 {linsert won't modify shared argument objects} {
catch {unset lis}
set lis [format "a \"%s\" c" "b"]
linsert $lis 0 [string length $lis]
} "7 a b c"
# cleanup
catch {unset lis}
catch {rename p ""}
::tcltest::cleanupTests
return
tcl8.4.20/tests/winConsole.test 0000644 0036047 0045461 00000002200 11737050674 015074 0 ustar dgp 771div # This file tests the tclWinConsole.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test winConsole-1.1 {Console file channel: non-blocking gets} \
{pcOnly interactive} {
set oldmode [fconfigure stdin]
puts stdout "Enter abcdef now: " nonewline
flush stdout
fileevent stdin readable {
if {[gets stdin line] >= 0} {
set result $line
} else {
set result "gets failed"
}
}
fconfigure stdin -blocking 0 -buffering line
set result {}
vwait result
#cleanup the fileevent
fileevent stdin readable {}
eval fconfigure stdin $oldmode
set result
} "abcdef"
#cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/parse.test 0000644 0036047 0045461 00000110664 11737050674 014104 0 ustar dgp 771div # This file contains a collection of tests for the procedures in the
# file tclParse.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[info commands testparser] == {}} {
puts "This application hasn't been compiled with the \"testparser\""
puts "command, so I can't test the Tcl parser."
::tcltest::cleanupTests
return
}
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} {
testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
test parse-1.3 {Tcl_ParseCommand procedure, leading space} {
testparser " \n\t foo" 0
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.4 {Tcl_ParseCommand procedure, leading space} {
testparser "\f\r\vfoo" 0
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.5 {Tcl_ParseCommand procedure, backslash-newline in leading space} {
testparser " \\\n foo" 0
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.6 {Tcl_ParseCommand procedure, backslash-newline in leading space} {
testparser { \a foo} 0
} {- {\a foo} 2 word {\a} 1 backslash {\a} 0 simple foo 1 text foo 0 {}}
test parse-1.7 {Tcl_ParseCommand procedure, missing continuation line in leading space} {
testparser " \\\n" 0
} {- {} 0 {}}
test parse-1.8 {Tcl_ParseCommand procedure, eof in leading space} {
testparser " foo" 3
} {- {} 0 { foo}}
test parse-2.1 {Tcl_ParseCommand procedure, comments} {
testparser "# foo bar\n foo" 0
} {{# foo bar
} foo 1 simple foo 1 text foo 0 {}}
test parse-2.2 {Tcl_ParseCommand procedure, several comments} {
testparser " # foo bar\n # another comment\n\n foo" 0
} {{# foo bar
# another comment
} foo 1 simple foo 1 text foo 0 {}}
test parse-2.3 {Tcl_ParseCommand procedure, backslash-newline in comments} {
testparser " # foo bar\\\ncomment on continuation line\nfoo" 0
} {#\ foo\ bar\\\ncomment\ on\ continuation\ line\n foo 1 simple foo 1 text foo 0 {}}
test parse-2.4 {Tcl_ParseCommand procedure, missing continuation line in comment} {
testparser "# \\\n" 0
} {#\ \ \ \\\n {} 0 {}}
test parse-2.5 {Tcl_ParseCommand procedure, eof in comment} {
testparser " # foo bar\nfoo" 8
} {{# foo b} {} 0 {ar
foo}}
test parse-3.1 {Tcl_ParseCommand procedure, parsing words, skipping space} {
testparser "foo bar\t\tx" 0
} {- {foo bar x} 3 simple foo 1 text foo 0 simple bar 1 text bar 0 simple x 1 text x 0 {}}
test parse-3.2 {Tcl_ParseCommand procedure, missing continuation line in leading space} {
testparser "abc \\\n" 0
} {- abc\ \ \\\n 1 simple abc 1 text abc 0 {}}
test parse-3.3 {Tcl_ParseCommand procedure, parsing words, command ends in space} {
testparser "foo ; bar x" 0
} {- {foo ;} 1 simple foo 1 text foo 0 { bar x}}
test parse-3.4 {Tcl_ParseCommand procedure, parsing words, command ends in space} {
testparser "foo " 5
} {- {foo } 1 simple foo 1 text foo 0 { }}
test parse-3.5 {Tcl_ParseCommand procedure, quoted words} {
testparser {foo "a b c" d "efg";} 0
} {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}}
test parse-3.6 {Tcl_ParseCommand procedure, words in braces} {
testparser {foo {a $b [concat foo]} {c d}} 0
} {- {foo {a $b [concat foo]} {c d}} 3 simple foo 1 text foo 0 simple {{a $b [concat foo]}} 1 text {a $b [concat foo]} 0 simple {{c d}} 1 text {c d} 0 {}}
test parse-3.7 {Tcl_ParseCommand procedure, error in unquoted word} {
list [catch {testparser "foo \$\{abc" 0} msg] $msg $errorInfo
} {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\$\\\{abc\"\ 0\"}
test parse-4.1 {Tcl_ParseCommand procedure, simple words} {
testparser {foo} 0
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-4.2 {Tcl_ParseCommand procedure, simple words} {
testparser {{abc}} 0
} {- {{abc}} 1 simple {{abc}} 1 text abc 0 {}}
test parse-4.3 {Tcl_ParseCommand procedure, simple words} {
testparser {"c d"} 0
} {- {"c d"} 1 simple {"c d"} 1 text {c d} 0 {}}
test parse-4.4 {Tcl_ParseCommand procedure, simple words} {
testparser {x$d} 0
} {- {x$d} 1 word {x$d} 3 text x 0 variable {$d} 1 text d 0 {}}
test parse-4.5 {Tcl_ParseCommand procedure, simple words} {
testparser {"a [foo] b"} 0
} {- {"a [foo] b"} 1 word {"a [foo] b"} 3 text {a } 0 command {[foo]} 0 text { b} 0 {}}
test parse-4.6 {Tcl_ParseCommand procedure, simple words} {
testparser {$x} 0
} {- {$x} 1 word {$x} 2 variable {$x} 1 text x 0 {}}
test parse-5.1 {Tcl_ParseCommand procedure, backslash-newline terminates word} {
testparser "{abc}\\\n" 0
} {- \{abc\}\\\n 1 simple {{abc}} 1 text abc 0 {}}
test parse-5.2 {Tcl_ParseCommand procedure, backslash-newline terminates word} {
testparser "foo\\\nbar" 0
} {- foo\\\nbar 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
test parse-5.3 {Tcl_ParseCommand procedure, word terminator is command terminator} {
testparser "foo\n bar" 0
} {- {foo
} 1 simple foo 1 text foo 0 { bar}}
test parse-5.4 {Tcl_ParseCommand procedure, word terminator is command terminator} {
testparser "foo; bar" 0
} {- {foo;} 1 simple foo 1 text foo 0 { bar}}
test parse-5.5 {Tcl_ParseCommand procedure, word terminator is end of string} {
testparser "\"foo\" bar" 5
} {- {"foo"} 1 simple {"foo"} 1 text foo 0 { bar}}
test parse-5.6 {Tcl_ParseCommand procedure, junk after close quote} {
list [catch {testparser {foo "bar"x} 0} msg] $msg $errorInfo
} {1 {extra characters after close-quote} {extra characters after close-quote
(remainder of script: "x")
invoked from within
"testparser {foo "bar"x} 0"}}
test parse-5.7 {Tcl_ParseCommand procedure, backslash-newline after close quote} {
testparser "foo \"bar\"\\\nx" 0
} {- foo\ \"bar\"\\\nx 3 simple foo 1 text foo 0 simple {"bar"} 1 text bar 0 simple x 1 text x 0 {}}
test parse-5.8 {Tcl_ParseCommand procedure, junk after close brace} {
list [catch {testparser {foo {bar}x} 0} msg] $msg $errorInfo
} {1 {extra characters after close-brace} {extra characters after close-brace
(remainder of script: "x")
invoked from within
"testparser {foo {bar}x} 0"}}
test parse-5.9 {Tcl_ParseCommand procedure, backslash-newline after close brace} {
testparser "foo {bar}\\\nx" 0
} {- foo\ \{bar\}\\\nx 3 simple foo 1 text foo 0 simple {{bar}} 1 text bar 0 simple x 1 text x 0 {}}
test parse-5.10 {Tcl_ParseCommand procedure, multiple deletion of non-static buffer} {
# This test is designed to catch bug 1681.
list [catch {testparser "a \"\\1\\2\\3\\4\\5\\6\\7\\8\\9\\1\\2\\3\\4\\5\\6\\7\\8" 0} msg] $msg $errorInfo
} "1 {missing \"} {missing \"
(remainder of script: \"\"\\1\\2\\3\\4\\5\\6\\7\\8\\9\\1\\2\\3\\4\\5\\6\\7\\8\")
invoked from within
\"testparser \"a \\\"\\\\1\\\\2\\\\3\\\\4\\\\5\\\\6\\\\7\\\\8\\\\9\\\\1\\\\2\\\\3\\\\4\\\\5\\\\6\\\\7\\\\8\" 0\"}"
test parse-6.1 {ParseTokens procedure, empty word} {
testparser {""} 0
} {- {""} 1 simple {""} 1 text {} 0 {}}
test parse-6.2 {ParseTokens procedure, simple range} {
testparser {"abc$x.e"} 0
} {- {"abc$x.e"} 1 word {"abc$x.e"} 4 text abc 0 variable {$x} 1 text x 0 text .e 0 {}}
test parse-6.3 {ParseTokens procedure, variable reference} {
testparser {abc$x.e $y(z)} 0
} {- {abc$x.e $y(z)} 2 word {abc$x.e} 4 text abc 0 variable {$x} 1 text x 0 text .e 0 word {$y(z)} 3 variable {$y(z)} 2 text y 0 text z 0 {}}
test parse-6.4 {ParseTokens procedure, variable reference} {
list [catch {testparser {$x([a )} 0} msg] $msg
} {1 {missing close-bracket}}
test parse-6.5 {ParseTokens procedure, command substitution} {
testparser {[foo $x bar]z} 0
} {- {[foo $x bar]z} 1 word {[foo $x bar]z} 2 command {[foo $x bar]} 0 text z 0 {}}
test parse-6.6 {ParseTokens procedure, command substitution} {
testparser {[foo \] [a b]]} 0
} {- {[foo \] [a b]]} 1 word {[foo \] [a b]]} 1 command {[foo \] [a b]]} 0 {}}
test parse-6.7 {ParseTokens procedure, error in command substitution} {
list [catch {testparser {a [b {}c d] e} 0} msg] $msg $errorInfo
} {1 {extra characters after close-brace} {extra characters after close-brace
(remainder of script: "c d] e")
invoked from within
"testparser {a [b {}c d] e} 0"}}
test parse-6.8 {ParseTokens procedure, error in command substitution} {
info complete {a [b {}c d]}
} {1}
test parse-6.9 {ParseTokens procedure, error in command substitution} {
info complete {a [b "c d}
} {0}
test parse-6.10 {ParseTokens procedure, incomplete sub-command} {
info complete {puts [
expr 1+1
#this is a comment ]}
} {0}
test parse-6.11 {ParseTokens procedure, memory allocation for big nested command} {
testparser {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0
} {- {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 word {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 command {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0 {}}
test parse-6.12 {ParseTokens procedure, missing close bracket} {
list [catch {testparser {[foo $x bar} 0} msg] $msg $errorInfo
} {1 {missing close-bracket} {missing close-bracket
(remainder of script: "[foo $x bar")
invoked from within
"testparser {[foo $x bar} 0"}}
test parse-6.13 {ParseTokens procedure, backslash-newline without continuation line} {
list [catch {testparser "\"a b\\\n" 0} msg] $msg $errorInfo
} {1 {missing "} missing\ \"\n\ \ \ \ (remainder\ of\ script:\ \"\"a\ b\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\"a\ b\\\\\\n\"\ 0\"}
test parse-6.14 {ParseTokens procedure, backslash-newline} {
testparser "b\\\nc" 0
} {- b\\\nc 2 simple b 1 text b 0 simple c 1 text c 0 {}}
test parse-6.15 {ParseTokens procedure, backslash-newline} {
testparser "\"b\\\nc\"" 0
} {- \"b\\\nc\" 1 word \"b\\\nc\" 3 text b 0 backslash \\\n 0 text c 0 {}}
test parse-6.16 {ParseTokens procedure, backslash substitution} {
testparser {\n\a\x7f} 0
} {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}}
test parse-6.17 {ParseTokens procedure, null characters} {
testparser [bytestring "foo\0zz"] 0
} "- [bytestring foo\0zz] 1 word [bytestring foo\0zz] 3 text foo 0 text [bytestring \0] 0 text zz 0 {}"
test parse-6.18 {ParseTokens procedure, seek past numBytes for close-bracket} {
# Test for Bug 681841
list [catch {testparser {[a]} 2} msg] $msg
} {1 {missing close-bracket}}
test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} {
testparser {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 0
} {- {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 16 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 {}}
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
test parse-8.1 {Tcl_EvalObjv procedure} testevalobjv {
testevalobjv 0 concat this is a test
} {this is a test}
test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} testevalobjv {
rename unknown unknown.old
set x [catch {testevalobjv 10 asdf poiu} msg]
rename unknown.old unknown
list $x $msg
} {1 {invalid command name "asdf"}}
test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} testevalobjv {
rename unknown unknown.old
proc unknown args {
return "unknown $args"
}
set x [catch {testevalobjv 0 asdf poiu} msg]
rename unknown {}
rename unknown.old unknown
list $x $msg
} {0 {unknown asdf poiu}}
test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} testevalobjv {
rename unknown unknown.old
proc unknown args {
error "I don't like that command"
}
set x [catch {testevalobjv 0 asdf poiu} msg]
rename unknown {}
rename unknown.old unknown
list $x $msg
} {1 {I don't like that command}}
test parse-8.5 {Tcl_EvalObjv procedure, command traces} testevalobjv {
testevalobjv 0 set x 123
testcmdtrace tracetest {testevalobjv 0 set x $x}
} {{testevalobjv 0 set x $x} {testevalobjv 0 set x 123} {set x 123} {set x 123}}
test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} testevalobjv {
proc x {} {
set y 23
set z [testevalobjv 1 set y]
return [list $z $y]
}
catch {unset y}
set y 16
x
} {16 23}
test parse-8.8 {Tcl_EvalObjv procedure, async handlers} testevalobjv {
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
return "new result"
}
set handler1 [testasync create async1]
set aresult xxx
set acode yyy
set x [list [catch [list testevalobjv 0 testasync mark $handler1 original 0] msg] $msg $acode $aresult]
testasync delete
set x
} {0 {new result} 0 original}
test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv {
list [catch {testevalobjv 0 error message} msg] $msg
} {1 message}
test parse-8.10 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL} testevalobjv {
rename ::unknown unknown.save
proc ::unknown args {lappend ::info [info level]}
catch {rename ::noSuchCommand {}}
set ::info {}
namespace eval test_ns_1 {
testevalobjv 1 noSuchCommand
uplevel #0 noSuchCommand
}
namespace delete test_ns_1
rename ::unknown {}
rename unknown.save ::unknown
set ::info
} {1 1}
test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv {
rename ::unknown unknown.save
proc ::unknown args {lappend ::info [info level]; uplevel 1 foo}
proc ::foo args {lappend ::info global}
catch {rename ::noSuchCommand {}}
set ::slave [interp create]
$::slave alias bar noSuchCommand
set ::info {}
namespace eval test_ns_1 {
proc foo args {lappend ::info namespace}
$::slave eval bar
testevalobjv 1 [list $::slave eval bar]
uplevel #0 [list $::slave eval bar]
}
namespace delete test_ns_1
rename ::foo {}
rename ::unknown {}
rename unknown.save ::unknown
set ::info
} [subst {[set level 2; incr level [info level]] global 1 global 1 global}]
test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} {
set ::auto_index(noSuchCommand) {
proc noSuchCommand {} {lappend ::info global}
}
set ::auto_index(::[string trimleft [namespace current]::test_ns_1::noSuchCommand :]) [list \
proc [namespace current]::test_ns_1::noSuchCommand {} {
lappend ::info ns
}]
catch {rename ::noSuchCommand {}}
set ::slave [interp create]
$::slave alias bar noSuchCommand
set ::info {}
namespace eval test_ns_1 {
$::slave eval bar
}
namespace delete test_ns_1
interp delete $::slave
catch {rename ::noSuchCommand {}}
set ::info
} global
test parse-9.1 {Tcl_LogCommandInfo, line numbers} {
catch {unset x}
list [catch {testevalex {for {} 1 {} {
# asdf
set x
}}}] $errorInfo
} {1 {can't read "x": no such variable
while executing
"set x"
("for" body line 5)
invoked from within
"for {} 1 {} {
# asdf
set x
}"
invoked from within
"testevalex {for {} 1 {} {
# asdf
set x
}}"}}
test parse-9.2 {Tcl_LogCommandInfo, truncating long commands} {
list [testevalex {catch {set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee fffffffff ggggggggg}}] $errorInfo
} {1 {wrong # args: should be "set varName ?newValue?"
while executing
"set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd ee..."}}
test parse-10.1 {Tcl_EvalTokens, simple text} {
testevalex {concat test}
} {test}
test parse-10.2 {Tcl_EvalTokens, backslash sequences} {
testevalex {concat test\063\062test}
} {test32test}
test parse-10.3 {Tcl_EvalTokens, nested commands} {
testevalex {concat [expr 2 + 6]}
} {8}
test parse-10.4 {Tcl_EvalTokens, nested commands} {
catch {unset a}
list [catch {testevalex {concat xxx[expr $a]}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-10.5 {Tcl_EvalTokens, simple variables} {
set a hello
testevalex {concat $a}
} {hello}
test parse-10.6 {Tcl_EvalTokens, array variables} {
catch {unset a}
set a(12) 46
testevalex {concat $a(12)}
} {46}
test parse-10.7 {Tcl_EvalTokens, array variables} {
catch {unset a}
set a(12) 46
testevalex {concat $a(1[expr 3 - 1])}
} {46}
test parse-10.8 {Tcl_EvalTokens, array variables} {
catch {unset a}
list [catch {testevalex {concat $x($a)}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-10.9 {Tcl_EvalTokens, array variables} {
catch {unset a}
list [catch {testevalex {concat xyz$a(1)}} msg] $msg
} {1 {can't read "a(1)": no such variable}}
test parse-10.10 {Tcl_EvalTokens, object values} {
set a 123
testevalex {concat $a}
} {123}
test parse-10.11 {Tcl_EvalTokens, object values} {
set a 123
testevalex {concat $a$a$a}
} {123123123}
test parse-10.12 {Tcl_EvalTokens, object values} {
testevalex {concat [expr 2][expr 4][expr 6]}
} {246}
test parse-10.13 {Tcl_EvalTokens, string values} {
testevalex {concat {a" b"}}
} {a" b"}
test parse-10.14 {Tcl_EvalTokens, string values} {
set a 111
testevalex {concat x$a.$a.$a}
} {x111.111.111}
test parse-11.1 {Tcl_EvalEx, TCL_EVAL_GLOBAL flag} {
proc x {} {
set y 777
set z [testevalex "set y" global]
return [list $z $y]
}
catch {unset y}
set y 321
x
} {321 777}
test parse-11.2 {Tcl_EvalEx, error while parsing} {
list [catch {testevalex {concat "abc}} msg] $msg
} {1 {missing "}}
test parse-11.3 {Tcl_EvalEx, error while collecting words} {
catch {unset a}
list [catch {testevalex {concat xyz $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-11.4 {Tcl_EvalEx, error in Tcl_EvalObjv call} {
catch {unset a}
list [catch {testevalex {_bogus_ a b c d}} msg] $msg
} {1 {invalid command name "_bogus_"}}
test parse-11.5 {Tcl_EvalEx, exceptional return} {
list [catch {testevalex {break}} msg] $msg
} {3 {}}
test parse-11.6 {Tcl_EvalEx, freeing memory} {
testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z}
} {a b c d e f g h i j k l m n o p q r s t u v w x y z}
test parse-11.7 {Tcl_EvalEx, multiple commands in script} {
list [testevalex {set a b; set c d}] $a $c
} {d b d}
test parse-11.8 {Tcl_EvalEx, multiple commands in script} {
list [testevalex {
set a b
set c d
}] $a $c
} {d b d}
test parse-11.9 {Tcl_EvalEx, freeing memory after error} {
catch {unset a}
list [catch {testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-11.10 {Tcl_EvalTokens, empty commands} {
testevalex {concat xyz; }
} {xyz}
test parse-11.11 {Tcl_EvalTokens, empty commands} {
testevalex "concat abc; ; # this is a comment\n"
} {abc}
test parse-11.12 {Tcl_EvalTokens, empty commands} {
testevalex {}
} {}
test parse-12.1 {Tcl_ParseVarName procedure, initialization} {
list [catch {testparsevarname {$a([first second])} 8 0} msg] $msg
} {1 {missing close-bracket}}
test parse-12.2 {Tcl_ParseVarName procedure, initialization} {
testparsevarname {$a([first second])} 0 0
} {- {} 0 variable {$a([first second])} 2 text a 0 command {[first second]} 0 {}}
test parse-12.3 {Tcl_ParseVarName procedure, initialization} {
list [catch {testparsevarname {$abcd} 3 0} msg] $msg
} {0 {- {} 0 variable {$ab} 1 text ab 0 cd}}
test parse-12.4 {Tcl_ParseVarName procedure, initialization} {
testparsevarname {$abcd} 0 0
} {- {} 0 variable {$abcd} 1 text abcd 0 {}}
test parse-12.5 {Tcl_ParseVarName procedure, just a dollar sign} {
testparsevarname {$abcd} 1 0
} {- {} 0 text {$} 0 abcd}
test parse-12.6 {Tcl_ParseVarName procedure, braced variable name} {
testparser {${..[]b}cd} 0
} {- {${..[]b}cd} 1 word {${..[]b}cd} 3 variable {${..[]b}} 1 text {..[]b} 0 text cd 0 {}}
test parse-12.7 {Tcl_ParseVarName procedure, braced variable name} {
testparser "\$\{\{\} " 0
} {- \$\{\{\}\ 1 word \$\{\{\} 2 variable \$\{\{\} 1 text \{ 0 {}}
test parse-12.8 {Tcl_ParseVarName procedure, missing close brace} {
list [catch {testparser "$\{abc" 0} msg] $msg $errorInfo
} {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\$\\\{abc\"\ 0\"}
test parse-12.9 {Tcl_ParseVarName procedure, missing close brace} {
list [catch {testparsevarname {${bcd}} 4 0} msg] $msg
} {1 {missing close-brace for variable name}}
test parse-12.10 {Tcl_ParseVarName procedure, missing close brace} {
list [catch {testparsevarname {${bc}} 4 0} msg] $msg
} {1 {missing close-brace for variable name}}
test parse-12.11 {Tcl_ParseVarName procedure, simple variable name} {
testparser {$az_AZ.} 0
} {- {$az_AZ.} 1 word {$az_AZ.} 3 variable {$az_AZ} 1 text az_AZ 0 text . 0 {}}
test parse-12.12 {Tcl_ParseVarName procedure, simple variable name} {
testparser {$abcdefg} 4
} {- {$abc} 1 word {$abc} 2 variable {$abc} 1 text abc 0 defg}
test parse-12.13 {Tcl_ParseVarName procedure, simple variable name with ::} {
testparser {$xyz::ab:c} 0
} {- {$xyz::ab:c} 1 word {$xyz::ab:c} 3 variable {$xyz::ab} 1 text xyz::ab 0 text :c 0 {}}
test parse-12.14 {Tcl_ParseVarName procedure, variable names with many colons} {
testparser {$xyz:::::c} 0
} {- {$xyz:::::c} 1 word {$xyz:::::c} 2 variable {$xyz:::::c} 1 text xyz:::::c 0 {}}
test parse-12.15 {Tcl_ParseVarName procedure, : vs. ::} {
testparsevarname {$ab:cd} 0 0
} {- {} 0 variable {$ab} 1 text ab 0 :cd}
test parse-12.16 {Tcl_ParseVarName procedure, eof in ::} {
testparsevarname {$ab::cd} 4 0
} {- {} 0 variable {$ab} 1 text ab 0 ::cd}
test parse-12.17 {Tcl_ParseVarName procedure, eof in ::} {
testparsevarname {$ab:::cd} 5 0
} {- {} 0 variable {$ab::} 1 text ab:: 0 :cd}
test parse-12.18 {Tcl_ParseVarName procedure, no variable name} {
testparser {$$ $.} 0
} {- {$$ $.} 2 word {$$} 2 text {$} 0 text {$} 0 word {$.} 2 text {$} 0 text . 0 {}}
test parse-12.19 {Tcl_ParseVarName procedure, EOF before (} {
testparsevarname {$ab(cd)} 3 0
} {- {} 0 variable {$ab} 1 text ab 0 (cd)}
test parse-12.20 {Tcl_ParseVarName procedure, array reference} {
testparser {$x(abc)} 0
} {- {$x(abc)} 1 word {$x(abc)} 3 variable {$x(abc)} 2 text x 0 text abc 0 {}}
test parse-12.21 {Tcl_ParseVarName procedure, array reference} {
testparser {$x(ab$cde[foo bar])} 0
} {- {$x(ab$cde[foo bar])} 1 word {$x(ab$cde[foo bar])} 6 variable {$x(ab$cde[foo bar])} 5 text x 0 text ab 0 variable {$cde} 1 text cde 0 command {[foo bar]} 0 {}}
test parse-12.22 {Tcl_ParseVarName procedure, array reference} {
testparser {$x([cmd arg]zz)} 0
} {- {$x([cmd arg]zz)} 1 word {$x([cmd arg]zz)} 4 variable {$x([cmd arg]zz)} 3 text x 0 command {[cmd arg]} 0 text zz 0 {}}
test parse-12.23 {Tcl_ParseVarName procedure, missing close paren in array reference} {
list [catch {testparser {$x(poiu} 0} msg] $msg $errorInfo
} {1 {missing )} {missing )
(remainder of script: "(poiu")
invoked from within
"testparser {$x(poiu} 0"}}
test parse-12.24 {Tcl_ParseVarName procedure, missing close paren in array reference} {
list [catch {testparsevarname {$ab(cd)} 6 0} msg] $msg $errorInfo
} {1 {missing )} {missing )
(remainder of script: "(cd)")
invoked from within
"testparsevarname {$ab(cd)} 6 0"}}
test parse-12.25 {Tcl_ParseVarName procedure, nested array reference} {
testparser {$x(a$y(b$z))} 0
} {- {$x(a$y(b$z))} 1 word {$x(a$y(b$z))} 8 variable {$x(a$y(b$z))} 7 text x 0 text a 0 variable {$y(b$z)} 4 text y 0 text b 0 variable {$z} 1 text z 0 {}}
test parse-13.1 {Tcl_ParseVar procedure} {
set abc 24
testparsevar {$abc.fg}
} {24 .fg}
test parse-13.2 {Tcl_ParseVar procedure, no variable name} {
testparsevar {$}
} {{$} {}}
test parse-13.3 {Tcl_ParseVar procedure, no variable name} {
testparsevar {$.123}
} {{$} .123}
test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} {
catch {unset abc}
list [catch {testparsevar {$abc}} msg] $msg
} {1 {can't read "abc": no such variable}}
test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} {
catch {unset abc}
list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg
} {1 {invalid command name "bogus"}}
test parse-14.1 {Tcl_ParseBraces procedure, computing string length} {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-14.2 {Tcl_ParseBraces procedure, computing string length} {
testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
test parse-14.3 {Tcl_ParseBraces procedure, words in braces} {
testparser {foo {a $b [concat foo]} {c d}} 0
} {- {foo {a $b [concat foo]} {c d}} 3 simple foo 1 text foo 0 simple {{a $b [concat foo]}} 1 text {a $b [concat foo]} 0 simple {{c d}} 1 text {c d} 0 {}}
test parse-14.4 {Tcl_ParseBraces procedure, empty nested braces} {
testparser {foo {{}}} 0
} {- {foo {{}}} 2 simple foo 1 text foo 0 simple {{{}}} 1 text {{}} 0 {}}
test parse-14.5 {Tcl_ParseBraces procedure, nested braces} {
testparser {foo {{a {b} c} {} {d e}}} 0
} {- {foo {{a {b} c} {} {d e}}} 2 simple foo 1 text foo 0 simple {{{a {b} c} {} {d e}}} 1 text {{a {b} c} {} {d e}} 0 {}}
test parse-14.6 {Tcl_ParseBraces procedure, backslashes in words in braces} {
testparser "foo {a \\n\\\{}" 0
} {- {foo {a \n\{}} 2 simple foo 1 text foo 0 simple {{a \n\{}} 1 text {a \n\{} 0 {}}
test parse-14.7 {Tcl_ParseBraces procedure, missing continuation line in braces} {
list [catch {testparser "\{abc\\\n" 0} msg] $msg $errorInfo
} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\{abc\\\\\\n\"\ 0\"}
test parse-14.8 {Tcl_ParseBraces procedure, backslash-newline in braces} {
testparser "foo {\\\nx}" 0
} {- foo\ \{\\\nx\} 2 simple foo 1 text foo 0 word \{\\\nx\} 2 backslash \\\n 0 text x 0 {}}
test parse-14.9 {Tcl_ParseBraces procedure, backslash-newline in braces} {
testparser "foo {a \\\n b}" 0
} {- foo\ \{a\ \\\n\ \ \ b\} 2 simple foo 1 text foo 0 word \{a\ \\\n\ \ \ b\} 3 text {a } 0 backslash \\\n\ \ \ 0 text b 0 {}}
test parse-14.10 {Tcl_ParseBraces procedure, backslash-newline in braces} {
testparser "foo {xyz\\\n }" 0
} {- foo\ \{xyz\\\n\ \} 2 simple foo 1 text foo 0 word \{xyz\\\n\ \} 2 text xyz 0 backslash \\\n\ 0 {}}
test parse-14.11 {Tcl_ParseBraces procedure, empty braced string} {
testparser {foo {}} 0
} {- {foo {}} 2 simple foo 1 text foo 0 simple {{}} 1 text {} 0 {}}
test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} {
list [catch {testparser "foo \{xy\\\nz" 0} msg] $msg $errorInfo
} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"}
test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} {
testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
test parse-15.3 {Tcl_ParseQuotedString procedure, word is quoted string} {
testparser {foo "a b c" d "efg";} 0
} {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}}
test parse-15.4 {Tcl_ParseQuotedString procedure, garbage after quoted string} {
list [catch {testparser {foo "a b c"d} 0} msg] $msg $errorInfo
} {1 {extra characters after close-quote} {extra characters after close-quote
(remainder of script: "d")
invoked from within
"testparser {foo "a b c"d} 0"}}
test parse-15.5 {CommandComplete procedure} {
info complete ""
} 1
test parse-15.6 {CommandComplete procedure} {
info complete " \n"
} 1
test parse-15.7 {CommandComplete procedure} {
info complete "abc def"
} 1
test parse-15.8 {CommandComplete procedure} {
info complete "a b c d e f \t\n"
} 1
test parse-15.9 {CommandComplete procedure} {
info complete {a b c"d}
} 1
test parse-15.10 {CommandComplete procedure} {
info complete {a b "c d" e}
} 1
test parse-15.11 {CommandComplete procedure} {
info complete {a b "c d"}
} 1
test parse-15.12 {CommandComplete procedure} {
info complete {a b "c d"}
} 1
test parse-15.13 {CommandComplete procedure} {
info complete {a b "c d}
} 0
test parse-15.14 {CommandComplete procedure} {
info complete {a b "}
} 0
test parse-15.15 {CommandComplete procedure} {
info complete {a b "cd"xyz}
} 1
test parse-15.16 {CommandComplete procedure} {
info complete {a b "c $d() d"}
} 1
test parse-15.17 {CommandComplete procedure} {
info complete {a b "c $dd("}
} 0
test parse-15.18 {CommandComplete procedure} {
info complete {a b "c \"}
} 0
test parse-15.19 {CommandComplete procedure} {
info complete {a b "c [d e f]"}
} 1
test parse-15.20 {CommandComplete procedure} {
info complete {a b "c [d e f] g"}
} 1
test parse-15.21 {CommandComplete procedure} {
info complete {a b "c [d e f"}
} 0
test parse-15.22 {CommandComplete procedure} {
info complete {a {b c d} e}
} 1
test parse-15.23 {CommandComplete procedure} {
info complete {a {b c d}}
} 1
test parse-15.24 {CommandComplete procedure} {
info complete "a b\{c d"
} 1
test parse-15.25 {CommandComplete procedure} {
info complete "a b \{c"
} 0
test parse-15.26 {CommandComplete procedure} {
info complete "a b \{c{ }"
} 0
test parse-15.27 {CommandComplete procedure} {
info complete "a b {c d e}xxx"
} 1
test parse-15.28 {CommandComplete procedure} {
info complete "a b {c \\\{d e}xxx"
} 1
test parse-15.29 {CommandComplete procedure} {
info complete {a b [ab cd ef]}
} 1
test parse-15.30 {CommandComplete procedure} {
info complete {a b x[ab][cd][ef] gh}
} 1
test parse-15.31 {CommandComplete procedure} {
info complete {a b x[ab][cd[ef] gh}
} 0
test parse-15.32 {CommandComplete procedure} {
info complete {a b x[ gh}
} 0
test parse-15.33 {CommandComplete procedure} {
info complete {[]]]}
} 1
test parse-15.34 {CommandComplete procedure} {
info complete {abc x$yyy}
} 1
test parse-15.35 {CommandComplete procedure} {
info complete "abc x\${abc\[\\d} xyz"
} 1
test parse-15.36 {CommandComplete procedure} {
info complete "abc x\$\{ xyz"
} 0
test parse-15.37 {CommandComplete procedure} {
info complete {word $a(xyz)}
} 1
test parse-15.38 {CommandComplete procedure} {
info complete {word $a(}
} 0
test parse-15.39 {CommandComplete procedure} {
info complete "set a \\\n"
} 0
test parse-15.40 {CommandComplete procedure} {
info complete "set a \\\\\n"
} 1
test parse-15.41 {CommandComplete procedure} {
info complete "set a \\n "
} 1
test parse-15.42 {CommandComplete procedure} {
info complete "set a \\"
} 1
test parse-15.43 {CommandComplete procedure} {
info complete "foo \\\n\{"
} 0
test parse-15.44 {CommandComplete procedure} {
info complete "a\nb\n# \{\n# \{\nc\n"
} 1
test parse-15.45 {CommandComplete procedure} {
info complete "#Incomplete comment\\\n"
} 0
test parse-15.46 {CommandComplete procedure} {
info complete "#Incomplete comment\\\nBut now it's complete.\n"
} 1
test parse-15.47 {CommandComplete procedure} {
info complete "# Complete comment\\\\\n"
} 1
test parse-15.48 {CommandComplete procedure} {
info complete "abc\\\n def"
} 1
test parse-15.49 {CommandComplete procedure} {
info complete "abc\\\n "
} 1
test parse-15.50 {CommandComplete procedure} {
info complete "abc\\\n"
} 0
test parse-15.51 {CommandComplete procedure} "
info complete \"\\{abc\\}\\{\"
" 1
test parse-15.52 {CommandComplete procedure} {
info complete "\"abc\"("
} 1
test parse-15.53 {CommandComplete procedure} "
info complete \" # {\"
" 1
test parse-15.54 {CommandComplete procedure} "
info complete \"foo bar;# {\"
" 1
test parse-15.55 {CommandComplete procedure} {
info complete "set x [bytestring \0]; puts hi"
} 1
test parse-15.56 {CommandComplete procedure} {
info complete "set x [bytestring \0]; \{"
} 0
test parse-15.57 {CommandComplete procedure} {
info complete "# Comment should be complete command"
} 1
test parse-15.58 {CommandComplete procedure, memory leaks} {
info complete "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22"
} 1
test parse-15.59 {CommandComplete procedure} {
# Test for Tcl Bug 684744
info complete [encoding convertfrom identity "\x00;if 1 \{"]
} 0
test parse-16.1 {Tcl_EvalEx, check termOffset is set correctly for non TCL_OK cases, bug 2535} {
subst {[eval {return foo}]bar}
} foobar
test parse-17.1 {Correct return codes from errors during substitution} {
catch {eval {w[continue]}}
} 4
test parse-19.1 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints {
testevalex
} -setup {
interp create i
load {} Tcltest i
i eval {proc {} args {}}
interp recursionlimit i 3
} -body {
i eval {testevalex {[]}}
} -cleanup {
interp delete i
}
test parse-19.2 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints {
testevalex
} -setup {
interp create i
load {} Tcltest i
i eval {proc {} args {}}
interp recursionlimit i 3
} -body {
i eval {testevalex {[[]]}}
} -cleanup {
interp delete i
} -returnCodes error -match glob -result {too many nested*}
test parse-19.3 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup {
interp create i
i eval {proc {} args {}}
interp recursionlimit i 3
} -body {
i eval {subst {[]}}
} -cleanup {
interp delete i
}
test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup {
interp create i
i eval {proc {} args {}}
interp recursionlimit i 3
} -body {
i eval {subst {[[]]}}
} -cleanup {
interp delete i
} -returnCodes error -match glob -result {too many nested*}
test parse-20.1 {TclParseBackslash: truncated escape} {
testparser {\u12345} 1
} {- \\ 1 simple \\ 1 text \\ 0 u12345}
test parse-20.2 {TclParseBackslash: truncated escape} {
testparser {\u12345} 2
} {- {\u} 1 word {\u} 1 backslash {\u} 0 12345}
test parse-20.3 {TclParseBackslash: truncated escape} {
testparser {\u12345} 3
} {- {\u1} 1 word {\u1} 1 backslash {\u1} 0 2345}
test parse-20.4 {TclParseBackslash: truncated escape} {
testparser {\u12345} 4
} {- {\u12} 1 word {\u12} 1 backslash {\u12} 0 345}
test parse-20.5 {TclParseBackslash: truncated escape} {
testparser {\u12345} 5
} {- {\u123} 1 word {\u123} 1 backslash {\u123} 0 45}
test parse-20.6 {TclParseBackslash: truncated escape} {
testparser {\u12345} 6
} {- {\u1234} 1 word {\u1234} 1 backslash {\u1234} 0 5}
test parse-20.7 {TclParseBackslash: truncated escape} {
testparser {\u12345} 7
} {- {\u12345} 1 word {\u12345} 2 backslash {\u1234} 0 text 5 0 {}}
test parse-20.8 {TclParseBackslash: truncated escape} {
testparser {\x12X} 1
} {- \\ 1 simple \\ 1 text \\ 0 x12X}
test parse-20.9 {TclParseBackslash: truncated escape} {
testparser {\x12X} 2
} {- {\x} 1 word {\x} 1 backslash {\x} 0 12X}
test parse-20.10 {TclParseBackslash: truncated escape} {
testparser {\x12X} 3
} {- {\x1} 1 word {\x1} 1 backslash {\x1} 0 2X}
test parse-20.11 {TclParseBackslash: truncated escape} {
testparser {\x12X} 4
} {- {\x12} 1 word {\x12} 1 backslash {\x12} 0 X}
test parse-20.12 {TclParseBackslash: truncated escape} {
testparser {\x12X} 5
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
# cleanup
catch {unset a}
::tcltest::cleanupTests
return
tcl8.4.20/tests/compExpr.test 0000644 0036047 0045461 00000040134 11737050674 014561 0 ustar dgp 771div # This file contains a collection of tests for the procedures in the
# file tclCompExpr.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
set gotT1 0
puts "This application hasn't been compiled with the \"T1\" and"
puts "\"T2\" math functions, so I'll skip some of the expr tests."
} else {
set gotT1 1
}
catch {unset a}
test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} {
expr 1+2
} 3
test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} {
list [catch {expr 1+2+} msg] $msg
} {1 {syntax error in expression "1+2+": premature end of expression}}
test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} {
list [catch {expr "foo(123)"} msg] $msg
} {1 {unknown math function "foo"}}
test compExpr-1.4 {TclCompileExpr procedure, expr has no operators} {
set a {000123}
expr {$a}
} 83
test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} {
catch {unset a}
set a 27
expr {"foo$a" < "bar"}
} 0
test compExpr-2.2 {CompileSubExpr procedure, error compiling TCL_TOKEN_WORD parse token} {
list [catch {expr {"00[expr 1+]" + 17}} msg] $msg
} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.3 {CompileSubExpr procedure, TCL_TOKEN_TEXT parse token} {
expr {{12345}}
} 12345
test compExpr-2.4 {CompileSubExpr procedure, empty TCL_TOKEN_TEXT parse token} {
expr {{}}
} {}
test compExpr-2.5 {CompileSubExpr procedure, TCL_TOKEN_BS parse token} {
expr "\{ \\
+123 \}"
} 123
test compExpr-2.6 {CompileSubExpr procedure, TCL_TOKEN_COMMAND parse token} {
expr {[info tclversion] != ""}
} 1
test compExpr-2.7 {CompileSubExpr procedure, TCL_TOKEN_COMMAND parse token} {
expr {[]}
} {}
test compExpr-2.8 {CompileSubExpr procedure, error in TCL_TOKEN_COMMAND parse token} {
list [catch {expr {[foo "bar"xxx] + 17}} msg] $msg
} {1 {extra characters after close-quote}}
test compExpr-2.9 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} {
catch {unset a}
set a 123
expr {$a*2}
} 246
test compExpr-2.10 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} {
catch {unset a}
catch {unset b}
set a(george) martha
set b geo
expr {$a(${b}rge)}
} martha
test compExpr-2.11 {CompileSubExpr procedure, error in TCL_TOKEN_VARIABLE parse token} {
catch {unset a}
list [catch {expr {$a + 17}} msg] $msg
} {1 {can't read "a": no such variable}}
test compExpr-2.12 {CompileSubExpr procedure, TCL_TOKEN_SUB_EXPR parse token} {
expr {27||3? 3<<(1+4) : 4&&9}
} 96
test compExpr-2.13 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} {
catch {unset a}
set a 15
list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg
} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} {
expr {5*6}
} 30
test compExpr-2.15 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function found} {
format %.6g [expr {sin(2.0)}]
} 0.909297
test compExpr-2.16 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function not found} {
list [catch {expr {fred(2.0)}} msg] $msg
} {1 {unknown math function "fred"}}
test compExpr-2.17 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4*2}
} 8
test compExpr-2.18 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4/2}
} 2
test compExpr-2.19 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4%2}
} 0
test compExpr-2.20 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4<<2}
} 16
test compExpr-2.21 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4>>2}
} 1
test compExpr-2.22 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4<2}
} 0
test compExpr-2.23 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4>2}
} 1
test compExpr-2.24 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4<=2}
} 0
test compExpr-2.25 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4>=2}
} 1
test compExpr-2.26 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4==2}
} 0
test compExpr-2.27 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4!=2}
} 1
test compExpr-2.28 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4&2}
} 0
test compExpr-2.29 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4^2}
} 6
test compExpr-2.30 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
expr {4|2}
} 6
test compExpr-2.31 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, 1 operand} {
expr {!4}
} 0
test compExpr-2.32 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, 1 operand} {
expr {~4}
} -5
test compExpr-2.33 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, comparison} {
catch {unset a}
set a 15
expr {$a==15} ;# compiled out-of-line to runtime call on Tcl_ExprObjCmd
} 1
test compExpr-2.34 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
expr {+2}
} 2
test compExpr-2.35 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} {
list [catch {expr {+[expr 1+]}} msg] $msg
} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.36 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
expr {4+2}
} 6
test compExpr-2.37 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} {
list [catch {expr {[expr 1+]+5}} msg] $msg
} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.38 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} {
list [catch {expr {5+[expr 1+]}} msg] $msg
} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.39 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
expr {-2}
} -2
test compExpr-2.40 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
expr {4-2}
} 2
test compExpr-2.41 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
catch {unset a}
set a true
expr {0||$a}
} 1
test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} {
catch {unset a}
set a 15
list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg
} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
catch {unset a}
set a false
expr {3&&$a}
} 0
test compExpr-2.44 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
catch {unset a}
set a false
expr {$a||1? 1 : 0}
} 1
test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} {
catch {unset a}
set a 15
list [catch {expr {1? 54 : "$a[expr 1+]00"}} msg] $msg
} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} {
catch {unset a}
set a 2
expr {[set a]||0}
} 1
test compExpr-3.2 {CompileLandOrLorExpr procedure, nonnumeric 1st operand} {
catch {unset a}
set a no
expr {$a&&1}
} 0
test compExpr-3.3 {CompileSubExpr procedure, error in 1st operand} {
list [catch {expr {[expr *2]||0}} msg] $msg
} {1 {syntax error in expression "*2": unexpected operator *}}
test compExpr-3.4 {CompileLandOrLorExpr procedure, result is 1 or 0} {
catch {unset a}
catch {unset b}
set a no
set b true
expr {$a || $b}
} 1
test compExpr-3.5 {CompileLandOrLorExpr procedure, short-circuit semantics} {
catch {unset a}
set a yes
expr {$a || [exit]}
} 1
test compExpr-3.6 {CompileLandOrLorExpr procedure, short-circuit semantics} {
catch {unset a}
set a no
expr {$a && [exit]}
} 0
test compExpr-3.7 {CompileLandOrLorExpr procedure, numeric 2nd operand} {
catch {unset a}
set a 2
expr {0||[set a]}
} 1
test compExpr-3.8 {CompileLandOrLorExpr procedure, nonnumeric 2nd operand} {
catch {unset a}
set a no
expr {1&&$a}
} 0
test compExpr-3.9 {CompileLandOrLorExpr procedure, error in 2nd operand} {
list [catch {expr {0||[expr %2]}} msg] $msg
} {1 {syntax error in expression "%2": unexpected operator %}}
test compExpr-3.10 {CompileLandOrLorExpr procedure, long lor/land arm} {
set a "abcdefghijkl"
set i 7
expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1
test compExpr-4.1 {CompileCondExpr procedure, simple test} {
catch {unset a}
set a 2
expr {($a > 1)? "ok" : "nope"}
} ok
test compExpr-4.2 {CompileCondExpr procedure, complex test, convert to numeric} {
catch {unset a}
set a no
expr {[set a]? 27 : -54}
} -54
test compExpr-4.3 {CompileCondExpr procedure, error in test} {
list [catch {expr {[expr *2]? +1 : -1}} msg] $msg
} {1 {syntax error in expression "*2": unexpected operator *}}
test compExpr-4.4 {CompileCondExpr procedure, simple "true" clause} {
catch {unset a}
set a no
expr {1? (27-2) : -54}
} 25
test compExpr-4.5 {CompileCondExpr procedure, convert "true" clause to numeric} {
catch {unset a}
set a no
expr {1? $a : -54}
} no
test compExpr-4.6 {CompileCondExpr procedure, error in "true" clause} {
list [catch {expr {1? [expr *2] : -127}} msg] $msg
} {1 {syntax error in expression "*2": unexpected operator *}}
test compExpr-4.7 {CompileCondExpr procedure, simple "false" clause} {
catch {unset a}
set a no
expr {(2-2)? -3.14159 : "nope"}
} nope
test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} {
catch {unset a}
set a 00123
expr {0? 42 : $a}
} 83
test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} {
list [catch {expr {1? 15 : [expr *2]}} msg] $msg
} {1 {syntax error in expression "*2": unexpected operator *}}
test compExpr-5.1 {CompileMathFuncCall procedure, math function found} {
format %.6g [expr atan2(1.0, 2.0)]
} 0.463648
test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} {
list [catch {expr {do_it()}} msg] $msg
} {1 {unknown math function "do_it"}}
if $gotT1 {
test compExpr-5.3 {CompileMathFuncCall: call registered math function} {
expr 3*T1()-1
} 368
test compExpr-5.4 {CompileMathFuncCall: call registered math function} {
expr T2()*3
} 1035
}
test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} {
list [catch {expr {atan2(1.0)}} msg] $msg
} {1 {too few arguments for math function}}
test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} {
format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))]
} 9.97424
test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} {
list [catch {expr {sinh(2.*)}} msg] $msg
} {1 {syntax error in expression "sinh(2.*)": unexpected close parenthesis}}
test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} {
list [catch {expr {sinh(2.0, 3.0)}} msg] $msg
} {1 {too many arguments for math function}}
test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} {
list [catch {expr {0 <= rand(5.2)}} msg] $msg
} {1 {too many arguments for math function}}
test compExpr-5.10 {error return from unbraced math func call of unknown function} -body {
expr {bogus()}
} -returnCodes error -result {unknown math function "bogus"}
test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
list [catch {expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3} msg] $msg
} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012...": extra tokens at end of expression}}
# cleanup
catch {unset a}
catch {unset b}
::tcltest::cleanupTests
return
tcl8.4.20/tests/regexp.test 0000644 0036047 0045461 00000060413 12133546540 014251 0 ustar dgp 771div # Commands covered: regexp, regsub
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {unset foo}
test regexp-1.1 {basic regexp operation} {
regexp ab*c abbbc
} 1
test regexp-1.2 {basic regexp operation} {
regexp ab*c ac
} 1
test regexp-1.3 {basic regexp operation} {
regexp ab*c ab
} 0
test regexp-1.4 {basic regexp operation} {
regexp -- -gorp abc-gorpxxx
} 1
test regexp-1.5 {basic regexp operation} {
regexp {^([^ ]*)[ ]*([^ ]*)} "" a
} 1
test regexp-1.6 {basic regexp operation} {
list [catch {regexp {} abc} msg] $msg
} {0 1}
test regexp-1.7 {regexp utf compliance} {
# if not UTF-8 aware, result is "0 1"
set foo "\u4e4eb q"
regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
list [string compare $foo $bar] [regexp 4 $bar]
} {0 0}
test regexp-2.1 {getting substrings back from regexp} {
set foo {}
list [regexp ab*c abbbbc foo] $foo
} {1 abbbbc}
test regexp-2.2 {getting substrings back from regexp} {
set foo {}
set f2 {}
list [regexp a(b*)c abbbbc foo f2] $foo $f2
} {1 abbbbc bbbb}
test regexp-2.3 {getting substrings back from regexp} {
set foo {}
set f2 {}
list [regexp a(b*)(c) abbbbc foo f2] $foo $f2
} {1 abbbbc bbbb}
test regexp-2.4 {getting substrings back from regexp} {
set foo {}
set f2 {}
set f3 {}
list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
} {1 abbbbc bbbb c}
test regexp-2.5 {getting substrings back from regexp} {
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
set f6 {}; set f7 {}; set f8 {}; set f9 {}; set fa {}; set fb {};
list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*)(a*)(b*) \
12223345556789999aabbb \
foo f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb] $foo $f1 $f2 $f3 $f4 $f5 \
$f6 $f7 $f8 $f9 $fa $fb
} {1 12223345556789999aabbb 1 222 33 4 555 6 7 8 9999 aa bbb}
test regexp-2.6 {getting substrings back from regexp} {
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 a a {} {}}
test regexp-2.7 {getting substrings back from regexp} {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 ac a {} c}
test regexp-2.8 {getting substrings back from regexp} {
set match {}
list [regexp {^a*b} aaaab match] $match
} {1 aaaab}
test regexp-2.9 {getting substrings back from regexp} {
set foo {}
set f2 {}
list [regexp f\352te(b*)c f\352tebbbbc foo f2] $foo $f2
} [list 1 f\352tebbbbc bbbb]
test regexp-2.10 {getting substrings back from regexp} {
set foo {}
set f2 {}
list [regexp f\352te(b*)c eff\352tebbbbc foo f2] $foo $f2
} [list 1 f\352tebbbbc bbbb]
test regexp-3.1 {-indices option to regexp} {
set foo {}
list [regexp -indices ab*c abbbbc foo] $foo
} {1 {0 5}}
test regexp-3.2 {-indices option to regexp} {
set foo {}
set f2 {}
list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2
} {1 {0 5} {1 4}}
test regexp-3.3 {-indices option to regexp} {
set foo {}
set f2 {}
list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2
} {1 {0 5} {1 4}}
test regexp-3.4 {-indices option to regexp} {
set foo {}
set f2 {}
set f3 {}
list [regexp -indices a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
} {1 {0 5} {1 4} {5 5}}
test regexp-3.5 {-indices option to regexp} {
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
set f6 {}; set f7 {}; set f8 {}; set f9 {}
list [regexp -indices (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) \
12223345556789999 \
foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \
$f6 $f7 $f8 $f9
} {1 {0 16} {0 0} {1 3} {4 5} {6 6} {7 9} {10 10} {11 11} {12 12} {13 16}}
test regexp-3.6 {getting substrings back from regexp} {
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 {1 1} {1 1} {-1 -1} {-1 -1}}
test regexp-3.7 {getting substrings back from regexp} {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 {1 2} {1 1} {-1 -1} {2 2}}
test regexp-4.1 {-nocase option to regexp} {
regexp -nocase foo abcFOo
} 1
test regexp-4.2 {-nocase option to regexp} {
set f1 22
set f2 33
set f3 44
list [regexp -nocase {a(b*)([xy]*)z} aBbbxYXxxZ22 f1 f2 f3] $f1 $f2 $f3
} {1 aBbbxYXxxZ Bbb xYXxx}
test regexp-4.3 {-nocase option to regexp} {
regexp -nocase FOo abcFOo
} 1
set x abcdefghijklmnopqrstuvwxyz1234567890
set x $x$x$x$x$x$x$x$x$x$x$x$x
test regexp-4.4 {case conversion in regexp} {
list [regexp -nocase $x $x foo] $foo
} "1 $x"
catch {unset x}
test regexp-5.1 {exercise cache of compiled expressions} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*a bbba
} 1
test regexp-5.2 {exercise cache of compiled expressions} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*b xxxb
} 1
test regexp-5.3 {exercise cache of compiled expressions} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*c yyyc
} 1
test regexp-5.4 {exercise cache of compiled expressions} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*d 1d
} 1
test regexp-5.5 {exercise cache of compiled expressions} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*e xe
} 1
test regexp-6.1 {regexp errors} {
list [catch {regexp a} msg] $msg
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
test regexp-6.2 {regexp errors} {
list [catch {regexp -nocase a} msg] $msg
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
test regexp-6.3 {regexp errors} {
list [catch {regexp -gorp a} msg] $msg
} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-6.4 {regexp errors} {
list [catch {regexp a( b} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-6.5 {regexp errors} {
list [catch {regexp a( b} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-6.6 {regexp errors} {
list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
} {0 1}
test regexp-6.7 {regexp errors} {
list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
} {0 0}
test regexp-6.8 {regexp errors} {
catch {unset f1}
set f1 44
list [catch {regexp abc abc f1(f2)} msg] $msg
} {1 {couldn't set variable "f1(f2)"}}
test regexp-6.9 {regexp errors, -start bad int check} {
list [catch {regexp -start bogus {^$} {}} msg] $msg
} {1 {expected integer but got "bogus"}}
test regexp-7.1 {basic regsub operation} {
list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
} {1 xax111aaa222xaa}
test regexp-7.2 {basic regsub operation} {
list [regsub aa+ aaaxaa &111 foo] $foo
} {1 aaa111xaa}
test regexp-7.3 {basic regsub operation} {
list [regsub aa+ xaxaaa 111& foo] $foo
} {1 xax111aaa}
test regexp-7.4 {basic regsub operation} {
list [regsub aa+ aaa 11&2&333 foo] $foo
} {1 11aaa2aaa333}
test regexp-7.5 {basic regsub operation} {
list [regsub aa+ xaxaaaxaa &2&333 foo] $foo
} {1 xaxaaa2aaa333xaa}
test regexp-7.6 {basic regsub operation} {
list [regsub aa+ xaxaaaxaa 1&22& foo] $foo
} {1 xax1aaa22aaaxaa}
test regexp-7.7 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo
} {1 xax1aa22aaxaa}
test regexp-7.8 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo
} "1 {xax1\\aa22aaxaa}"
test regexp-7.9 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo
} "1 {xax1\\122aaxaa}"
test regexp-7.10 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo
} "1 {xax1\\aaaaaxaa}"
test regexp-7.11 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo
} {1 xax1&aaxaa}
test regexp-7.12 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo
} {1 xaxaaaaaaaaaaaaaaxaa}
test regexp-7.13 {basic regsub operation} {
set foo xxx
list [regsub abc xyz 111 foo] $foo
} {0 xyz}
test regexp-7.14 {basic regsub operation} {
set foo xxx
list [regsub ^ xyz "111 " foo] $foo
} {1 {111 xyz}}
test regexp-7.15 {basic regsub operation} {
set foo xxx
list [regsub -- -foo abc-foodef "111 " foo] $foo
} {1 {abc111 def}}
test regexp-7.16 {basic regsub operation} {
set foo xxx
list [regsub x "" y foo] $foo
} {0 {}}
test regexp-7.17 {regsub utf compliance} {
# if not UTF-8 aware, result is "0 1"
set foo "xyz555ijka\u4e4ebpqr"
regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
list [string compare $foo $bar] [regexp 4 $bar]
} {0 0}
test regexp-8.1 {case conversion in regsub} {
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
} {1 xaAAaAAay}
test regexp-8.2 {case conversion in regsub} {
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
} {1 xaAAaAAay}
test regexp-8.3 {case conversion in regsub} {
set foo 123
list [regsub a(a+) xaAAaAAay & foo] $foo
} {0 xaAAaAAay}
test regexp-8.4 {case conversion in regsub} {
set foo 123
list [regsub -nocase a CaDE b foo] $foo
} {1 CbDE}
test regexp-8.5 {case conversion in regsub} {
set foo 123
list [regsub -nocase XYZ CxYzD b foo] $foo
} {1 CbD}
test regexp-8.6 {case conversion in regsub} {
set x abcdefghijklmnopqrstuvwxyz1234567890
set x $x$x$x$x$x$x$x$x$x$x$x$x
set foo 123
list [regsub -nocase $x $x b foo] $foo
} {1 b}
test regexp-9.1 {-all option to regsub} {
set foo 86
list [regsub -all x+ axxxbxxcxdx |&| foo] $foo
} {4 a|xxx|b|xx|c|x|d|x|}
test regexp-9.2 {-all option to regsub} {
set foo 86
list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo
} {4 a|XxX|b|xx|c|X|d|x|}
test regexp-9.3 {-all option to regsub} {
set foo 86
list [regsub x+ axxxbxxcxdx |&| foo] $foo
} {1 a|xxx|bxxcxdx}
test regexp-9.4 {-all option to regsub} {
set foo 86
list [regsub -all bc axxxbxxcxdx |&| foo] $foo
} {0 axxxbxxcxdx}
test regexp-9.5 {-all option to regsub} {
set foo xxx
list [regsub -all node "node node more" yy foo] $foo
} {2 {yy yy more}}
test regexp-9.6 {-all option to regsub} {
set foo xxx
list [regsub -all ^ xxx 123 foo] $foo
} {1 123xxx}
test regexp-10.1 {expanded syntax in regsub} {
set foo xxx
list [regsub -expanded ". \#comment\n . \#comment2" abc def foo] $foo
} {1 defc}
test regexp-10.2 {newline sensitivity in regsub} {
set foo xxx
list [regsub -line {^a.*b$} "dabc\naxyb\n" 123 foo] $foo
} "1 {dabc\n123\n}"
test regexp-10.3 {newline sensitivity in regsub} {
set foo xxx
list [regsub -line {^a.*b$} "dabc\naxyb\nxb" 123 foo] $foo
} "1 {dabc\n123\nxb}"
test regexp-10.4 {partial newline sensitivity in regsub} {
set foo xxx
list [regsub -lineanchor {^a.*b$} "da\naxyb\nxb" 123 foo] $foo
} "1 {da\n123}"
test regexp-10.5 {inverse partial newline sensitivity in regsub} {
set foo xxx
list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
} "1 {da\nb123\nxb}"
test regexp-11.1 {regsub errors} {
list [catch {regsub a b} msg] $msg
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.2 {regsub errors} {
list [catch {regsub -nocase a b} msg] $msg
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.3 {regsub errors} {
list [catch {regsub -nocase -all a b} msg] $msg
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.4 {regsub errors} {
list [catch {regsub a b c d e f} msg] $msg
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
list [catch {regsub -gorp a b c} msg] $msg
} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexp-11.6 {regsub errors} {
list [catch {regsub -nocase a( b c d} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-11.7 {regsub errors} {
catch {unset f1}
set f1 44
list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
} {1 {couldn't set variable "f1(f2)"}}
test regexp-11.8 {regsub errors, -start bad int check} {
list [catch {regsub -start bogus pattern string rep var} msg] $msg
} {1 {expected integer but got "bogus"}}
test regexp-11.9 {regsub without final variable name returns value} {
regsub b abaca X
} {aXaca}
test regexp-11.10 {regsub without final variable name returns value} {
regsub -all a abaca X
} {XbXcX}
test regexp-11.11 {regsub without final variable name returns value} {
regsub b(.*?)d abcdeabcfde {,&,\1,}
} {a,bcd,c,eabcfde}
test regexp-11.12 {regsub without final variable name returns value} {
regsub -all b(.*?)d abcdeabcfde {,&,\1,}
} {a,bcd,c,ea,bcfd,cf,e}
# This test crashes on the Mac unless you increase the Stack Space to about 1
# Meg. This is probably bigger than most users want...
# 8.2.3 regexp reduced stack space requirements, but this should be
# tested again
test regexp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} {
list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all a b c d e f g h i j k l m n o p q r s t u v w x y z] $all $a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s $t $u $v $w $x $y $z
} {1 abcdefghijklmnopqrstuvwxyz a b c d e f g h i j k l m n o p q r s t u v w x y z}
test regexp-13.1 {regsub of a very large string} {
# This test is designed to stress the memory subsystem in order
# to catch Bug #933. It only fails if the Tcl memory allocator
# is in use.
set line {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE}
set filedata [string repeat $line 200]
for {set i 1} {$i<10} {incr i} {
regsub -all "BEGIN_TABLE " $filedata "" newfiledata
}
set x done
} {done}
test regexp-14.1 {CompileRegexp: regexp cache} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
set x .
append x *a
regexp $x bbba
} 1
test regexp-14.2 {CompileRegexp: regexp cache, different flags} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
set x .
append x *a
regexp -nocase $x bbba
} 1
testConstraint exec [llength [info commands exec]]
test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -constraints {
exec
} -setup {
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
test regexp-15.1 {regexp -start} {
catch {unset x}
list [regexp -start -10 {\d} 1abc2de3 x] $x
} {1 1}
test regexp-15.2 {regexp -start} {
catch {unset x}
list [regexp -start 2 {\d} 1abc2de3 x] $x
} {1 2}
test regexp-15.3 {regexp -start} {
catch {unset x}
list [regexp -start 4 {\d} 1abc2de3 x] $x
} {1 2}
test regexp-15.4 {regexp -start} {
catch {unset x}
list [regexp -start 5 {\d} 1abc2de3 x] $x
} {1 3}
test regexp-15.5 {regexp -start, over end of string} {
catch {unset x}
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexp-15.6 {regexp -start, loss of ^$ behavior} {
list [regexp -start 2 {^$} {}]
} {0}
test regexp-16.1 {regsub -start} {
catch {unset x}
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} {4 a1b/2c/3d/4e/5}
test regexp-16.2 {regsub -start} {
catch {unset x}
list [regsub -all -start -25 {z} hello {/&} x] $x
} {0 hello}
test regexp-16.3 {regsub -start} {
catch {unset x}
list [regsub -all -start 3 {z} hello {/&} x] $x
} {0 hello}
test regexp-16.4 {regsub -start, \A behavior} {
set out {}
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
} {5 /a/b/c/d/e 3 ab/c/d/e}
test regexp-17.1 {regexp -inline} {
regexp -inline b ababa
} {b}
test regexp-17.2 {regexp -inline} {
regexp -inline (b) ababa
} {b b}
test regexp-17.3 {regexp -inline -indices} {
regexp -inline -indices (b) ababa
} {{1 1} {1 1}}
test regexp-17.4 {regexp -inline} {
regexp -inline {\w(\d+)\w} " hello 23 there456def "
} {e456d 456}
test regexp-17.5 {regexp -inline no matches} {
regexp -inline {\w(\d+)\w} ""
} {}
test regexp-17.6 {regexp -inline no matches} {
regexp -inline hello goodbye
} {}
test regexp-17.7 {regexp -inline, no matchvars allowed} {
list [catch {regexp -inline b abc match} msg] $msg
} {1 {regexp match variables not allowed when using -inline}}
test regexp-18.1 {regexp -all} {
regexp -all b bbbbb
} {5}
test regexp-18.2 {regexp -all} {
regexp -all b abababbabaaaaaaaaaab
} {6}
test regexp-18.3 {regexp -all -inline} {
regexp -all -inline b abababbabaaaaaaaaaab
} {b b b b b b}
test regexp-18.4 {regexp -all -inline} {
regexp -all -inline {\w(\w)} abcdefg
} {ab b cd d ef f}
test regexp-18.5 {regexp -all -inline} {
regexp -all -inline {\w(\w)$} abcdefg
} {fg g}
test regexp-18.6 {regexp -all -inline} {
regexp -all -inline {\d+} 10:20:30:40
} {10 20 30 40}
test regexp-18.7 {regexp -all -inline} {
list [catch {regexp -all -inline b abc match} msg] $msg
} {1 {regexp match variables not allowed when using -inline}}
test regexp-18.8 {regexp -all} {
# This should not cause an infinite loop
regexp -all -inline {a*} a
} {a}
test regexp-18.9 {regexp -all} {
# Yes, the expected result is {a {}}. Here's why:
# Start at index 0; a* matches the "a" there then stops.
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
# that a* matches zero or more "a"'s; thus it matches the string "b", as
# there are zero or more "a"'s there.
# Go to index 2; this is past the end of the string, so stop.
regexp -all -inline {a*} ab
} {a {}}
test regexp-18.10 {regexp -all} {
# Yes, the expected result is {a {} a}. Here's why:
# Start at index 0; a* matches the "a" there then stops.
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
# that a* matches zero or more "a"'s; thus it matches the string "b", as
# there are zero or more "a"'s there.
# Go to index 2; a* matches the "a" there then stops.
# Go to index 3; this is past the end of the string, so stop.
regexp -all -inline {a*} aba
} {a {} a}
test regexp-18.11 {regexp -all} {
regexp -all -inline {^a} aaaa
} {a}
test regexp-18.12 {regexp -all -inline -indices} {
regexp -all -inline -indices a(b(c)d|e(f)g)h abcdhaefgh
} {{0 4} {1 3} {2 2} {-1 -1} {5 9} {6 8} {-1 -1} {7 7}}
test regexp-19.1 {regsub null replacement} {
regsub -all {@} {@hel@lo@} "\0a\0" result
list $result [string length $result]
} "\0a\0hel\0a\0lo\0a\0 14"
test regexp-20.1 {regsub shared object shimmering} {
# Bug #461322
set a abcdefghijklmnopqurstuvwxyz
set b $a
set c abcdefghijklmnopqurstuvwxyz0123456789
regsub $a $c $b d
list $d [string length $d] [string bytelength $d]
} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
test regexp-20.2 {regsub shared object shimmering with -about} {
eval regexp -about abc
} {0 {}}
test regexp-21.1 {regsub works with empty string} {
regsub -- ^ {} foo
} {foo}
test regexp-21.2 {regsub works with empty string} {
regsub -- \$ {} foo
} {foo}
test regexp-21.3 {regsub works with empty string offset} {
regsub -start 0 -- ^ {} foo
} {foo}
test regexp-21.4 {regsub works with empty string offset} {
regsub -start 0 -- \$ {} foo
} {foo}
test regexp-21.5 {regsub works with empty string offset} {
regsub -start 3 -- \$ {123} foo
} {123foo}
test regexp-21.6 {regexp works with empty string} {
regexp -- ^ {}
} {1}
test regexp-21.7 {regexp works with empty string} {
regexp -start 0 -- ^ {}
} {1}
test regexp-21.8 {regexp works with empty string offset} {
regexp -start 3 -- ^ {123}
} {0}
test regexp-21.9 {regexp works with empty string offset} {
regexp -start 3 -- \$ {123}
} {1}
test regexp-21.10 {multiple matches handle newlines} {
regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n
} "foo\nfoo\nfoo\n"
test regexp-21.11 {multiple matches handle newlines} {
regsub -all -line -- ^ "a\nb\nc" \#
} "\#a\n\#b\n\#c"
test regexp-21.12 {multiple matches handle newlines} {
regsub -all -line -- ^ "\n\n" \#
} "\#\n\#\n\#"
test regexp-21.13 {multiple matches handle newlines} {
regexp -all -inline -indices -line -- ^ "a\nb\nc"
} {{0 -1} {2 1} {4 3}}
test regexp-22.1 {Bug 1810038} {
regexp ($|^X)* {}
} 1
test regexp-22.2 {regexp compile and backrefs, Bug 1857126} {
regexp -- {([bc])\1} bb
} 1
test regexp-22.3 {Bug 3604074} {
# This will hang in interps where the bug is not fixed
regexp ((((((((a)*)*)*)*)*)*)*)* a
} 1
test regexp-22.4 {Bug 3606139} -setup {
interp alias {} a {} string repeat a
} -body {
# This crashes in interps where the bug is not fixed
regexp [join [list [a 160]([a 55])[a 668]([a 55])[a 669]([a 55]) \
[a 668]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \
[a 672]([a 55])[a 669]([a 55])[a 671]([a 55])[a 671]([a 55]) \
[a 672]([a 55])[a 652]([a 55])[a 672]([a 55])[a 671]([a 55]) \
[a 671]([a 55])[a 671]([a 55])[a 653]([a 55])[a 672]([a 55]) \
[a 653]([a 55])[a 672]([a 55])[a 672]([a 55])[a 652]([a 55]) \
[a 671]([a 55])[a 652]([a 55])[a 652]([a 55])[a 672]([a 55]) \
[a 672]([a 55])[a 672]([a 55])[a 653]([a 55])[a 671]([a 55]) \
[a 669]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \
[a 668]([a 55])[a 650]([a 55])[a 650]([a 55])[a 672]([a 55]) \
[a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
[a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \
[a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 672]([a 55]) \
[a 670]([a 55])[a 671]([a 55])[a 672]([a 55])[a 672]([a 55]) \
[a 671]([a 55])[a 671]([a 55])[a 672]([a 55])[a 669]([a 55]) \
[a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \
[a 669]([a 55])[a 668]([a 55])[a 669]([a 55])[a 669]([a 55]) \
[a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \
[a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 669]([a 55]) \
[a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \
[a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \
[a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
[a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
[a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 710]([a 55]) \
[a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
[a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
[a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 669]([a 55]) \
[a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \
[a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
[a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 668]([a 55]) \
[a 667]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \
[a 671]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
[a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
[a 668]([a 55])[a 710]([a 55])[a 668]([a 55])[a 668]([a 55]) \
[a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 511]] {}] a
} -cleanup {
rename a {}
} -returnCodes 1 -result {couldn't compile regular expression pattern: nfa has too many states}
test regexp-22.5 {Bug 3610026} -setup {
set e {}
set cp 99
while {$cp < 32864} {
append e [format %c [incr cp]]
}
} -body {
regexp -about $e
} -cleanup {
unset -nocomplain e cp
} -returnCodes error -match glob -result {*too many colors*}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/unixFCmd.test 0000644 0036047 0045461 00000025775 11737050674 014517 0 ustar dgp 771div # This file tests the tclUnixFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# 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.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
# Several tests require need to match results against the unix username
set user {}
if {$tcl_platform(platform) == "unix"} {
catch {set user [exec whoami]}
if {$user == ""} {
catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
}
if {$user == ""} {
set user "root"
}
}
proc openup {path} {
testchmod 777 $path
if {[file isdirectory $path]} {
catch {
foreach p [glob -directory $path *] {
openup $p
}
}
}
}
proc cleanup {args} {
foreach p ". $args" {
set x ""
catch {
set x [glob -directory $p tf* td*]
}
foreach file $x {
if {[catch {file delete -force -- $file}]} {
openup $file
file delete -force -- $file
}
}
}
}
test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} {
cleanup
file mkdir td1/td2/td3
file attributes td1/td2 -permissions 0000
set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg]
file attributes td1/td2 -permissions 0755
set msg
} {1 {error renaming "td1/td2/td3": permission denied}}
test unixFCmd-1.2 {TclpRenameFile: EEXIST} {unixOnly notRoot} {
cleanup
file mkdir td1/td2
file mkdir td2
list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2" to "td1/td2": file already exists}}
test unixFCmd-1.3 {TclpRenameFile: EINVAL} {unixOnly notRoot} {
cleanup
file mkdir td1
list [catch {file rename td1 td1} msg] $msg
} {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}}
test unixFCmd-1.4 {TclpRenameFile: EISDIR} {emptyTest unixOnly notRoot} {
# can't make it happen
} {}
test unixFCmd-1.5 {TclpRenameFile: ENOENT} {unixOnly notRoot} {
cleanup
file mkdir td1
list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2": no such file or directory}}
test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {emptyTest unixOnly notRoot} {
# can't make it happen
} {}
test unixFCmd-1.7 {TclpRenameFile: EXDEV} {unixOnly notRoot} {
cleanup
file mkdir foo/bar
file attr foo -perm 040555
set catchResult [catch {file rename foo/bar /tmp} msg]
set msg [lindex [split $msg :] end]
catch {file delete /tmp/bar}
catch {file attr foo -perm 040777}
catch {file delete -force foo}
list $catchResult $msg
} {1 { permission denied}}
test unixFCmd-1.8 {Checking EINTR Bug} {unixOnly notRoot nonPortable} {
testalarm
after 2000
list [testgotsig] [testgotsig]
} {1 0}
test unixFCmd-1.9 {Checking EINTR Bug} {unixOnly notRoot nonPortable} {
cleanup
set f [open tfalarm w]
puts $f {
after 2000
puts "hello world"
exit 0
}
close $f
testalarm
set pipe [open "|[info nameofexecutable] tfalarm" r+]
set line [read $pipe 1]
catch {close $pipe}
list $line [testgotsig]
} {h 1}
test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \
{unixOnly notRoot} {
cleanup
close [open tf1 a]
close [open tf2 a]
file copy -force tf1 tf2
} {}
test unixFCmd-2.2.1 {TclpCopyFile: src is symlink} {unixOnly notRoot dontCopyLinks} {
# copying links should end up with real files
cleanup
close [open tf1 a]
file link -symbolic tf2 tf1
file copy tf2 tf3
file type tf3
} {file}
test unixFCmd-2.2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} {
# copying links should end up with the links copied
cleanup
close [open tf1 a]
file link -symbolic tf2 tf1
file copy tf2 tf3
file type tf3
} {link}
test unixFCmd-2.3 {TclpCopyFile: src is block} {unixOnly notRoot} {
cleanup
set null "/dev/null"
while {[file type $null] != "characterSpecial"} {
set null [file join [file dirname $null] [file readlink $null]]
}
# file copy $null tf1
} {}
test unixFCmd-2.4 {TclpCopyFile: src is fifo} {unixOnly notRoot} {
cleanup
if [catch {exec mknod tf1 p}] {
list 1
} else {
file copy tf1 tf2
expr {"[file type tf1]" == "[file type tf2]"}
}
} {1}
test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} {
cleanup
close [open tf1 a]
file attributes tf1 -permissions 0472
file copy tf1 tf2
file attributes tf2 -permissions
} 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-
test unixFCmd-3.1 {CopyFile not done} {emptyTest unixOnly notRoot} {
} {}
test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unixOnly notRoot} {
} {}
test unixFCmd-5.1 {TclpCreateDirectory not done} {emptyTest unixOnly notRoot} {
} {}
test unixFCmd-6.1 {TclpCopyDirectory not done} {emptyTest unixOnly notRoot} {
} {}
test unixFCmd-7.1 {TclpRemoveDirectory not done} {emptyTest unixOnly notRoot} {
} {}
test unixFCmd-8.1 {TraverseUnixTree not done} {emptyTest unixOnly notRoot} {
} {}
test unixFCmd-9.1 {TraversalCopy not done} {emptyTest unixOnly notRoot} {
} {}
test unixFCmd-10.1 {TraversalDelete not done} {emptyTest unixOnly notRoot} {
} {}
test unixFCmd-11.1 {CopyFileAttrs not done} {emptyTest unixOnly notRoot} {
} {}
test unixFCmd-12.1 {GetGroupAttribute - file not found} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
list [catch {file attributes foo.test -group} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-12.2 {GetGroupAttribute - file found} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attributes foo.test -group}] [file delete -force -- foo.test]
} {0 {}}
test unixFCmd-13.1 {GetOwnerAttribute - file not found} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
list [catch {file attributes foo.test -group} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-13.2 {GetOwnerAttribute} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attributes foo.test -owner} msg] \
[string compare $msg $user] [file delete -force -- foo.test]
} {0 0 {}}
test unixFCmd-14.1 {GetPermissionsAttribute - file not found} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
list [catch {file attributes foo.test -permissions} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-14.2 {GetPermissionsAttribute} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attribute foo.test -permissions}] \
[file delete -force -- foo.test]
} {0 {}}
# Find a group that exists on this system, or else skip tests that require
# groups
set ::tcltest::testConstraints(foundGroup) 0
if {$tcl_platform(platform) == "unix"} {
catch {
set groupList [exec groups]
set group [lindex $groupList 0]
set ::tcltest::testConstraints(foundGroup) 1
}
}
#groups hard to test
test unixFCmd-15.1 {SetGroupAttribute - invalid group} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
list [catch {file attributes foo.test -group foozzz} msg] \
$msg [file delete -force -- foo.test]
} {1 {could not set group for file "foo.test": group "foozzz" does not exist} {}}
test unixFCmd-15.2 {SetGroupAttribute - invalid file} \
{unixOnly notRoot foundGroup} {
catch {file delete -force -- foo.test}
list [catch {file attributes foo.test -group $group} msg] $msg
} {1 {could not set group for file "foo.test": no such file or directory}}
#changing owners hard to do
test unixFCmd-16.1 {SetOwnerAttribute - current owner} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attributes foo.test -owner $user} msg] \
$msg [string compare [file attributes foo.test -owner] $user] \
[file delete -force -- foo.test]
} {0 {} 0 {}}
test unixFCmd-16.2 {SetOwnerAttribute - invalid file} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
list [catch {file attributes foo.test -owner $user} msg] $msg
} {1 {could not set owner for file "foo.test": no such file or directory}}
test unixFCmd-16.3 {SetOwnerAttribute - invalid owner} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
list [catch {file attributes foo.test -owner foozzz} msg] $msg
} {1 {could not set owner for file "foo.test": user "foozzz" does not exist}}
test unixFCmd-17.1 {SetPermissionsAttribute} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attributes foo.test -permissions 0000} msg] \
$msg [file attributes foo.test -permissions] \
[file delete -force -- foo.test]
} {0 {} 00000 {}}
test unixFCmd-17.2 {SetPermissionsAttribute} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
list [catch {file attributes foo.test -permissions 0000} msg] $msg
} {1 {could not set permissions for file "foo.test": no such file or directory}}
test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attributes foo.test -permissions foo} msg] $msg \
[file delete -force -- foo.test]
} {1 {unknown permission string format "foo"} {}}
test unixFCmd-17.4 {SetPermissionsAttribute} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attributes foo.test -permissions ---rwx} msg] $msg \
[file delete -force -- foo.test]
} {1 {unknown permission string format "---rwx"} {}}
close [open foo.test w]
set ::i 4
proc permcheck {testnum permstr expected} {
test $testnum {SetPermissionsAttribute} {unixOnly notRoot} {
file attributes foo.test -permissions $permstr
file attributes foo.test -permissions
} $expected
}
permcheck unixFCmd-17.5 rwxrwxrwx 00777
permcheck unixFCmd-17.6 r--r---w- 00442
permcheck unixFCmd-17.7 0 00000
permcheck unixFCmd-17.8 u+rwx,g+r 00740
permcheck unixFCmd-17.9 u-w 00540
permcheck unixFCmd-17.10 o+rwx 00547
permcheck unixFCmd-17.11 --x--x--x 00111
permcheck unixFCmd-17.12 a+rwx 00777
file delete -force -- foo.test
test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} {
# This test is nonportable because SunOS generates a weird error
# message when the current directory isn't readable.
set cd [pwd]
set nd $cd/tstdir
file mkdir $nd
cd $nd
file attributes $nd -permissions 0000
set r [list [catch {pwd} res] [string range $res 0 36]];
cd $cd;
file attributes $nd -permissions 0755
file delete $nd
set r
} {1 {error getting working directory name:}}
# cleanup
cleanup
cd $oldcwd
::tcltest::cleanupTests
return
tcl8.4.20/tests/dstring.test 0000644 0036047 0045461 00000017107 11737050674 014442 0 ustar dgp 771div # Commands covered: none
#
# This file contains a collection of tests for Tcl's dynamic string
# library procedures. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {[info commands testdstring] == {}} {
puts "This application hasn't been compiled with the \"testdstring\""
puts "command, so I can't test Tcl_DStringAppend et al."
::tcltest::cleanupTests
return
}
test dstring-1.1 {appending and retrieving} {
testdstring free
testdstring append "abc" -1
list [testdstring get] [testdstring length]
} {abc 3}
test dstring-1.2 {appending and retrieving} {
testdstring free
testdstring append "abc" -1
testdstring append " xyzzy" 3
testdstring append " 12345" -1
list [testdstring get] [testdstring length]
} {{abc xy 12345} 12}
test dstring-1.3 {appending and retrieving} {
testdstring free
foreach l {a b c d e f g h i j k l m n o p} {
testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1
}
list [testdstring get] [testdstring length]
} {{aaaaaaaaaaaaaaaaaaaaa
bbbbbbbbbbbbbbbbbbbbb
ccccccccccccccccccccc
ddddddddddddddddddddd
eeeeeeeeeeeeeeeeeeeee
fffffffffffffffffffff
ggggggggggggggggggggg
hhhhhhhhhhhhhhhhhhhhh
iiiiiiiiiiiiiiiiiiiii
jjjjjjjjjjjjjjjjjjjjj
kkkkkkkkkkkkkkkkkkkkk
lllllllllllllllllllll
mmmmmmmmmmmmmmmmmmmmm
nnnnnnnnnnnnnnnnnnnnn
ooooooooooooooooooooo
ppppppppppppppppppppp
} 352}
test dstring-2.1 {appending list elements} {
testdstring free
testdstring element "abc"
testdstring element "d e f"
list [testdstring get] [testdstring length]
} {{abc {d e f}} 11}
test dstring-2.2 {appending list elements} {
testdstring free
testdstring element "x"
testdstring element "\{"
testdstring element "ab\}"
testdstring get
} {x \{ ab\}}
test dstring-2.3 {appending list elements} {
testdstring free
foreach l {a b c d e f g h i j k l m n o p} {
testdstring element $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l
}
testdstring get
} {aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp}
test dstring-2.4 {appending list elements} {
testdstring free
testdstring append "a\{" -1
testdstring element abc
testdstring append " \{" -1
testdstring element xyzzy
testdstring get
} "a{ abc {xyzzy"
test dstring-2.5 {appending list elements} {
testdstring free
testdstring append " \{" -1
testdstring element abc
testdstring get
} " {abc"
test dstring-2.6 {appending list elements} {
testdstring free
testdstring append " " -1
testdstring element abc
testdstring get
} { abc}
test dstring-2.7 {appending list elements} {
testdstring free
testdstring append "\\ " -1
testdstring element abc
testdstring get
} "\\ abc"
test dstring-2.8 {appending list elements} {
testdstring free
testdstring append "x " -1
testdstring element abc
testdstring get
} {x abc}
test dstring-3.1 {nested sublists} {
testdstring free
testdstring start
testdstring element foo
testdstring element bar
testdstring end
testdstring element another
testdstring get
} {{foo bar} another}
test dstring-3.2 {nested sublists} {
testdstring free
testdstring start
testdstring start
testdstring element abc
testdstring element def
testdstring end
testdstring end
testdstring element ghi
testdstring get
} {{{abc def}} ghi}
test dstring-3.3 {nested sublists} {
testdstring free
testdstring start
testdstring start
testdstring start
testdstring element foo
testdstring element foo2
testdstring end
testdstring end
testdstring element foo3
testdstring end
testdstring element foo4
testdstring get
} {{{{foo foo2}} foo3} foo4}
test dstring-3.4 {nested sublists} {
testdstring free
testdstring element before
testdstring start
testdstring element during
testdstring element more
testdstring end
testdstring element last
testdstring get
} {before {during more} last}
test dstring-3.5 {nested sublists} {
testdstring free
testdstring element "\{"
testdstring start
testdstring element first
testdstring element second
testdstring end
testdstring get
} {\{ {first second}}
test dstring-4.1 {truncation} {
testdstring free
testdstring append "abcdefg" -1
testdstring trunc 3
list [testdstring get] [testdstring length]
} {abc 3}
test dstring-4.2 {truncation} {
testdstring free
testdstring append "xyzzy" -1
testdstring trunc 0
list [testdstring get] [testdstring length]
} {{} 0}
test dstring-5.1 {copying to result} {
testdstring free
testdstring append xyz -1
testdstring result
} xyz
test dstring-5.2 {copying to result} {
testdstring free
catch {unset a}
foreach l {a b c d e f g h i j k l m n o p} {
testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1
}
set a [testdstring result]
testdstring append abc -1
list $a [testdstring get]
} {{aaaaaaaaaaaaaaaaaaaaa
bbbbbbbbbbbbbbbbbbbbb
ccccccccccccccccccccc
ddddddddddddddddddddd
eeeeeeeeeeeeeeeeeeeee
fffffffffffffffffffff
ggggggggggggggggggggg
hhhhhhhhhhhhhhhhhhhhh
iiiiiiiiiiiiiiiiiiiii
jjjjjjjjjjjjjjjjjjjjj
kkkkkkkkkkkkkkkkkkkkk
lllllllllllllllllllll
mmmmmmmmmmmmmmmmmmmmm
nnnnnnnnnnnnnnnnnnnnn
ooooooooooooooooooooo
ppppppppppppppppppppp
} abc}
test dstring-6.1 {Tcl_DStringGetResult} {
testdstring free
list [testdstring gresult staticsmall] [testdstring get]
} {{} short}
test dstring-6.2 {Tcl_DStringGetResult} {
testdstring free
foreach l {a b c d e f g h i j k l m n o p} {
testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1
}
list [testdstring gresult staticsmall] [testdstring get]
} {{} short}
test dstring-6.3 {Tcl_DStringGetResult} {
set result {}
lappend result [testdstring gresult staticlarge]
testdstring append x 1
lappend result [testdstring get]
} {{} {first0 first1 first2 first3 first4 first5 first6 first7 first8 first9
second0 second1 second2 second3 second4 second5 second6 second7 second8 second9
third0 third1 third2 third3 third4 third5 third6 third7 third8 third9
fourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9
fifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9
sixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9
seventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9
x}}
test dstring-6.4 {Tcl_DStringGetResult} {
set result {}
lappend result [testdstring gresult free]
testdstring append y 1
lappend result [testdstring get]
} {{} {This is a malloc-ed stringy}}
test dstring-6.5 {Tcl_DStringGetResult} {
set result {}
lappend result [testdstring gresult special]
testdstring append z 1
lappend result [testdstring get]
} {{} {This is a specially-allocated stringz}}
# cleanup
testdstring free
::tcltest::cleanupTests
return
tcl8.4.20/tests/expr.test 0000644 0036047 0045461 00000131650 11737050674 013746 0 ustar dgp 771div # Commands covered: expr
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint registeredMathFuncs [expr {
([catch {expr T1()} msg] != 1) || ($msg ne {unknown math function "T1"})
}]
testConstraint wideIs64bit [expr {(0x80000000 > 0) && (0x8000000000000000 < 0)}]
# procedures used below
proc put_hello_char {c} {
global a
append a [format %c $c]
return $c
}
proc hello_world {} {
global a
set a ""
set L1 [set l0 [set h_1 [set q 0]]]
for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0]
:!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])]
?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3?
[incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]]
:[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2
?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]}
expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]}
}
set a
}
proc 12days {a b c} {
global xxx
expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \
[expr 1-$b] [string range $c [12days -86 0 [string range $c 1 end]] \
end]] end]]:1};expr {$a<$b?[12days [expr $a+1] $b $c]:3};expr {[12days \
-94 [expr $a-27] $c]&&$a==2?$b<13?[12days 2 [expr $b+1] "%s %d %d\n"]:9
:16}]:$a<0?$a<-72?[12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"]
:$a<-50?[string compare [format %c $b] [string index $c 0]]==0?[append \
xxx [string index $c 31];scan [string index $c 31] %c x;set x]
:[12days -65 $b [string range $c 1 end]]:[12days [expr ([string compare \
[string index $c 0] "/"]==0)+$a] $b [string range $c 1 end]]:0<$a
?[12days 2 2 "%s"]:[string compare [string index $c 0] "/"]==0||
[12days 0 [12days -61 [scan [string index $c 0] %c x; set x] \
"!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \
[string range $c 1 end]]}
}
proc do_twelve_days {} {
global xxx
set xxx ""
12days 1 1 1
string length $xxx
}
# start of tests
catch {unset a b i x}
test expr-1.1 {TclCompileExprCmd: no expression} {
list [catch {expr } msg] $msg
} {1 {wrong # args: should be "expr arg ?arg ...?"}}
test expr-1.2 {TclCompileExprCmd: one expression word} {
expr -25
} -25
test expr-1.3 {TclCompileExprCmd: two expression words} {
expr -8.2 -6
} -14.2
test expr-1.4 {TclCompileExprCmd: five expression words} {
expr 20 - 5 +10 -7
} 18
test expr-1.5 {TclCompileExprCmd: quoted expression word} {
expr "0005"
} 5
test expr-1.6 {TclCompileExprCmd: quoted expression word} {
catch {expr "0005"zxy} msg
set msg
} {extra characters after close-quote}
test expr-1.7 {TclCompileExprCmd: expression word in braces} {
expr {-0005}
} -5
test expr-1.8 {TclCompileExprCmd: expression word in braces} {
expr {{-0x1234}}
} -4660
test expr-1.9 {TclCompileExprCmd: expression word in braces} {
catch {expr {-0005}foo} msg
set msg
} {extra characters after close-brace}
test expr-1.10 {TclCompileExprCmd: other expression word in braces} {
expr 4*[llength "6 2"]
} 8
test expr-1.11 {TclCompileExprCmd: expression word terminated by ;} {
expr 4*[llength "6 2"];
} 8
test expr-1.12 {TclCompileExprCmd: inlined expr (in "catch") inside other catch} {
set a xxx
catch {
# Might not be a number
set a [expr 10*$a]
}
} 1
test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in braces with single var reference} {
set a xxx
set x 27; set bool {$x}; if $bool {set a foo}
set a
} foo
test expr-1.14 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} {
set a xxx
set x 2; set b {$x}; set a [expr $b == 2]
set a
} 1
test expr-1.15 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} {
set a xxx
set x 2; set b {$x}; set a [expr $b eq 2]
set a
} 1
test expr-2.1 {TclCompileExpr: are builtin functions registered?} {
expr double(5*[llength "6 2"])
} 10.0
test expr-2.2 {TclCompileExpr: error in expr} {
catch {expr 2**3} msg
set msg
} {syntax error in expression "2**3": unexpected operator *}
test expr-2.3 {TclCompileExpr: junk after legal expr} {
catch {expr 7*[llength "a b"]foo} msg
set msg
} {syntax error in expression "7*2foo": extra tokens at end of expression}
test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} {
expr {0001}
} 1
test expr-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1
test expr-3.2 {CompileCondExpr: error in lor expr} {
catch {expr x||3} msg
set msg
} {syntax error in expression "x||3": variable references require preceding $}
test expr-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44
test expr-3.4 {CompileCondExpr: error compiling true arm} {
catch {expr 3>2?2**3:66} msg
set msg
} {syntax error in expression "3>2?2**3:66": unexpected operator *}
test expr-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66
test expr-3.6 {CompileCondExpr: error compiling false arm} {
catch {expr 2>3?44:2**3} msg
set msg
} {syntax error in expression "2>3?44:2**3": unexpected operator *}
test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} {unixOnly nonPortable} {
puts "Note: doing test expr-3.7 which can take several minutes to run"
hello_world
} {Hello world}
catch {unset xxx}
test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} {unixOnly nonPortable} {
puts "Note: doing test expr-3.8 which can take several minutes to run"
do_twelve_days
} 2358
catch {unset xxx}
test expr-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1
test expr-4.2 {CompileLorExpr: error in land expr} {
catch {expr x&&3} msg
set msg
} {syntax error in expression "x&&3": variable references require preceding $}
test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1
test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1
test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1
test expr-4.6 {CompileLorExpr: error compiling lor arm} {
catch {expr 2**3||4.0} msg
set msg
} {syntax error in expression "2**3||4.0": unexpected operator *}
test expr-4.7 {CompileLorExpr: error compiling lor arm} {
catch {expr 1.3||2**3} msg
set msg
} {syntax error in expression "1.3||2**3": unexpected operator *}
test expr-4.8 {CompileLorExpr: error compiling lor arms} {
list [catch {expr {"a"||"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-4.9 {CompileLorExpr: long lor arm} {
set a "abcdefghijkl"
set i 7
expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1
test expr-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23
test expr-5.2 {CompileLandExpr: error in bitor expr} {
catch {expr x|3} msg
set msg
} {syntax error in expression "x|3": variable references require preceding $}
test expr-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0
test expr-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0
test expr-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1
test expr-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1
test expr-5.7 {CompileLandExpr: error compiling land arm} {
catch {expr 2**3&&4.0} msg
set msg
} {syntax error in expression "2**3&&4.0": unexpected operator *}
test expr-5.8 {CompileLandExpr: error compiling land arm} {
catch {expr 1.3&&2**3} msg
set msg
} {syntax error in expression "1.3&&2**3": unexpected operator *}
test expr-5.9 {CompileLandExpr: error compiling land arm} {
list [catch {expr {"a"&&"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-5.10 {CompileLandExpr: long land arms} {
set a "abcdefghijkl"
set i 7
expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]}
} 1
test expr-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3
test expr-6.2 {CompileBitXorExpr: error in bitand expr} {
catch {expr x|3} msg
set msg
} {syntax error in expression "x|3": variable references require preceding $}
test expr-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20
test expr-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19
test expr-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7
test expr-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8
test expr-6.7 {CompileBitXorExpr: error compiling bitxor arm} {
catch {expr 2**3|6} msg
set msg
} {syntax error in expression "2**3|6": unexpected operator *}
test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} {
catch {expr 2^x} msg
set msg
} {syntax error in expression "2^x": variable references require preceding $}
test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
} {1 {can't use floating-point value as operand of "^"}}
test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {"a"^"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "^"}}
test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
test expr-7.5 {CompileBitAndExpr: error in equality expr} {
catch {expr x==3} msg
set msg
} {syntax error in expression "x==3": variable references require preceding $}
test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} {
catch {expr 2**3&6} msg
set msg
} {syntax error in expression "2**3&6": unexpected operator *}
test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} {
catch {expr 2&x} msg
set msg
} {syntax error in expression "2&x": variable references require preceding $}
test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {24.0&3}} msg] $msg
} {1 {can't use floating-point value as operand of "&"}}
test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {"a"&"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "&"}}
test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
test expr-7.20 {CompileBitAndExpr: error in equality expr} {
catch {expr xne3} msg
set msg
} {syntax error in expression "xne3": variable references require preceding $}
test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
test expr-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
test expr-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1
test expr-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0
test expr-8.5 {CompileEqualityExpr: error in relational expr} {
catch {expr x>3} msg
set msg
} {syntax error in expression "x>3": variable references require preceding $}
test expr-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0
test expr-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1
test expr-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1
test expr-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1
test expr-8.10 {CompileEqualityExpr: error compiling equality arm} {
catch {expr 2**3==6} msg
set msg
} {syntax error in expression "2**3==6": unexpected operator *}
test expr-8.11 {CompileEqualityExpr: error compiling equality arm} {
catch {expr 2!=x} msg
set msg
} {syntax error in expression "2!=x": variable references require preceding $}
test expr-8.12 {CompileBitAndExpr: equality expr} {expr {"a"eq"a"}} 1
test expr-8.13 {CompileBitAndExpr: equality expr} {
set s \u00fc
expr {"\374" eq $s}
} 1
test expr-8.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
test expr-8.15 {CompileBitAndExpr: equality expr} {expr 2.0eq2} 0
test expr-8.16 {CompileBitAndExpr: equality expr} {expr 3.2ne2.2} 1
test expr-8.17 {CompileBitAndExpr: equality expr} {expr 01eq1} 0
test expr-8.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
test expr-8.19 {CompileBitAndExpr: equality expr} {expr {"abc" ne "abd"}} 1
test expr-8.20 {CompileBitAndExpr: error in equality expr} {
catch {expr x ne3} msg
set msg
} {syntax error in expression "x ne3": variable references require preceding $}
test expr-8.21 {CompileBitAndExpr: error in equality expr} {
# These should be ""ed to avoid the error
catch {expr a eq b} msg
set msg
} {syntax error in expression "a eq b": variable references require preceding $}
test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
# The following test is different for 32-bit versus 64-bit
# architectures because LONG_MIN is different
if {0x80000000 > 0} {
test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
expr {1<<63}
} -9223372036854775808
} else {
test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
expr {1<<31}
} -2147483648
}
test expr-9.6 {CompileRelationalExpr: error in shift expr} {
catch {expr x>>3} msg
set msg
} {syntax error in expression "x>>3": variable references require preceding $}
test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
test expr-9.9 {CompileRelationalExpr: error compiling relational arm} {
catch {expr 2**3>6} msg
set msg
} {syntax error in expression "2**3>6": unexpected operator *}
test expr-9.10 {CompileRelationalExpr: error compiling relational arm} {
catch {expr 2>0x3} 31
test expr-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936
test expr-10.8 {CompileShiftExpr: error compiling shift arm} {
catch {expr 2**3>>6} msg
set msg
} {syntax error in expression "2**3>>6": unexpected operator *}
test expr-10.9 {CompileShiftExpr: error compiling shift arm} {
catch {expr 2<>43}} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test expr-10.11 {CompileShiftExpr: runtime error} {
list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "<<"}}
test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6
test expr-11.5 {CompileAddExpr: error in multiply expr} {
catch {expr x*3} msg
set msg
} {syntax error in expression "x*3": variable references require preceding $}
test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
test expr-11.8 {CompileAddExpr: error compiling add arm} {
catch {expr 2**3+6} msg
set msg
} {syntax error in expression "2**3+6": unexpected operator *}
test expr-11.9 {CompileAddExpr: error compiling add arm} {
catch {expr 2-x} msg
set msg
} {syntax error in expression "2-x": variable references require preceding $}
test expr-11.10 {CompileAddExpr: runtime error} {
list [catch {expr {24.0+"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-11.11 {CompileAddExpr: runtime error} {
list [catch {expr {"a"-"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test expr-11.12 {CompileAddExpr: runtime error} {
list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
test expr-11.13 {CompileAddExpr: runtime error} {
list [catch {expr {2.3/0.0}} msg] $msg
} {1 {divide by zero}}
test expr-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5
test expr-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5
test expr-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0
test expr-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936
test expr-12.5 {CompileMultiplyExpr: error in unary expr} {
catch {expr ~x} msg
set msg
} {syntax error in expression "~x": variable references require preceding $}
test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765
test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2
test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} {
catch {expr 2*3%%6} msg
set msg
} {syntax error in expression "2*3%%6": unexpected operator %}
test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} {
catch {expr 2*x} msg
set msg
} {syntax error in expression "2*x": variable references require preceding $}
test expr-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
test expr-12.11 {CompileMultiplyExpr: runtime error} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83
test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
test expr-13.8 {CompileUnaryExpr: error compiling unary expr} {
catch {expr ~x} msg
set msg
} {syntax error in expression "~x": variable references require preceding $}
test expr-13.9 {CompileUnaryExpr: error compiling unary expr} {
catch {expr !1.x} msg
set msg
} {syntax error in expression "!1.x": extra tokens at end of expression}
test expr-13.10 {CompileUnaryExpr: runtime error} {
list [catch {expr {~"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "~"}}
test expr-13.11 {CompileUnaryExpr: runtime error} {
list [catch {expr ~4.0} msg] $msg
} {1 {can't use floating-point value as operand of "~"}}
test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291
test expr-13.13 {CompileUnaryExpr: just primary expr} {
set a 27
expr $a
} 27
test expr-13.14 {CompileUnaryExpr: just primary expr} {
expr double(27)
} 27.0
test expr-13.15 {CompileUnaryExpr: just primary expr} {expr "123"} 123
test expr-13.16 {CompileUnaryExpr: error in primary expr} {
catch {expr [set]} msg
set msg
} {wrong # args: should be "set varName ?newValue?"}
test expr-13.17 {CompileUnaryExpr: negating non-numeric boolean literals} {
set a1 yes; set a0 no; set b1 true; set b0 false
list [expr {!$a1}] [expr {!$a0}] [expr {!$b1}] [expr {!$b0}]
} {0 1 0 1}
test expr-14.1 {CompilePrimaryExpr: literal primary} {expr 1} 1
test expr-14.2 {CompilePrimaryExpr: literal primary} {expr 123} 123
test expr-14.3 {CompilePrimaryExpr: literal primary} {expr 0xff} 255
test expr-14.4 {CompilePrimaryExpr: literal primary} {expr 00010} 8
test expr-14.5 {CompilePrimaryExpr: literal primary} {expr 62.0} 62.0
test expr-14.6 {CompilePrimaryExpr: literal primary} {
expr 3.1400000
} 3.14
test expr-14.7 {CompilePrimaryExpr: literal primary} {expr {{abcde}<{abcdef}}} 1
test expr-14.8 {CompilePrimaryExpr: literal primary} {expr {{abc\
def} < {abcdef}}} 1
test expr-14.9 {CompilePrimaryExpr: literal primary} {expr {{abc\tde} > {abc\tdef}}} 0
test expr-14.10 {CompilePrimaryExpr: literal primary} {expr {{123}}} 123
test expr-14.11 {CompilePrimaryExpr: var reference primary} {
set i 789
list [expr {$i}] [expr $i]
} {789 789}
test expr-14.12 {CompilePrimaryExpr: var reference primary} {
set i {789} ;# test expr's aggressive conversion to numeric semantics
list [expr {$i}] [expr $i]
} {789 789}
test expr-14.13 {CompilePrimaryExpr: var reference primary} {
catch {unset a}
set a(foo) foo
set a(bar) bar
set a(123) 123
set result ""
lappend result [expr $a(123)] [expr {$a(bar)<$a(foo)}]
catch {unset a}
set result
} {123 1}
test expr-14.14 {CompilePrimaryExpr: var reference primary} {
set i 123 ;# test "$var.0" floating point conversion hack
list [expr $i] [expr $i.0] [expr $i.0/12.0]
} {123 123.0 10.25}
test expr-14.15 {CompilePrimaryExpr: var reference primary} {
set i 123
catch {expr $i.2} msg
set msg
} 123.2
test expr-14.16 {CompilePrimaryExpr: error compiling var reference primary} {
catch {expr {$a(foo}} msg
set errorInfo
} {missing )
while compiling
"expr {$a(foo}"}
test expr-14.17 {CompilePrimaryExpr: string primary that looks like var ref} {
expr $
} $
test expr-14.18 {CompilePrimaryExpr: quoted string primary} {
expr "21"
} 21
test expr-14.19 {CompilePrimaryExpr: quoted string primary} {
set i 123
set x 456
expr "$i+$x"
} 579
test expr-14.20 {CompilePrimaryExpr: quoted string primary} {
set i 3
set x 6
expr 2+"$i.$x"
} 5.6
test expr-14.21 {CompilePrimaryExpr: error in quoted string primary} {
catch {expr "[set]"} msg
set msg
} {wrong # args: should be "set varName ?newValue?"}
test expr-14.22 {CompilePrimaryExpr: subcommand primary} {
expr {[set i 123; set i]}
} 123
test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} {
catch {expr {[set]}} msg
set errorInfo
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
while compiling
"expr {[set]}"}
test expr-14.24 {CompilePrimaryExpr: error in subcommand primary} {
catch {expr {[set i}} msg
set errorInfo
} {missing close-bracket
while compiling
"expr {[set i}"}
test expr-14.25 {CompilePrimaryExpr: math function primary} {
format %.6g [expr exp(1.0)]
} 2.71828
test expr-14.26 {CompilePrimaryExpr: math function primary} {
format %.6g [expr pow(2.0+0.1,3.0+0.1)]
} 9.97424
test expr-14.27 {CompilePrimaryExpr: error in math function primary} {
catch {expr sinh::(2.0)} msg
set errorInfo
} {syntax error in expression "sinh::(2.0)": expected parenthesis enclosing function arguments
while compiling
"expr sinh::(2.0)"}
test expr-14.28 {CompilePrimaryExpr: subexpression primary} {
expr 2+(3*4)
} 14
test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} {
catch {expr 2+(3*[set])} msg
set errorInfo
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
while compiling
"expr 2+(3*[set])"}
test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} {
catch {expr 2+(3*(4+5)} msg
set errorInfo
} {syntax error in expression "2+(3*(4+5)": looking for close parenthesis
while compiling
"expr 2+(3*(4+5)"}
test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
set i "5+10"
list "[expr $i] == 15" "[expr ($i)] == 15" "[eval expr ($i)] == 15"
} {{15 == 15} {15 == 15} {15 == 15}}
test expr-14.32 {CompilePrimaryExpr: unexpected token} {
catch {expr @} msg
set errorInfo
} {syntax error in expression "@": character not legal in expressions
while compiling
"expr @"}
test expr-15.1 {CompileMathFuncCall: missing parenthesis} {
catch {expr sinh2.0)} msg
set errorInfo
} {syntax error in expression "sinh2.0)": variable references require preceding $
while compiling
"expr sinh2.0)"}
test expr-15.2 {CompileMathFuncCall: unknown math function} {
catch {expr whazzathuh(1)} msg
set errorInfo
} {unknown math function "whazzathuh"
while compiling
"expr whazzathuh(1)"}
test expr-15.3 {CompileMathFuncCall: too many arguments} {
catch {expr sin(1,2,3)} msg
set errorInfo
} {too many arguments for math function
while compiling
"expr sin(1,2,3)"}
test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} {
catch {expr sin()} msg
set errorInfo
} {too few arguments for math function
while compiling
"expr sin()"}
test expr-15.5 {CompileMathFuncCall: too few arguments} {
catch {expr pow(1)} msg
set errorInfo
} {too few arguments for math function
while compiling
"expr pow(1)"}
test expr-15.6 {CompileMathFuncCall: missing ')'} {
catch {expr sin(1} msg
set errorInfo
} {syntax error in expression "sin(1": missing close parenthesis at end of function call
while compiling
"expr sin(1"}
test expr-15.7 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
expr 2*T1()
} 246
test expr-15.8 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
expr T2()*3
} 1035
test expr-15.9 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
expr T3(21, 37)
} 37
test expr-15.10 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
expr T3(21.2, 37)
} 37.0
test expr-15.11 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
expr T3(-21.2, -17.5)
} -17.5
test expr-15.12 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
expr T3(21, wide(37))
} 37
test expr=15.13 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
expr T3(wide(21), 37)
} 37
test expr=15.14 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
expr T3(wide(21), wide(37))
} 37
test expr-15.15 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
expr T3(21.0, wide(37))
} 37.0
test expr=15.16 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
expr T3(wide(21), 37.0)
} 37.0
test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
set a(VALUE) ff15
set i 123
if {[expr 0x$a(VALUE)] & 16} {
set i {}
}
set i
} {}
test expr-16.2 {GetToken: check for string literal in braces} {
expr {{1}}
} {1}
# Check "expr" and computed command names.
test expr-17.1 {expr and computed command names} {
set i 0
set z expr
$z 1+2
} 3
# Check correct conversion of operands to numbers: If the string looks like
# an integer, convert to integer. Otherwise, if the string looks like a
# double, convert to double.
test expr-18.1 {expr and conversion of operands to numbers} {
set x [lindex 11 0]
catch {expr int($x)}
expr {$x}
} 11
test expr-18.2 {whitespace strings should not be == 0 (buggy strtod)} {
expr {" "}
} { }
# Check "expr" and interpreter result object resetting before appending
# an error msg during evaluation of exprs not in {}s
test expr-19.1 {expr and interpreter result object resetting} {
proc p {} {
set t 10.0
set x 2.0
set dx 0.2
set f {$dx-$x/10}
set g {-$x/5}
set center 1.0
set x [expr $x-$center]
set dx [expr $dx+$g]
set x [expr $x+$f+$center]
set x [expr $x+$f+$center]
set y [expr round($x)]
}
p
} 3
# Test for incorrect "double evaluation" semantics
test expr-20.1 {wrong brace matching} {
catch {unset l}
catch {unset r}
catch {unset q}
catch {unset cmd}
catch {unset a}
set l "\{"; set r "\}"; set q "\""
set cmd "expr $l$q|$q == $q$r$q$r"
list [catch $cmd a] $a
} {1 {extra characters after close-brace}}
test expr-20.2 {double invocation of variable traces} {
set exprtracecounter 0
proc exprtraceproc {args} {
upvar #0 exprtracecounter counter
set argc [llength $args]
set extraargs [lrange $args 0 [expr {$argc - 4}]]
set name [lindex $args [expr {$argc - 3}]]
upvar 1 $name var
if {[incr counter] % 2 == 1} {
set var "$counter oops [concat $extraargs]"
} else {
set var "$counter + [concat $extraargs]"
}
}
trace variable exprtracevar r [list exprtraceproc 10]
list [catch {expr "$exprtracevar + 20"} a] $a \
[catch {expr "$exprtracevar + 20"} b] $b \
[unset exprtracevar exprtracecounter]
} {1 {syntax error in expression "1 oops 10 + 20": extra tokens at end of expression} 0 32 {}}
test expr-20.3 {broken substitution of integer digits} {
# fails with 8.0.x, but not 8.1b2
list [set a 000; expr 0x1$a] [set a 1; expr ${a}000]
} {4096 1000}
test expr-20.4 {proper double evaluation compilation, error case} {
catch {unset a}; # make sure $a doesn't exist
list [catch {expr 1?{$a}:0} msg] $msg
} {1 {can't read "a": no such variable}}
test expr-20.5 {proper double evaluation compilation, working case} {
set a yellow
expr 1?{$a}:0
} yellow
test expr-20.6 {handling of compile error in trial compile} {
list [catch {expr + {[incr]}} msg] $msg
} {1 {wrong # args: should be "incr varName ?increment?"}}
test expr-20.7 {handling of compile error in runtime case} {
list [catch {expr + {[error foo]}} msg] $msg
} {1 foo}
# Test for non-numeric boolean literal handling
test expr-21.1 {non-numeric boolean literals} {expr false } false
test expr-21.2 {non-numeric boolean literals} {expr true } true
test expr-21.3 {non-numeric boolean literals} {expr off } off
test expr-21.4 {non-numeric boolean literals} {expr on } on
test expr-21.5 {non-numeric boolean literals} {expr no } no
test expr-21.6 {non-numeric boolean literals} {expr yes } yes
test expr-21.7 {non-numeric boolean literals} {expr !false} 1
test expr-21.8 {non-numeric boolean literals} {expr !true } 0
test expr-21.9 {non-numeric boolean literals} {expr !off } 1
test expr-21.10 {non-numeric boolean literals} {expr !on } 0
test expr-21.11 {non-numeric boolean literals} {expr !no } 1
test expr-21.12 {non-numeric boolean literals} {expr !yes } 0
# Test for non-numeric float handling.
#
# These are non-portable because strtod()-support for "Inf" and "NaN"
# is so wildly variable. This sucks...
test expr-22.1 {non-numeric floats} nonPortable {
list [catch {expr {NaN + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.2 {non-numeric floats} nonPortable {
list [catch {expr {Inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.3 {non-numeric floats} nonPortable {
set nan NaN
list [catch {expr {$nan + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.4 {non-numeric floats} nonPortable {
set inf Inf
list [catch {expr {$inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.5 {non-numeric floats} nonPortable {
list [catch {expr NaN} msg] $msg
} {1 {domain error: argument not in valid range}}
test expr-22.6 {non-numeric floats} nonPortable {
list [catch {expr Inf} msg] $msg
} {1 {floating-point value too large to represent}}
test expr-22.7 {non-numeric floats} nonPortable {
list [catch {expr {1 / NaN}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "/"}}
test expr-22.8 {non-numeric floats} nonPortable {
list [catch {expr {1 / Inf}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "/"}}
# Make sure [Bug 761471] stays fixed.
test expr-22.9 {non-numeric floats: shared object equality and NaN} nonPortable {
set x NaN
expr {$x == $x}
} 0
# Some compilers get this wrong; ensure that we work around it correctly
test expr-24.1 {expr edge cases; shifting} {expr int(5)>>31} 0
test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0
test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>31} 0
test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0
test expr-24.5 {expr edge cases; shifting} nonPortable {expr int(5)<<31} 0
test expr-24.6 {expr edge cases; shifting} nonPortable {expr int(5)<<63} 0
test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<31} 10737418240
test expr-24.8 {expr edge cases; shifting} nonPortable {expr wide(5)<<63} -9223372036854775808
test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0
test expr-38.1 {abs of smallest 32-bit integer [Bug 1241572]} {wideIs64bit} {
expr {abs(int(-2147483648))}
} 2147483648
test expr-38.2 {abs and -0 [Bug 1893815]} {
expr {abs(-0)}
} 0
test expr-38.3 {abs and -0 [Bug 1893815]} {
expr {abs(-0.0)}
} 0.0
# tests 38.4 to 38.8 not backported
test expr-38.9 {abs and 0.0 [Bug 2954959]} {
expr {abs(0.0)}
} 0.0
test expr-38.10 {abs and -0x0 [Bug 2954959]} {
expr {abs(-0x0)}
} 0
# tests 38.11 to 38.13 not backported
test expr-46.1 {round() rounds to +-infinity} {
expr round(0.5)
} 1
test expr-46.2 {round() rounds to +-infinity} {
expr round(1.5)
} 2
test expr-46.3 {round() rounds to +-infinity} {
expr round(-0.5)
} -1
test expr-46.4 {round() rounds to +-infinity} {
expr round(-1.5)
} -2
test expr-46.5 {round() overflow} {
list [catch {expr round(9.2233720368547758e+018)} result] $result
} {1 {integer value too large to represent}}
test expr-46.6 {round() overflow} {
list [catch {expr round(-9.2233720368547758e+018)} result] $result
} {1 {integer value too large to represent}}
test expr-46.7 {round() bad value} {
set x trash
list [catch {expr {round($x)}} result] $result
} {1 {argument to math function didn't have numeric value}}
test expr-46.8 {round() already an integer} {
set x 123456789012
incr x
expr round($x)
} 123456789013
test expr-46.9 {round() boundary case - 1/2 - 1 ulp} {
set x 0.25
set bit 0.125
while 1 {
set newx [expr {$x + $bit}]
if { $newx == $x || $newx == 0.5 } break
set x $newx
set bit [expr { $bit / 2.0 }]
}
expr {round($x)}
} 0
test expr-46.10 {round() boundary case - 1/2 + 1 ulp} {
set x 0.75
set bit 0.125
while 1 {
set newx [expr { $x - $bit }]
if { $newx == $x || $newx == 0.5 } break
set x $newx
set bit [expr { $bit / 2.0 }]
}
expr {round($x)}
} 1
test expr-46.11 {round() boundary case - -1/2 - 1 ulp} {
set x -0.75
set bit 0.125
while 1 {
set newx [expr { $x + $bit }]
if { $newx == $x || $newx == -0.5 } break
set x $newx
set bit [expr { $bit / 2.0 }]
}
expr {round($x)}
} -1
test expr-46.12 {round() boundary case - -1/2 + 1 ulp} {
set x -0.25
set bit 0.125
while 1 {
set newx [expr { $x - $bit }]
if { $newx == $x || $newx == -0.5 } break
set x $newx
set bit [expr { $bit / 2.0 }]
}
expr {round($x)}
} 0
test expr-46.13 {round() boundary case - round down} {
expr {round(2147483647 - 0.51)}
} 2147483646
test expr-46.14 {round() boundary case - round up} {
expr {round(2147483647 - 0.50)}
} 2147483647
test expr-46.15 {round() boundary case - round up to wide} {
expr {round(2147483647 + 0.50)}
} [expr {wide(2147483647) + 1}]
test expr-46.16 {round() boundary case - round up} {
expr {round(-2147483648 + 0.51)}
} -2147483647
test expr-46.17 {round() boundary case - round down} {
expr {round(-2147483648 + 0.50)}
} -2147483648
test expr-46.18 {round() boundary case - round down to wide} {
expr {round(-2147483648 - 0.50)}
} [expr {wide(-2147483648) - 1}]
# cleanup
if {[info exists a]} {
unset a
}
::tcltest::cleanupTests
return
tcl8.4.20/tests/remote.tcl 0000644 0036047 0045461 00000010113 11737050674 014054 0 ustar dgp 771div # This file contains Tcl code to implement a remote server that can be
# used during testing of Tcl socket code. This server is used by some
# of the tests in socket.test.
#
# Source this file in the remote server you are using to test Tcl against.
#
# Copyright (c) 1995-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.
# Initialize message delimitor
# Initialize command array
catch {unset command}
set command(0) ""
set callerSocket ""
# Detect whether we should print out connection messages etc.
if {![info exists VERBOSE]} {
set VERBOSE 0
}
proc __doCommands__ {l s} {
global callerSocket VERBOSE
if {$VERBOSE} {
puts "--- Server executing the following for socket $s:"
puts $l
puts "---"
}
set callerSocket $s
if {[catch {uplevel #0 $l} msg]} {
list error $msg
} else {
list success $msg
}
}
proc __readAndExecute__ {s} {
global command VERBOSE
set l [gets $s]
if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
if {[info exists command($s)]} {
puts $s [list error incomplete_command]
}
puts $s "--Marker--Marker--Marker--"
return
}
if {[string compare $l ""] == 0} {
if {[eof $s]} {
if {$VERBOSE} {
puts "Server closing $s, eof from client"
}
close $s
}
return
}
append command($s) $l "\n"
if {[info complete $command($s)]} {
set cmds $command($s)
unset command($s)
puts $s [__doCommands__ $cmds $s]
}
if {[eof $s]} {
if {$VERBOSE} {
puts "Server closing $s, eof from client"
}
close $s
}
}
proc __accept__ {s a p} {
global VERBOSE
if {$VERBOSE} {
puts "Server accepts new connection from $a:$p on $s"
}
fileevent $s readable [list __readAndExecute__ $s]
fconfigure $s -buffering line -translation crlf
}
set serverIsSilent 0
for {set i 0} {$i < $argc} {incr i} {
if {[string compare -serverIsSilent [lindex $argv $i]] == 0} {
set serverIsSilent 1
break
}
}
if {![info exists serverPort]} {
if {[info exists env(serverPort)]} {
set serverPort $env(serverPort)
}
}
if {![info exists serverPort]} {
for {set i 0} {$i < $argc} {incr i} {
if {[string compare -port [lindex $argv $i]] == 0} {
if {$i < [expr $argc - 1]} {
set serverPort [lindex $argv [expr $i + 1]]
}
break
}
}
}
if {![info exists serverPort]} {
set serverPort 2048
}
if {![info exists serverAddress]} {
if {[info exists env(serverAddress)]} {
set serverAddress $env(serverAddress)
}
}
if {![info exists serverAddress]} {
for {set i 0} {$i < $argc} {incr i} {
if {[string compare -address [lindex $argv $i]] == 0} {
if {$i < [expr $argc - 1]} {
set serverAddress [lindex $argv [expr $i + 1]]
}
break
}
}
}
if {![info exists serverAddress]} {
set serverAddress 0.0.0.0
}
if {$serverIsSilent == 0} {
set l "Remote server listening on port $serverPort, IP $serverAddress."
puts ""
puts $l
for {set c [string length $l]} {$c > 0} {incr c -1} {puts -nonewline "-"}
puts ""
puts ""
puts "You have set the Tcl variables serverAddress to $serverAddress and"
puts "serverPort to $serverPort. You can set these with the -address and"
puts "-port command line options, or as environment variables in your"
puts "shell."
puts ""
puts "NOTE: The tests will not work properly if serverAddress is set to"
puts "\"localhost\" or 127.0.0.1."
puts ""
puts "When you invoke tcltest to run the tests, set the variables"
puts "remoteServerPort to $serverPort and remoteServerIP to"
puts "[info hostname]. You can set these as environment variables"
puts "from the shell. The tests will not work properly if you set"
puts "remoteServerIP to \"localhost\" or 127.0.0.1."
puts ""
puts -nonewline "Type Ctrl-C to terminate--> "
flush stdout
}
if {[catch {set serverSocket \
[socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
puts "Server on $serverAddress:$serverPort cannot start: $msg"
} else {
vwait __server_wait_variable__
}
tcl8.4.20/tests/get.test 0000644 0036047 0045461 00000010451 11737050674 013542 0 ustar dgp 771div # Commands covered: none
#
# This file contains a collection of tests for the procedures in the
# file tclGet.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test get-1.1 {Tcl_GetInt procedure} {
set x 44
incr x { 22}
} {66}
test get-1.2 {Tcl_GetInt procedure} {
set x 44
incr x -3
} {41}
test get-1.3 {Tcl_GetInt procedure} {
set x 44
incr x +8
} {52}
test get-1.4 {Tcl_GetInt procedure} {
set x 44
list [catch {incr x foo} msg] $msg
} {1 {expected integer but got "foo"}}
test get-1.5 {Tcl_GetInt procedure} {
set x 44
list [catch {incr x {16 }} msg] $msg
} {0 60}
test get-1.6 {Tcl_GetInt procedure} {
set x 44
list [catch {incr x {16 x}} msg] $msg
} {1 {expected integer but got "16 x"}}
# The following tests are non-portable because they depend on
# word size.
if {wide(0x80000000) > wide(0)} {
test get-1.7 {Tcl_GetInt procedure} {
set x 44
list [catch {eval incr x 18446744073709551616} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.8 {Tcl_GetInt procedure} {
set x 0
list [catch {incr x 18446744073709551614} msg] $msg
} {0 -2}
test get-1.9 {Tcl_GetInt procedure} {
set x 0
list [catch {incr x +18446744073709551614} msg] $msg
} {0 -2}
test get-1.10 {Tcl_GetInt procedure} {
set x 0
list [catch {incr x -18446744073709551614} msg] $msg
} {0 2}
} else {
test get-1.11 {Tcl_GetInt procedure} {
set x 44
list [catch {incr x 4294967296} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.12 {Tcl_GetInt procedure} {
set x 0
list [catch {incr x 4294967294} msg] $msg
} {0 -2}
test get-1.13 {Tcl_GetInt procedure} {
set x 0
list [catch {incr x +4294967294} msg] $msg
} {0 -2}
test get-1.14 {Tcl_GetInt procedure} {
set x 0
list [catch {incr x -4294967294} msg] $msg
} {0 2}
}
test get-2.1 {Tcl_GetInt procedure} {
format %g 1.23
} {1.23}
test get-2.2 {Tcl_GetInt procedure} {
format %g { 1.23 }
} {1.23}
test get-2.3 {Tcl_GetInt procedure} {
list [catch {format %g clip} msg] $msg
} {1 {expected floating-point number but got "clip"}}
test get-2.4 {Tcl_GetInt procedure} {nonPortable} {
list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode
} {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}}
test get-3.1 {Tcl_GetInt(FromObj), bad numbers} {
# SF bug #634856
set result ""
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1" "+12345678987654321" "++12345678987654321"]
foreach num $numbers {
lappend result [catch {format %ld $num} msg] $msg
}
set result
} {0 1 0 1 1 {expected integer but got "++1"} 1 {expected integer but got "+-1"} 1 {expected integer but got "-+1"} 0 -1 1 {expected integer but got "--1"} 1 {expected integer but got "- +1"} 0 12345678987654321 1 {expected integer but got "++12345678987654321"}}
test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} {
set result ""
set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"]
foreach num $numbers {
lappend result [catch {format %g $num} msg] $msg
}
set result
} {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/ioCmd.test 0000644 0036047 0045461 00000053101 11737050674 014015 0 ustar dgp 771div # -*- tcl -*-
# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush,
# fblocked, fconfigure, open, channel, fcopy
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint fcopy [llength [info commands fcopy]]
test iocmd-1.1 {puts command} {
list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
list [catch {puts a b c d e f g} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.3 {puts command} {
list [catch {puts froboz -nonewline kablooie} msg] $msg
} {1 {bad argument "kablooie": should be "nonewline"}}
test iocmd-1.4 {puts command} {
list [catch {puts froboz hello} msg] $msg
} {1 {can not find channel named "froboz"}}
test iocmd-1.5 {puts command} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
set path(test1) [makeFile {} test1]
test iocmd-1.6 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts -nonewline $f foobar
close $f
file size $path(test1)
} 6
test iocmd-1.7 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts $f foobar
close $f
file size $path(test1)
} 7
test iocmd-1.8 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {} -encoding iso8859-1
puts -nonewline $f [binary format a4a5 foo bar]
close $f
file size $path(test1)
} 9
test iocmd-2.1 {flush command} {
list [catch {flush} msg] $msg
} {1 {wrong # args: should be "flush channelId"}}
test iocmd-2.2 {flush command} {
list [catch {flush a b c d e} msg] $msg
} {1 {wrong # args: should be "flush channelId"}}
test iocmd-2.3 {flush command} {
list [catch {flush foo} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-2.4 {flush command} {
list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test iocmd-3.1 {gets command} {
list [catch {gets} msg] $msg
} {1 {wrong # args: should be "gets channelId ?varName?"}}
test iocmd-3.2 {gets command} {
list [catch {gets a b c d e f g} msg] $msg
} {1 {wrong # args: should be "gets channelId ?varName?"}}
test iocmd-3.3 {gets command} {
list [catch {gets aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-3.4 {gets command} {
list [catch {gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-3.5 {gets command} {
set f [open $path(test1) w]
puts $f [binary format a4a5 foo bar]
close $f
set f [open $path(test1) r]
set result [gets $f]
close $f
set x foo\x00
set x "${x}bar\x00\x00"
string compare $x $result
} 0
test iocmd-4.1 {read command} {
list [catch {read} msg] $msg
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}}
test iocmd-4.2 {read command} {
list [catch {read a b c d e f g h} msg] $msg
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}}
test iocmd-4.3 {read command} {
list [catch {read aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-4.4 {read command} {
list [catch {read -nonewline} msg] $msg
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}}
test iocmd-4.5 {read command} {
list [catch {read -nonew file4} msg] $msg $errorCode
} {1 {can not find channel named "-nonew"} NONE}
test iocmd-4.6 {read command} {
list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.7 {read command} {
list [catch {read -nonewline stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.8 {read command with incorrect combination of arguments} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [list [catch {read -nonewline $f 20 z} msg] $msg $errorCode]
close $f
set x
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} NONE}
test iocmd-4.9 {read command} {
list [catch {read stdin foo} msg] $msg $errorCode
} {1 {bad argument "foo": should be "nonewline"} NONE}
test iocmd-4.10 {read command} {
list [catch {read file107} msg] $msg $errorCode
} {1 {can not find channel named "file107"} NONE}
set path(test3) [makeFile {} test3]
test iocmd-4.11 {read command} {
set f [open $path(test3) w]
set x [list [catch {read $f} msg] $msg $errorCode]
close $f
string compare [string tolower $x] \
[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
test iocmd-4.12 {read command} {
set f [open $path(test1)]
set x [list [catch {read $f 12z} msg] $msg $errorCode]
close $f
set x
} {1 {expected integer but got "12z"} NONE}
test iocmd-5.1 {seek command} {
list [catch {seek} msg] $msg
} {1 {wrong # args: should be "seek channelId offset ?origin?"}}
test iocmd-5.2 {seek command} {
list [catch {seek a b c d e f g} msg] $msg
} {1 {wrong # args: should be "seek channelId offset ?origin?"}}
test iocmd-5.3 {seek command} {
list [catch {seek stdin gugu} msg] $msg
} {1 {expected integer but got "gugu"}}
test iocmd-5.4 {seek command} {
list [catch {seek stdin 100 gugu} msg] $msg
} {1 {bad origin "gugu": must be start, current, or end}}
test iocmd-6.1 {tell command} {
list [catch {tell} msg] $msg
} {1 {wrong # args: should be "tell channelId"}}
test iocmd-6.2 {tell command} {
list [catch {tell a b c d e} msg] $msg
} {1 {wrong # args: should be "tell channelId"}}
test iocmd-6.3 {tell command} {
list [catch {tell aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-7.1 {close command} {
list [catch {close} msg] $msg
} {1 {wrong # args: should be "close channelId"}}
test iocmd-7.2 {close command} {
list [catch {close a b c d e} msg] $msg
} {1 {wrong # args: should be "close channelId"}}
test iocmd-7.3 {close command} {
list [catch {close aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-8.1 {fconfigure command} {
list [catch {fconfigure} msg] $msg
} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}}
test iocmd-8.2 {fconfigure command} {
list [catch {fconfigure a b c d e f} msg] $msg
} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}}
test iocmd-8.3 {fconfigure command} {
list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}
test iocmd-8.4 {fconfigure command} {
file delete $path(test1)
set f1 [open $path(test1) w]
set x [list [catch {fconfigure $f1 froboz} msg] $msg]
close $f1
set x
} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.5 {fconfigure command} {
list [catch {fconfigure stdin -buffering froboz} msg] $msg
} {1 {bad value for -buffering: must be one of full, line, or none}}
test iocmd-8.6 {fconfigure command} {
list [catch {fconfigure stdin -translation froboz} msg] $msg
} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}}
test iocmd-8.7 {fconfigure command} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {} -encoding unicode
set x [fconfigure $f1]
close $f1
set x
} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf}
test iocmd-8.8 {fconfigure command} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line -buffersize 3030 \
-eofchar {} -encoding unicode
set x ""
lappend x [fconfigure $f1 -buffering]
lappend x [fconfigure $f1]
close $f1
set x
} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}}
test iocmd-8.9 {fconfigure command} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
-eofchar {} -encoding binary
set x [fconfigure $f1]
close $f1
set x
} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf}
test iocmd-8.10 {fconfigure command} {
list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}
set path(fconfigure.dummy) [makeFile {} fconfigure.dummy]
test iocmd-8.11 {fconfigure command} {
set chan [open $path(fconfigure.dummy) r]
set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg]
close $chan
set res
} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.12 {fconfigure command} {
set chan [open $path(fconfigure.dummy) r]
set res [list [catch {fconfigure $chan -b blarfo} msg] $msg]
close $chan
set res
} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.13 {fconfigure command} {
set chan [open $path(fconfigure.dummy) r]
set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg]
close $chan
set res
} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
removeFile fconfigure.dummy
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
} 4096
proc iocmdSSETUP {} {
uplevel {
set srv [socket -server iocmdSRV 0]
set port [lindex [fconfigure $srv -sockname] 2]
proc iocmdSRV {sock ip port} {close $sock}
set cli [socket 127.0.0.1 $port]
}
}
proc iocmdSSHTDWN {} {
uplevel {
close $cli
close $srv
unset cli srv port
rename iocmdSRV {}
}
}
test iocmd-8.15.0 {fconfigure command / tcp channel} {socket macOnly} {
iocmdSSETUP
set r [list [catch {fconfigure $cli -blah} msg] $msg]
iocmdSSHTDWN
set r
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -error, -peername, or -sockname}}
test iocmd-8.15.1 {fconfigure command / tcp channel} {socket unixOrPc} {
iocmdSSETUP
set r [list [catch {fconfigure $cli -blah} msg] $msg]
iocmdSSHTDWN
set r
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -peername, or -sockname}}
test iocmd-8.16 {fconfigure command / tcp channel} {socket} {
iocmdSSETUP
set r [expr [lindex [fconfigure $cli -peername] 2]==$port]
iocmdSSHTDWN
set r
} 1
test iocmd-8.17 {fconfigure command / tcp channel} {nonPortable} {
# It is possible that you don't get the connection reset by peer
# error but rather a valid answer. depends of the tcp implementation
iocmdSSETUP
update;
puts $cli "blah"; flush $cli; # that flush could/should fail too
update;
set r [catch {fconfigure $cli -peername} msg]
iocmdSSHTDWN
regsub -all {can([^:])+: } $r {} r;
set r
} 1
test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} {
# might fail if /dev/ttya is unavailable
set tty [open /dev/ttya]
set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
close $tty;
set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode}}
test iocmd-8.19 {fconfigure command / win tty channel} {nonPortable pcOnly} {
# might fail if com1 is unavailable
set tty [open com1]
set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
close $tty;
set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, or -pollinterval}}
test iocmd-9.1 {eof command} {
list [catch {eof} msg] $msg $errorCode
} {1 {wrong # args: should be "eof channelId"} NONE}
test iocmd-9.2 {eof command} {
list [catch {eof a b} msg] $msg $errorCode
} {1 {wrong # args: should be "eof channelId"} NONE}
test iocmd-9.3 {eof command} {
catch {close file100}
list [catch {eof file100} msg] $msg $errorCode
} {1 {can not find channel named "file100"} NONE}
# The tests for Tcl_ExecObjCmd are in exec.test
test iocmd-10.1 {fblocked command} {
list [catch {fblocked} msg] $msg
} {1 {wrong # args: should be "fblocked channelId"}}
test iocmd-10.2 {fblocked command} {
list [catch {fblocked a b c d e f g} msg] $msg
} {1 {wrong # args: should be "fblocked channelId"}}
test iocmd-10.3 {fblocked command} {
list [catch {fblocked file1000} msg] $msg
} {1 {can not find channel named "file1000"}}
test iocmd-10.4 {fblocked command} {
list [catch {fblocked stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-10.5 {fblocked command} {
fblocked stdin
} 0
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
file delete $path(test5)
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
set f [open $path(test4) w]
close $f
list [catch {open "| cat < $path(test4) > $path(test5)" w} msg] $msg $errorCode
} {1 {can't write input to command: standard input was redirected} NONE}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
list [catch {open "| echo > $path(test5)" r} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
list [catch {open "| echo > $path(test5)" r+} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-12.1 {POSIX open access modes: RDONLY} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1) RDONLY]
set x [list [gets $f] [catch {puts $f Test} msg] $msg]
close $f
string compare $x \
"{Two lines: this one} 1 [list [format "channel \"%s\" wasn't opened for writing" $f]]"
} 0
test iocmd-12.2 {POSIX open access modes: RDONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) RDONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test iocmd-12.3 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
#
# Test 13.4 relies on assigning the same channel name twice.
#
test iocmd-12.4 {POSIX open access modes: WRONLY} {unixOnly} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -eofchar {}
puts $f xyzzy
close $f
set f [open $path(test3) WRONLY]
fconfigure $f -eofchar {}
puts -nonewline $f "ab"
seek $f 0 current
set x [list [catch {gets $f} msg] $msg]
close $f
set f [open $path(test3) r]
fconfigure $f -eofchar {}
lappend x [gets $f]
close $f
set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy]
string compare $x $y
} 0
test iocmd-12.5 {POSIX open access modes: RDWR} -match regexp -body {
file delete $path(test3)
open $path(test3) RDWR
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test iocmd-12.6 {POSIX open access modes: errors} {
concat [catch {open $path(test3) "FOO \{BAR BAZ"} msg] $msg\n$errorInfo
} "1 unmatched open brace in list
unmatched open brace in list
while processing open access modes \"FOO {BAR BAZ\"
invoked from within
\"open \$path(test3) \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}}
test iocmd-12.8 {POSIX open access modes: errors} {
list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg
} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}
close [open $path(test3) w]
test iocmd-13.1 {errors in open command} {
list [catch {open} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.2 {errors in open command} {
list [catch {open a b c d} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.3 {errors in open command} {
list [catch {open $path(test1) x} msg] $msg
} {1 {illegal access mode "x"}}
test iocmd-13.4 {errors in open command} {
list [catch {open $path(test1) rw} msg] $msg
} {1 {illegal access mode "rw"}}
test iocmd-13.5 {errors in open command} {
list [catch {open $path(test1) r+1} msg] $msg
} {1 {illegal access mode "r+1"}}
test iocmd-13.6 {errors in open command} {
set msg [list [catch {open _non_existent_} msg] $msg $errorCode]
regsub [file join {} _non_existent_] $msg "_non_existent_" msg
string tolower $msg
} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}
test iocmd-13.7.1 {open for append, a mode} -setup {
set log [makeFile {} out]
set chans {}
} -body {
foreach i { 0 1 2 3 4 5 6 7 8 9 } {
puts [set ch [open $log a]] $i
lappend chans $ch
}
foreach ch $chans {catch {close $ch}}
lsort [split [string trim [viewFile out]] \n]
} -cleanup {
removeFile out
# Ensure that channels are gone, even if body failed to do so
foreach ch $chans {catch {close $ch}}
} -result {0 1 2 3 4 5 6 7 8 9}
test iocmd-13.7.2 {open for append, O_APPEND} -setup {
set log [makeFile {} out]
set chans {}
} -body {
foreach i { 0 1 2 3 4 5 6 7 8 9 } {
puts [set ch [open $log {WRONLY CREAT APPEND}]] $i
lappend chans $ch
}
foreach ch $chans {catch {close $ch}}
lsort [split [string trim [viewFile out]] \n]
} -cleanup {
removeFile out
# Ensure that channels are gone, even if body failed to do so
foreach ch $chans {catch {close $ch}}
} -result {0 1 2 3 4 5 6 7 8 9}
test iocmd-14.1 {file id parsing errors} {
list [catch {eof gorp} msg] $msg $errorCode
} {1 {can not find channel named "gorp"} NONE}
test iocmd-14.2 {file id parsing errors} {
list [catch {eof filex} msg] $msg
} {1 {can not find channel named "filex"}}
test iocmd-14.3 {file id parsing errors} {
list [catch {eof file12a} msg] $msg
} {1 {can not find channel named "file12a"}}
test iocmd-14.4 {file id parsing errors} {
list [catch {eof file123} msg] $msg
} {1 {can not find channel named "file123"}}
test iocmd-14.5 {file id parsing errors} {
list [catch {eof stdout} msg] $msg
} {0 0}
test iocmd-14.6 {file id parsing errors} {
list [catch {eof stdin} msg] $msg
} {0 0}
test iocmd-14.7 {file id parsing errors} {
list [catch {eof stdout} msg] $msg
} {0 0}
test iocmd-14.8 {file id parsing errors} {
list [catch {eof stderr} msg] $msg
} {0 0}
test iocmd-14.9 {file id parsing errors} {
list [catch {eof stderr1} msg] $msg
} {1 {can not find channel named "stderr1"}}
set f [open $path(test1) w]
close $f
set expect "1 {can not find channel named \"$f\"}"
test iocmd-14.10 {file id parsing errors} {
list [catch {eof $f} msg] $msg
} $expect
test iocmd-15.1 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.2 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy 1} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.3 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy 1 2 3 4 5 6 7} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.4 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy 1 2 3} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.5 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy 1 2 3 4 5} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
set path(test2) [makeFile {} test2]
set f [open $path(test1) w]
close $f
set rfile [open $path(test1) r]
set wfile [open $path(test2) w]
test iocmd-15.6 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy foo $wfile} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-15.7 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile foo} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-15.8 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $wfile $wfile} msg] $msg
} "1 {channel \"$wfile\" wasn't opened for reading}"
test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $rfile} msg] $msg
} "1 {channel \"$rfile\" wasn't opened for writing}"
test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile foo bar} msg] $msg
} {1 {bad switch "foo": must be -size or -command}}
test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile -size foo} msg] $msg
} {1 {expected integer but got "foo"}}
test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg
} {1 {expected integer but got "foo"}}
close $rfile
close $wfile
# cleanup
foreach file [list test1 test2 test3 test4] {
removeFile $file
}
# delay long enough for background processes to finish
after 500
foreach file [list test5] {
removeFile $file
}
cleanupTests
return
tcl8.4.20/tests/namespace.test 0000644 0036047 0045461 00000150731 12133546540 014716 0 ustar dgp 771div # Functionality covered: this file contains a collection of tests for the
# procedures in tclNamesp.c that implement Tcl's basic support for
# namespaces. Other namespace-related tests appear in variable.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}
test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
namespace children :: test_ns_*
} {}
catch {unset l}
test namespace-2.1 {Tcl_GetCurrentNamespace} {
list [namespace current] [namespace eval {} {namespace current}] \
[namespace eval {} {namespace current}]
} {:: :: ::}
test namespace-2.2 {Tcl_GetCurrentNamespace} {
set l {}
lappend l [namespace current]
namespace eval test_ns_1 {
lappend l [namespace current]
namespace eval foo {
lappend l [namespace current]
}
}
lappend l [namespace current]
set l
} {:: ::test_ns_1 ::test_ns_1::foo ::}
test namespace-3.1 {Tcl_GetGlobalNamespace} {
namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } }
# namespace children uses Tcl_GetGlobalNamespace
namespace eval test_ns_1 {namespace children foo b*}
} {::test_ns_1::foo::bar}
test namespace-4.1 {Tcl_PushCallFrame with isProcCallFrame=1} {
namespace eval test_ns_1 {
variable v 123
proc p {} {
variable v
return $v
}
}
test_ns_1::p ;# does Tcl_PushCallFrame to push p's namespace
} {123}
test namespace-4.2 {Tcl_PushCallFrame with isProcCallFrame=0} {
namespace eval test_ns_1::baz {} ;# does Tcl_PushCallFrame to create baz
proc test_ns_1::baz::p {} {
variable v
set v 789
set v}
test_ns_1::baz::p
} {789}
test namespace-5.1 {Tcl_PopCallFrame, no vars} {
namespace eval test_ns_1::blodge {} ;# pushes then pops frame
} {}
test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} {
proc test_ns_1::r {} {
set a 123
}
test_ns_1::r ;# pushes then pop's r's frame
} {123}
test namespace-6.1 {Tcl_CreateNamespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [lsort [namespace children :: test_ns_*]] \
[namespace eval test_ns_1 {namespace current}] \
[namespace eval test_ns_2 {namespace current}] \
[namespace eval ::test_ns_3 {namespace current}] \
[namespace eval ::test_ns_4 \
{namespace eval foo {namespace current}}] \
[namespace eval ::test_ns_5 \
{namespace eval ::test_ns_6 {namespace current}}] \
[lsort [namespace children :: test_ns_*]]
} {{} ::test_ns_1 ::test_ns_2 ::test_ns_3 ::test_ns_4::foo ::test_ns_6 {::test_ns_1 ::test_ns_2 ::test_ns_3 ::test_ns_4 ::test_ns_5 ::test_ns_6}}
test namespace-6.2 {Tcl_CreateNamespace, odd number of :'s in name is okay} {
list [namespace eval :::test_ns_1::::foo {namespace current}] \
[namespace eval test_ns_2:::::foo {namespace current}]
} {::test_ns_1::foo ::test_ns_2::foo}
test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg
} {0 ::test_ns_7}
test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1:: {
namespace eval test_ns_2:: {}
namespace eval test_ns_3:: {}
}
lsort [namespace children ::test_ns_1]
} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_3}]
test namespace-6.5 {Tcl_CreateNamespace, relative ns names now only looked up in current ns} {
set trigger {
namespace eval test_ns_2 {namespace current}
}
set l {}
lappend l [namespace eval test_ns_1 $trigger]
namespace eval test_ns_1::test_ns_2 {}
lappend l [namespace eval test_ns_1 $trigger]
} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_2}
test namespace-7.1 {Tcl_DeleteNamespace, active call frames in ns} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc p {} {
namespace delete [namespace current]
return [namespace current]
}
}
list [test_ns_1::p] [catch {test_ns_1::p} msg] $msg
} {::test_ns_1 1 {invalid command name "test_ns_1::p"}}
test namespace-7.2 {Tcl_DeleteNamespace, no active call frames in ns} {
namespace eval test_ns_2 {
proc p {} {
return [namespace current]
}
}
list [test_ns_2::p] [namespace delete test_ns_2]
} {::test_ns_2 {}}
test namespace-7.3 {recursive Tcl_DeleteNamespace, active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
set x 1
trace add variable x unset "namespace delete [namespace current];#"
namespace delete [namespace current]
}
} {}
test namespace-7.4 {recursive Tcl_DeleteNamespace, active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
proc x {} {}
trace add command x delete "namespace delete [namespace current];#"
namespace delete [namespace current]
}
} {}
test namespace-7.5 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
set x 1
trace add variable x unset "namespace delete [namespace current];#"
}
namespace delete test_ns_2
} {}
test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
proc x {} {}
trace add command x delete "namespace delete [namespace current];#"
}
namespace delete test_ns_2
} {}
test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
namespace eval test_ns_1 {
namespace export p
proc p {} {
return [namespace current]
}
}
namespace eval test_ns_2 {
namespace import ::test_ns_1::p
variable v 27
proc q {} {
variable v
return "[p] $v"
}
}
set x [test_ns_2::q]
catch {set xxxx}
}
list [interp eval test_interp {test_ns_2::q}] \
[interp eval test_interp {namespace delete ::}] \
[catch {interp eval test_interp {set a 123}} msg] $msg \
[interp delete test_interp]
} {{::test_ns_1 27} {} 1 {invalid command name "set"} {}}
test namespace-8.2 {TclTeardownNamespace, remove deleted ns from parent} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}}
namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}}
list [namespace children test_ns_1] \
[namespace delete test_ns_1::test_ns_2] \
[namespace children test_ns_1]
} {::test_ns_1::test_ns_2 {} {}}
test namespace-8.3 {TclTeardownNamespace, delete child namespaces} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}}
namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}}
list [namespace children test_ns_1] \
[namespace delete test_ns_1::test_ns_2] \
[namespace children test_ns_1] \
[catch {namespace children test_ns_1::test_ns_2} msg] $msg \
[info commands test_ns_1::test_ns_2::test_ns_3a::*]
} {::test_ns_1::test_ns_2 {} {} 1 {unknown namespace "test_ns_1::test_ns_2" in namespace children command} {}}
test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1 cmd2
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_import {
namespace import ::test_ns_export::*
proc p {} {return foo}
}
list [lsort [info commands test_ns_import::*]] \
[namespace delete test_ns_export] \
[info commands test_ns_import::*]
} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p]
test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
interp create slave
slave eval {trace add execution error leave {namespace delete :: ;#}}
catch {slave eval error foo bar baz}
interp delete slave
set ::errorInfo
} {bar
invoked from within
"slave eval error foo bar baz"}
test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
interp create slave
slave eval {trace add variable errorCode write {namespace delete :: ;#}}
catch {slave eval error foo bar baz}
interp delete slave
set ::errorInfo
} {bar
invoked from within
"slave eval error foo bar baz"}
test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
interp create slave
slave eval {trace add execution error leave {namespace delete :: ;#}}
catch {slave eval error foo bar baz}
interp delete slave
set ::errorCode
} baz
test namespace-9.1 {Tcl_Import, empty import pattern} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace eval test_ns_import {namespace import {}}} msg] $msg
} {1 {empty import pattern}}
test namespace-9.2 {Tcl_Import, unknown namespace in import pattern} {
list [catch {namespace eval test_ns_import {namespace import fred::x}} msg] $msg
} {1 {unknown namespace in import pattern "fred::x"}}
test namespace-9.3 {Tcl_Import, import ns == export ns} {
list [catch {namespace eval test_ns_import {namespace import ::test_ns_import::puts}} msg] $msg
} {1 {import pattern "::test_ns_import::puts" tries to import from namespace "test_ns_import" into itself}}
test namespace-9.4 {Tcl_Import, simple import} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_import {
namespace import ::test_ns_export::*
proc p {} {return [cmd1 123]}
}
test_ns_import::p
} {cmd1: 123}
test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} {
list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
} {0 {}}
test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} {
namespace eval test_ns_import {
namespace import -force ::test_ns_export::*
cmd1 555
}
} {cmd1: 555}
test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
}
namespace eval test_ns_import {
namespace import -force ::test_ns_export::*
}
list [test_ns_import::cmd1 a b c] \
[test_ns_export::cmd1 d e f] \
[proc test_ns_export::cmd1 {args} {return "new1: $args"}] \
[namespace origin test_ns_import::cmd1] \
[namespace origin test_ns_export::cmd1] \
[test_ns_import::cmd1 g h i] \
[test_ns_export::cmd1 j k l]
} {{cmd1: a b c} {cmd1: d e f} {} ::test_ns_export::cmd1 ::test_ns_export::cmd1 {new1: g h i} {new1: j k l}}
test namespace-9.8 {Tcl_Import: Bug 1017299} -setup {
namespace eval one {
namespace export cmd
proc cmd {} {}
}
namespace eval two {
namespace export cmd
proc other args {}
}
namespace eval two \
[list namespace import [namespace current]::one::cmd]
namespace eval three \
[list namespace import [namespace current]::two::cmd]
namespace eval three {
rename cmd other
namespace export other
}
} -body {
namespace eval two [list namespace import -force \
[namespace current]::three::other]
namespace origin two::other
} -cleanup {
namespace delete one two three
} -match glob -result *::one::cmd
test namespace-9.9 {Tcl_Import: Bug 1017299} -setup {
namespace eval one {
namespace export cmd
proc cmd {} {}
}
namespace eval two namespace export cmd
namespace eval two \
[list namespace import [namespace current]::one::cmd]
namespace eval three namespace export cmd
namespace eval three \
[list namespace import [namespace current]::two::cmd]
} -body {
namespace eval two [list namespace import -force \
[namespace current]::three::cmd]
namespace origin two::cmd
} -cleanup {
namespace delete one two three
} -returnCodes error -match glob -result {import pattern * would create a loop*}
test namespace-10.1 {Tcl_ForgetImport, check for valid namespaces} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace forget xyzzy::*} msg] $msg
} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}}
test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} {
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_import {
namespace forget ::test_ns_export::wombat
}
} {}
test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} {
namespace eval test_ns_import {
namespace import ::test_ns_export::*
proc p {} {return [cmd1 123]}
set l {}
lappend l [lsort [info commands ::test_ns_import::*]]
namespace forget ::test_ns_export::cmd1
lappend l [info commands ::test_ns_import::*]
lappend l [catch {cmd1 777} msg] $msg
}
} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}]
test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval unrelated {
proc cmd {} {}
}
namespace eval my \
[list namespace import [namespace current]::origin::cmd]
} -body {
namespace eval my \
[list namespace forget [namespace current]::unrelated::cmd]
my::cmd
} -cleanup {
namespace delete origin unrelated my
}
test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval my \
[list namespace import [namespace current]::origin::cmd]
namespace eval my rename cmd newname
} -body {
namespace eval my \
[list namespace forget [namespace current]::origin::cmd]
my::newname
} -cleanup {
namespace delete origin my
} -returnCodes error -match glob -result *
test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval my \
[list namespace import [namespace current]::origin::cmd]
namespace eval your {}
namespace eval my \
[list rename cmd [namespace current]::your::newname]
} -body {
namespace eval your namespace forget newname
your::newname
} -cleanup {
namespace delete origin my your
} -returnCodes error -match glob -result *
test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval link namespace export cmd
namespace eval link \
[list namespace import [namespace current]::origin::cmd]
namespace eval link2 namespace export cmd
namespace eval link2 \
[list namespace import [namespace current]::link::cmd]
namespace eval my \
[list namespace import [namespace current]::link2::cmd]
} -body {
namespace eval my \
[list namespace forget [namespace current]::origin::cmd]
my::cmd
} -cleanup {
namespace delete origin link link2 my
} -returnCodes error -match glob -result *
test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval link namespace export cmd
namespace eval link \
[list namespace import [namespace current]::origin::cmd]
namespace eval link2 namespace export cmd
namespace eval link2 \
[list namespace import [namespace current]::link::cmd]
namespace eval my \
[list namespace import [namespace current]::link2::cmd]
} -body {
namespace eval my \
[list namespace forget [namespace current]::link::cmd]
my::cmd
} -cleanup {
namespace delete origin link link2 my
}
test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval link namespace export cmd
namespace eval link \
[list namespace import [namespace current]::origin::cmd]
namespace eval link2 namespace export cmd
namespace eval link2 \
[list namespace import [namespace current]::link::cmd]
namespace eval my \
[list namespace import [namespace current]::link2::cmd]
} -body {
namespace eval my \
[list namespace forget [namespace current]::link2::cmd]
my::cmd
} -cleanup {
namespace delete origin link link2 my
} -returnCodes error -match glob -result *
test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
}
list [namespace origin set] [namespace origin test_ns_export::cmd1]
} {::set ::test_ns_export::cmd1}
test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} {
namespace eval test_ns_import1 {
namespace import ::test_ns_export::*
namespace export *
proc p {} {namespace origin cmd1}
}
list [test_ns_import1::p] [namespace origin test_ns_import1::cmd1]
} {::test_ns_export::cmd1 ::test_ns_export::cmd1}
test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} {
namespace eval test_ns_import2 {
namespace import ::test_ns_import1::*
proc q {} {return [cmd1 123]}
}
list [test_ns_import2::q] [namespace origin test_ns_import2::cmd1]
} {{cmd1: 123} ::test_ns_export::cmd1}
test namespace-12.1 {InvokeImportedCmd} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {namespace current}
}
namespace eval test_ns_import {
namespace import ::test_ns_export::*
}
list [test_ns_import::cmd1]
} {::test_ns_export}
test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} {
namespace eval test_ns_import {
set l {}
lappend l [info commands ::test_ns_import::*]
namespace forget ::test_ns_export::cmd1
lappend l [info commands ::test_ns_import::*]
}
} {::test_ns_import::cmd1 {}}
test namespace-14.1 {TclGetNamespaceForQualName, absolute names} {
catch {eval namespace delete [namespace children :: test_ns_*]}
variable v 10
namespace eval test_ns_1::test_ns_2 {
variable v 20
}
namespace eval test_ns_2 {
variable v 30
}
namespace eval test_ns_1 {
list $::v $::test_ns_2::v $::test_ns_1::test_ns_2::v \
[lsort [namespace children :: test_ns_*]]
}
} [list 10 30 20 [lsort {::test_ns_1 ::test_ns_2}]]
test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} {
namespace eval test_ns_1 {
list [catch {set ::test_ns_777::v} msg] $msg \
[catch {namespace children test_ns_777} msg] $msg
}
} {1 {can't read "::test_ns_777::v": no such variable} 1 {unknown namespace "test_ns_777" in namespace children command}}
test namespace-14.3 {TclGetNamespaceForQualName, relative names} {
namespace eval test_ns_1 {
list $v $test_ns_2::v
}
} {10 20}
test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
namespace eval test_ns_1::test_ns_2 {
namespace eval foo {}
}
namespace eval test_ns_1 {
list [namespace children test_ns_2] \
[catch {namespace children test_ns_1} msg] $msg
}
} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}}
test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
namespace eval ::test_ns_2 {
namespace eval bar {}
}
namespace eval test_ns_1 {
set l [list [catch {namespace delete test_ns_2::bar} msg] $msg]
}
set l
} {1 {unknown namespace "test_ns_2::bar" in namespace delete command}}
test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
namespace eval test_ns_1::test_ns_2 {
namespace eval foo {}
}
namespace eval test_ns_1 {
list [namespace children test_ns_2] \
[catch {namespace children test_ns_1} msg] $msg
}
} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}}
test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} {
namespace children test_ns_1:::
} {::test_ns_1::test_ns_2}
test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} {
namespace children :::test_ns_1:::::test_ns_2:::
} {::test_ns_1::test_ns_2::foo}
test namespace-14.9 {TclGetNamespaceForQualName, extra ::s are significant for vars} {
set l {}
lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg
namespace eval test_ns_1::test_ns_2 {variable {} 2525}
lappend l [set test_ns_1::test_ns_2::]
} {1 {can't read "test_ns_1::test_ns_2::": no such variable} 2525}
test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} {
catch {unset test_ns_1::test_ns_2::}
set l {}
lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg
set test_ns_1::test_ns_2:: 314159
lappend l [set test_ns_1::test_ns_2::]
} {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159}
test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} {
catch {rename test_ns_1::test_ns_2:: {}}
set l {}
lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg
proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"}
lappend l [test_ns_1::test_ns_2:: hello]
} {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}}
test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
variable {}
set test_ns_1::(x) y
}
set test_ns_1::(x)
} y
test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace eval test_ns_1 {proc {} {} {}; namespace eval {} {}; {}}} msg] $msg
} {1 {can't create namespace "": only global namespace can have empty name}}
test namespace-15.1 {Tcl_FindNamespace, absolute name found} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_delete {
namespace eval test_ns_delete2 {}
proc cmd {args} {namespace current}
}
list [namespace delete ::test_ns_delete::test_ns_delete2] \
[namespace children ::test_ns_delete]
} {{} {}}
test namespace-15.2 {Tcl_FindNamespace, absolute name not found} {
list [catch {namespace delete ::test_ns_delete::test_ns_delete2} msg] $msg
} {1 {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command}}
test namespace-15.3 {Tcl_FindNamespace, relative name found} {
namespace eval test_ns_delete {
namespace eval test_ns_delete2 {}
namespace eval test_ns_delete3 {}
list [namespace delete test_ns_delete2] \
[namespace children [namespace current]]
}
} {{} ::test_ns_delete::test_ns_delete3}
test namespace-15.4 {Tcl_FindNamespace, relative name not found} {
namespace eval test_ns_delete2 {}
namespace eval test_ns_delete {
list [catch {namespace delete test_ns_delete2} msg] $msg
}
} {1 {unknown namespace "test_ns_delete2" in namespace delete command}}
test namespace-16.1 {Tcl_FindCommand, absolute name found} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc cmd {args} {return "[namespace current]::cmd: $args"}
variable v "::test_ns_1::cmd"
eval $v one
}
} {::test_ns_1::cmd: one}
test namespace-16.2 {Tcl_FindCommand, absolute name found} {
eval $test_ns_1::v two
} {::test_ns_1::cmd: two}
test namespace-16.3 {Tcl_FindCommand, absolute name not found} {
namespace eval test_ns_1 {
variable v2 "::test_ns_1::ladidah"
list [catch {eval $v2} msg] $msg
}
} {1 {invalid command name "::test_ns_1::ladidah"}}
# save the "unknown" proc, which is redefined by the following two tests
catch {rename unknown unknown.old}
proc unknown {args} {
return "unknown: $args"
}
test namespace-16.4 {Tcl_FindCommand, absolute name and TCL_GLOBAL_ONLY} {
::test_ns_1::foobar x y z
} {unknown: ::test_ns_1::foobar x y z}
test namespace-16.5 {Tcl_FindCommand, absolute name and TCL_GLOBAL_ONLY} {
::foobar 1 2 3 4 5
} {unknown: ::foobar 1 2 3 4 5}
test namespace-16.6 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} {
test_ns_1::foobar x y z
} {unknown: test_ns_1::foobar x y z}
test namespace-16.7 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} {
foobar 1 2 3 4 5
} {unknown: foobar 1 2 3 4 5}
# restore the "unknown" proc saved previously
catch {rename unknown {}}
catch {rename unknown.old unknown}
test namespace-16.8 {Tcl_FindCommand, relative name found} {
namespace eval test_ns_1 {
cmd a b c
}
} {::test_ns_1::cmd: a b c}
test namespace-16.9 {Tcl_FindCommand, relative name found} {
catch {rename cmd2 {}}
proc cmd2 {args} {return "[namespace current]::cmd2: $args"}
namespace eval test_ns_1 {
cmd2 a b c
}
} {::::cmd2: a b c}
test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current then global ns} {
namespace eval test_ns_1 {
proc cmd2 {args} {
return "[namespace current]::cmd2 in test_ns_1: $args"
}
namespace eval test_ns_12 {
cmd2 a b c
}
}
} {::::cmd2: a b c}
test namespace-16.11 {Tcl_FindCommand, relative name not found} {
namespace eval test_ns_1 {
list [catch {cmd3 a b c} msg] $msg
}
} {1 {invalid command name "cmd3"}}
catch {unset x}
test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} {
catch {eval namespace delete [namespace children :: test_ns_*]}
set x 314159
namespace eval test_ns_1 {
set ::x
}
} {314159}
test namespace-17.2 {Tcl_FindNamespaceVar, absolute name found} {
namespace eval test_ns_1 {
variable x 777
set ::test_ns_1::x
}
} {777}
test namespace-17.3 {Tcl_FindNamespaceVar, absolute name found} {
namespace eval test_ns_1 {
namespace eval test_ns_2 {
variable x 1111
}
set ::test_ns_1::test_ns_2::x
}
} {1111}
test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} {
namespace eval test_ns_1 {
namespace eval test_ns_2 {
variable x 1111
}
list [catch {set ::test_ns_1::test_ns_2::y} msg] $msg
}
} {1 {can't read "::test_ns_1::test_ns_2::y": no such variable}}
test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} {
namespace eval test_ns_1 {
namespace eval test_ns_3 {
variable ::test_ns_1::test_ns_2::x 2222
}
}
set ::test_ns_1::test_ns_2::x
} {2222}
test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} {
namespace eval test_ns_1 {
set x
}
} {777}
test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} {
namespace eval test_ns_1 {
unset x
set x ;# must be global x now
}
} {314159}
test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} {
namespace eval test_ns_1 {
list [catch {set wuzzat} msg] $msg
}
} {1 {can't read "wuzzat": no such variable}}
test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} {
namespace eval test_ns_1 {
variable a hello
}
set test_ns_1::a
} {hello}
catch {unset x}
catch {unset l}
catch {rename foo {}}
test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} {
catch {eval namespace delete [namespace children :: test_ns_*]}
proc foo {} {return "global foo"}
namespace eval test_ns_1 {
proc trigger {} {
return [foo]
}
}
set l ""
lappend l [test_ns_1::trigger]
namespace eval test_ns_1 {
# force invalidation of cached ref to "foo" in proc trigger
proc foo {} {return "foo in test_ns_1"}
}
lappend l [test_ns_1::trigger]
set l
} {{global foo} {foo in test_ns_1}}
test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} {
namespace eval test_ns_2 {
proc foo {} {return "foo in ::test_ns_2"}
}
namespace eval test_ns_1 {
namespace eval test_ns_2 {}
proc trigger {} {
return [test_ns_2::foo]
}
}
set l ""
lappend l [test_ns_1::trigger]
namespace eval test_ns_1 {
namespace eval test_ns_2 {
# force invalidation of cached ref to "foo" in proc trigger
proc foo {} {return "foo in ::test_ns_1::test_ns_2"}
}
}
lappend l [test_ns_1::trigger]
set l
} {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}}
catch {unset l}
catch {rename foo {}}
test namespace-19.1 {GetNamespaceFromObj, global name found} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
namespace children ::test_ns_1
} {::test_ns_1::test_ns_2}
test namespace-19.2 {GetNamespaceFromObj, relative name found} {
namespace eval test_ns_1 {
namespace children test_ns_2
}
} {}
test namespace-19.3 {GetNamespaceFromObj, name not found} {
namespace eval test_ns_1 {
list [catch {namespace children test_ns_99} msg] $msg
}
} {1 {unknown namespace "test_ns_99" in namespace children command}}
test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} {
namespace eval test_ns_1 {
proc foo {} {
return [namespace children test_ns_2]
}
list [catch {namespace children test_ns_99} msg] $msg
}
set l {}
lappend l [test_ns_1::foo]
namespace delete test_ns_1::test_ns_2
namespace eval test_ns_1::test_ns_2::test_ns_3 {}
lappend l [test_ns_1::foo]
set l
} {{} ::test_ns_1::test_ns_2::test_ns_3}
test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace} msg] $msg
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} {
list [catch {namespace wombat {}} msg] $msg
} {1 {bad option "wombat": must be children, code, current, delete, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
namespace ch :: test_ns_*
} {}
test namespace-21.1 {NamespaceChildrenCmd, no args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
expr {[string first ::test_ns_1 [namespace children]] != -1}
} {1}
test namespace-21.2 {NamespaceChildrenCmd, no args} {
namespace eval test_ns_1 {
namespace children
}
} {::test_ns_1::test_ns_2}
test namespace-21.3 {NamespaceChildrenCmd, ns name given} {
namespace children ::test_ns_1
} {::test_ns_1::test_ns_2}
test namespace-21.4 {NamespaceChildrenCmd, ns name given} {
namespace eval test_ns_1 {
namespace children test_ns_2
}
} {}
test namespace-21.5 {NamespaceChildrenCmd, too many args} {
namespace eval test_ns_1 {
list [catch {namespace children test_ns_2 xxx yyy} msg] $msg
}
} {1 {wrong # args: should be "namespace children ?name? ?pattern?"}}
test namespace-21.6 {NamespaceChildrenCmd, glob-style pattern given} {
namespace eval test_ns_1::test_ns_foo {}
namespace children test_ns_1 *f*
} {::test_ns_1::test_ns_foo}
test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} {
namespace eval test_ns_1::test_ns_foo {}
lsort [namespace children test_ns_1 test*]
} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}]
test namespace-22.1 {NamespaceCodeCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace code} msg] $msg \
[catch {namespace code xxx yyy} msg] $msg
} {1 {wrong # args: should be "namespace code arg"} 1 {wrong # args: should be "namespace code arg"}}
test namespace-22.2 {NamespaceCodeCmd, arg is already scoped value} {
namespace eval test_ns_1 {
proc cmd {} {return "test_ns_1::cmd"}
}
namespace code {namespace inscope ::test_ns_1 cmd}
} {namespace inscope ::test_ns_1 cmd}
test namespace-22.3 {NamespaceCodeCmd, arg is already scoped value} {
namespace code {namespace inscope ::test_ns_1 cmd}
} {namespace inscope ::test_ns_1 cmd}
test namespace-22.4 {NamespaceCodeCmd, in :: namespace} {
namespace code unknown
} {::namespace inscope :: unknown}
test namespace-22.5 {NamespaceCodeCmd, in other namespace} {
namespace eval test_ns_1 {
namespace code cmd
}
} {::namespace inscope ::test_ns_1 cmd}
test namespace-22.6 {NamespaceCodeCmd, in other namespace} {
namespace eval test_ns_1 {
variable v 42
}
namespace eval test_ns_2 {
proc namespace args {}
}
namespace eval test_ns_2 [namespace eval test_ns_1 {
namespace code {set v}
}]
} {42}
test namespace-23.1 {NamespaceCurrentCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace current xxx} msg] $msg \
[catch {namespace current xxx yyy} msg] $msg
} {1 {wrong # args: should be "namespace current"} 1 {wrong # args: should be "namespace current"}}
test namespace-23.2 {NamespaceCurrentCmd, at global level} {
namespace current
} {::}
test namespace-23.3 {NamespaceCurrentCmd, in nested ns} {
namespace eval test_ns_1::test_ns_2 {
namespace current
}
} {::test_ns_1::test_ns_2}
test namespace-24.1 {NamespaceDeleteCmd, no args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace delete
} {}
test namespace-24.2 {NamespaceDeleteCmd, one arg} {
namespace eval test_ns_1::test_ns_2 {}
namespace delete ::test_ns_1
} {}
test namespace-24.3 {NamespaceDeleteCmd, two args} {
namespace eval test_ns_1::test_ns_2 {}
list [namespace delete ::test_ns_1::test_ns_2] [namespace delete ::test_ns_1]
} {{} {}}
test namespace-24.4 {NamespaceDeleteCmd, unknown ns} {
list [catch {namespace delete ::test_ns_foo} msg] $msg
} {1 {unknown namespace "::test_ns_foo" in namespace delete command}}
test namespace-25.1 {NamespaceEvalCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace eval} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-25.2 {NamespaceEvalCmd, bad args} {
list [catch {namespace test_ns_1} msg] $msg
} {1 {bad option "test_ns_1": must be children, code, current, delete, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
set v 123
namespace eval test_ns_1 {
variable v 314159
proc p {} {
variable v
return $v
}
}
test_ns_1::p
} {314159}
test namespace-25.4 {NamespaceEvalCmd, existing namespace} {
namespace eval test_ns_1 {
proc q {} {return [expr {[p]+1}]}
}
test_ns_1::q
} {314160}
test namespace-25.5 {NamespaceEvalCmd, multiple args} {
namespace eval test_ns_1 "set" "v"
} {314159}
test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} {
list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $errorInfo
} {1 {invalid command name "xxxx"} {invalid command name "xxxx"
while executing
"xxxx"
(in namespace eval "::test_ns_1" script line 1)
invoked from within
"namespace eval test_ns_1 {xxxx}"}}
test namespace-25.7 {NamespaceEvalCmd, error in eval'd script} {
list [catch {namespace eval test_ns_1 {error foo bar baz}} msg] $msg $errorInfo
} {1 foo {bar
(in namespace eval "::test_ns_1" script line 1)
invoked from within
"namespace eval test_ns_1 {error foo bar baz}"}}
test namespace-25.8 {NamespaceEvalCmd, error in eval'd script} knownBug {
list [catch {namespace eval test_ns_1 error foo bar baz} msg] $msg $errorInfo
} {1 foo {bar
(in namespace eval "::test_ns_1" script line 1)
invoked from within
"namespace eval test_ns_1 error foo bar baz"}}
catch {unset v}
test namespace-25.9 {NamespaceEvalCmd, 545325} {
namespace eval test_ns_1 info level 0
} {namespace eval test_ns_1 info level 0}
test namespace-26.1 {NamespaceExportCmd, no args and new ns} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace export
} {}
test namespace-26.2 {NamespaceExportCmd, just -clear arg} {
namespace export -clear
} {}
test namespace-26.3 {NamespaceExportCmd, pattern can't specify a namespace} {
namespace eval test_ns_1 {
list [catch {namespace export ::zzz} msg] $msg
}
} {1 {invalid export pattern "::zzz": pattern can't specify a namespace}}
test namespace-26.4 {NamespaceExportCmd, one pattern} {
namespace eval test_ns_1 {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
proc cmd3 {args} {return "cmd3: $args"}
proc cmd4 {args} {return "cmd4: $args"}
}
namespace eval test_ns_2 {
namespace import ::test_ns_1::*
}
list [info commands test_ns_2::*] [test_ns_2::cmd1 hello]
} {::test_ns_2::cmd1 {cmd1: hello}}
test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} {
namespace eval test_ns_1 {
namespace export cmd1 cmd3
}
namespace eval test_ns_2 {
namespace import -force ::test_ns_1::*
}
list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd3 hello]
} [list [lsort {::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd3: hello}]
test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} {
namespace eval test_ns_1 {
namespace export
}
} {cmd1 cmd3}
test namespace-26.7 {NamespaceExportCmd, -clear resets export list} {
namespace eval test_ns_1 {
namespace export -clear cmd4
}
namespace eval test_ns_2 {
namespace import ::test_ns_1::*
}
list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello]
} [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}]
test namespace-26.8 {NamespaceExportCmd, -clear resets export list} {
catch {namespace delete foo}
namespace eval foo {
namespace export x
namespace export -clear
}
list [namespace eval foo namespace export] [namespace delete foo]
} {{} {}}
test namespace-27.1 {NamespaceForgetCmd, no args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace forget
} {}
test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} {
list [catch {namespace forget ::test_ns_1::xxx} msg] $msg
} {1 {unknown namespace in namespace forget pattern "::test_ns_1::xxx"}}
test namespace-27.3 {NamespaceForgetCmd, arg is forgotten} {
namespace eval test_ns_1 {
namespace export cmd*
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_2 {
namespace import ::test_ns_1::*
namespace forget ::test_ns_1::cmd1
}
info commands ::test_ns_2::*
} {::test_ns_2::cmd2}
test namespace-28.1 {NamespaceImportCmd, no args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace import
} {}
test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} {
namespace import -force
} {}
test namespace-28.3 {NamespaceImportCmd, arg is imported} {
namespace eval test_ns_1 {
namespace export cmd2
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_2 {
namespace import ::test_ns_1::*
namespace forget ::test_ns_1::cmd1
}
info commands test_ns_2::*
} {::test_ns_2::cmd2}
test namespace-29.1 {NamespaceInscopeCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace inscope} msg] $msg
} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}}
test namespace-29.2 {NamespaceInscopeCmd, bad args} {
list [catch {namespace inscope ::} msg] $msg
} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}}
test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} {
list [catch {namespace inscope test_ns_1 {set v}} msg] $msg
} {1 {unknown namespace "test_ns_1" in inscope namespace command}}
test namespace-29.4 {NamespaceInscopeCmd, simple case} {
namespace eval test_ns_1 {
variable v 747
proc cmd {args} {
variable v
return "[namespace current]::cmd: v=$v, args=$args"
}
}
namespace inscope test_ns_1 cmd
} {::test_ns_1::cmd: v=747, args=}
test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} {
list [namespace inscope test_ns_1 cmd x y z] \
[namespace eval test_ns_1 [concat cmd [list x y z]]]
} {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}}
test namespace-29.6 {NamespaceInscopeCmd, 1400572} knownBug {
namespace inscope test_ns_1 {info level 0}
} {namespace inscope test_ns_1 {info level 0}}
test namespace-30.1 {NamespaceOriginCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace origin} msg] $msg
} {1 {wrong # args: should be "namespace origin name"}}
test namespace-30.2 {NamespaceOriginCmd, bad args} {
list [catch {namespace origin x y} msg] $msg
} {1 {wrong # args: should be "namespace origin name"}}
test namespace-30.3 {NamespaceOriginCmd, command not found} {
list [catch {namespace origin fred} msg] $msg
} {1 {invalid command name "fred"}}
test namespace-30.4 {NamespaceOriginCmd, command isn't imported} {
namespace origin set
} {::set}
test namespace-30.5 {NamespaceOriginCmd, imported command} {
namespace eval test_ns_1 {
namespace export cmd*
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_2 {
namespace export *
namespace import ::test_ns_1::*
proc p {} {}
}
namespace eval test_ns_3 {
namespace import ::test_ns_2::*
list [namespace origin foreach] \
[namespace origin p] \
[namespace origin cmd1] \
[namespace origin ::test_ns_2::cmd2]
}
} {::foreach ::test_ns_2::p ::test_ns_1::cmd1 ::test_ns_1::cmd2}
test namespace-31.1 {NamespaceParentCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace parent a b} msg] $msg
} {1 {wrong # args: should be "namespace parent ?name?"}}
test namespace-31.2 {NamespaceParentCmd, no args} {
namespace parent
} {}
test namespace-31.3 {NamespaceParentCmd, namespace specified} {
namespace eval test_ns_1 {
namespace eval test_ns_2 {
namespace eval test_ns_3 {}
}
}
list [namespace parent ::] \
[namespace parent test_ns_1::test_ns_2] \
[namespace eval test_ns_1::test_ns_2::test_ns_3 {namespace parent ::test_ns_1::test_ns_2}]
} {{} ::test_ns_1 ::test_ns_1}
test namespace-31.4 {NamespaceParentCmd, bad namespace specified} {
list [catch {namespace parent test_ns_1::test_ns_foo} msg] $msg
} {1 {unknown namespace "test_ns_1::test_ns_foo" in namespace parent command}}
test namespace-32.1 {NamespaceQualifiersCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace qualifiers} msg] $msg
} {1 {wrong # args: should be "namespace qualifiers string"}}
test namespace-32.2 {NamespaceQualifiersCmd, bad args} {
list [catch {namespace qualifiers x y} msg] $msg
} {1 {wrong # args: should be "namespace qualifiers string"}}
test namespace-32.3 {NamespaceQualifiersCmd, simple name} {
namespace qualifiers foo
} {}
test namespace-32.4 {NamespaceQualifiersCmd, leading ::} {
namespace qualifiers ::x::y::z
} {::x::y}
test namespace-32.5 {NamespaceQualifiersCmd, no leading ::} {
namespace qualifiers a::b
} {a}
test namespace-32.6 {NamespaceQualifiersCmd, :: argument} {
namespace qualifiers ::
} {}
test namespace-32.7 {NamespaceQualifiersCmd, odd number of :s} {
namespace qualifiers :::::
} {}
test namespace-32.8 {NamespaceQualifiersCmd, odd number of :s} {
namespace qualifiers foo:::
} {foo}
test namespace-33.1 {NamespaceTailCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace tail} msg] $msg
} {1 {wrong # args: should be "namespace tail string"}}
test namespace-33.2 {NamespaceTailCmd, bad args} {
list [catch {namespace tail x y} msg] $msg
} {1 {wrong # args: should be "namespace tail string"}}
test namespace-33.3 {NamespaceTailCmd, simple name} {
namespace tail foo
} {foo}
test namespace-33.4 {NamespaceTailCmd, leading ::} {
namespace tail ::x::y::z
} {z}
test namespace-33.5 {NamespaceTailCmd, no leading ::} {
namespace tail a::b
} {b}
test namespace-33.6 {NamespaceTailCmd, :: argument} {
namespace tail ::
} {}
test namespace-33.7 {NamespaceTailCmd, odd number of :s} {
namespace tail :::::
} {}
test namespace-33.8 {NamespaceTailCmd, odd number of :s} {
namespace tail foo:::
} {}
test namespace-34.1 {NamespaceWhichCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace which} msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-34.2 {NamespaceWhichCmd, bad args} {
list [catch {namespace which -fred} msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-34.3 {NamespaceWhichCmd, bad args} {
list [catch {namespace which -command} msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-34.4 {NamespaceWhichCmd, bad args} {
list [catch {namespace which a b} msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-34.5 {NamespaceWhichCmd, command lookup} {
namespace eval test_ns_1 {
namespace export cmd*
variable v1 111
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_2 {
namespace export *
namespace import ::test_ns_1::*
variable v2 222
proc p {} {}
}
namespace eval test_ns_3 {
namespace import ::test_ns_2::*
variable v3 333
list [namespace which -command foreach] \
[namespace which -command p] \
[namespace which -command cmd1] \
[namespace which -command ::test_ns_2::cmd2] \
[catch {namespace which -command ::test_ns_2::noSuchCmd} msg] $msg
}
} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}}
test namespace-34.6 {NamespaceWhichCmd, -command is default} {
namespace eval test_ns_3 {
list [namespace which foreach] \
[namespace which p] \
[namespace which cmd1] \
[namespace which ::test_ns_2::cmd2]
}
} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2}
test namespace-34.7 {NamespaceWhichCmd, variable lookup} {
namespace eval test_ns_3 {
list [namespace which -variable env] \
[namespace which -variable v3] \
[namespace which -variable ::test_ns_2::v2] \
[catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg
}
} {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}}
test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc p {} {
namespace delete [namespace current]
return [namespace current]
}
}
test_ns_1::p
} {::test_ns_1}
test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} {
namespace eval test_ns_1 {
proc q {} {
return [namespace current]
}
}
list [test_ns_1::q] \
[namespace delete test_ns_1] \
[catch {test_ns_1::q} msg] $msg
} {::test_ns_1 {} 1 {invalid command name "test_ns_1::q"}}
catch {unset x}
catch {unset y}
test namespace-36.1 {DupNsNameInternalRep} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {}
set x "::test_ns_1"
list [namespace parent $x] [set y $x] [namespace parent $y]
} {:: ::test_ns_1 ::}
catch {unset x}
catch {unset y}
test namespace-37.1 {SetNsNameFromAny, ns name found} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
namespace eval test_ns_1 {
namespace children ::test_ns_1
}
} {::test_ns_1::test_ns_2}
test namespace-37.2 {SetNsNameFromAny, ns name not found} {
namespace eval test_ns_1 {
list [catch {namespace children ::test_ns_1::test_ns_foo} msg] $msg
}
} {1 {unknown namespace "::test_ns_1::test_ns_foo" in namespace children command}}
test namespace-38.1 {UpdateStringOfNsName} {
catch {eval namespace delete [namespace children :: test_ns_*]}
;# Tcl_NamespaceObjCmd calls UpdateStringOfNsName to get subcmd name
list [namespace eval {} {namespace current}] \
[namespace eval {} {namespace current}]
} {:: ::}
test namespace-39.1 {NamespaceExistsCmd} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval ::test_ns_z::test_me { variable foo }
list [namespace exists ::] \
[namespace exists ::bogus_namespace] \
[namespace exists ::test_ns_z] \
[namespace exists test_ns_z] \
[namespace exists ::test_ns_z::foo] \
[namespace exists ::test_ns_z::test_me] \
[namespace eval ::test_ns_z { namespace exists ::test_me }] \
[namespace eval ::test_ns_z { namespace exists test_me }] \
[namespace exists :::::test_ns_z]
} {1 0 1 1 0 1 0 1 1}
test namespace-39.2 {NamespaceExistsCmd error} {
list [catch {namespace exists} msg] $msg
} {1 {wrong # args: should be "namespace exists name"}}
test namespace-39.3 {NamespaceExistsCmd error} {
list [catch {namespace exists a b} msg] $msg
} {1 {wrong # args: should be "namespace exists name"}}
test namespace-40.1 {Ignoring namespace proc "unknown"} {
rename unknown _unknown
proc unknown args {return global}
namespace eval ns {proc unknown args {return local}}
set l [list [namespace eval ns aaa bbb] [namespace eval ns aaa]]
rename unknown {}
rename _unknown unknown
namespace delete ns
set l
} {global global}
test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} {
set res {}
namespace eval ns {
set res {}
proc test {} {
set ::g 0
}
lappend ::res [test]
proc set {a b} {
::set a [incr b]
}
lappend ::res [test]
}
namespace delete ns
set res
} {0 1}
test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} {
set res {}
namespace eval ns {}
proc ns::a {i} {
variable b
proc set args {return "New proc is called"}
return [set b $i]
}
ns::a 1
set res [ns::a 2]
namespace delete ns
set res
} {New proc is called}
test namespace-41.3 {Shadowing byte-compiled commands, Bug: 231259} {knownBug} {
set res {}
namespace eval ns {
variable b 0
}
proc ns::a {i} {
variable b
proc set args {return "New proc is called"}
return [set b $i]
}
set res [list [ns::a 1] $ns::b]
namespace delete ns
set res
} {{New proc is called} 0}
# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
eval namespace delete [namespace children :: test_ns_*]
::tcltest::cleanupTests
return
tcl8.4.20/tests/indexObj.test 0000644 0036047 0045461 00000012013 11737050674 014521 0 ustar dgp 771div # This file is a Tcl script to test out the the procedures in file
# tkIndexObj.c, which implement indexed table lookups. The tests here
# are organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {[info commands testindexobj] == {}} {
puts "This application hasn't been compiled with the \"testindexobj\""
puts "command, so I can't test Tcl_GetIndexFromObj etc."
::tcltest::cleanupTests
return
}
test indexObj-1.1 {exact match} {
testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} {
testindexobj 1 1 abc abc def xyz alm
} {0}
test indexObj-1.3 {exact match} {
testindexobj 1 1 alm abc def xyz alm
} {3}
test indexObj-1.4 {unique abbreviation} {
testindexobj 1 1 xy abc def xalb xyz alm
} {3}
test indexObj-1.5 {multiple abbreviations and exact match} {
testindexobj 1 1 x abc def xalb xyz alm x
} {5}
test indexObj-1.6 {forced exact match} {
testindexobj 1 0 xy abc def xalb xy alm
} {3}
test indexObj-1.7 {forced exact match} {
testindexobj 1 0 x abc def xalb xyz alm x
} {5}
test indexObj-1.8 {exact match of empty values} {
testindexobj 1 1 {} a aa aaa {} b bb bbb
} 3
test indexObj-1.9 {exact match of empty values} {
testindexobj 1 0 {} a aa aaa {} b bb bbb
} 3
test indexObj-2.1 {no match} {
list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg
} {1 {bad token "dddd": must be abc, def, xalb, xyz, alm, or x}}
test indexObj-2.2 {no match} {
list [catch {testindexobj 1 1 dddd abc} msg] $msg
} {1 {bad token "dddd": must be abc}}
test indexObj-2.3 {no match: no abbreviations} {
list [catch {testindexobj 1 0 xy abc def xalb xyz alm} msg] $msg
} {1 {bad token "xy": must be abc, def, xalb, xyz, or alm}}
test indexObj-2.4 {ambiguous value} {
list [catch {testindexobj 1 1 d dumb daughter a c} msg] $msg
} {1 {ambiguous token "d": must be dumb, daughter, a, or c}}
test indexObj-2.5 {omit error message} {
list [catch {testindexobj 0 1 d x} msg] $msg
} {1 {}}
test indexObj-2.6 {TCL_EXACT => no "ambiguous" error message} {
list [catch {testindexobj 1 0 d dumb daughter a c} msg] $msg
} {1 {bad token "d": must be dumb, daughter, a, or c}}
test indexObj-2.7 {exact match of empty values} {
list [catch {testindexobj 1 1 {} a b c} msg] $msg
} {1 {ambiguous token "": must be a, b, or c}}
test indexObj-2.8 {exact match of empty values: singleton case} {
list [catch {testindexobj 1 0 {} a} msg] $msg
} {1 {bad token "": must be a}}
test indexObj-2.9 {non-exact match of empty values: singleton case} {
# NOTE this is a special case. Although the empty string is a
# unique prefix, we have an established history of rejecting
# empty lookup keys, requiring any unique prefix match to have
# at least one character.
list [catch {testindexobj 1 1 {} a} msg] $msg
} {1 {bad token "": must be a}}
test indexObj-3.1 {cache result to skip next lookup} {
testindexobj check 42
} {42}
test indexObj-4.1 {free old internal representation} {
set x {a b}
lindex $x 1
testindexobj 1 1 $x abc def {a b} zzz
} {2}
test indexObj-5.1 {Tcl_WrongNumArgs} {
testwrongnumargs 1 "?option?" mycmd
} "wrong # args: should be \"mycmd ?option?\""
test indexObj-5.2 {Tcl_WrongNumArgs} {
testwrongnumargs 2 "bar" mycmd foo
} "wrong # args: should be \"mycmd foo bar\""
test indexObj-5.3 {Tcl_WrongNumArgs} {
testwrongnumargs 0 "bar" mycmd foo
} "wrong # args: should be \"bar\""
test indexObj-5.4 {Tcl_WrongNumArgs} {
testwrongnumargs 0 "" mycmd foo
} "wrong # args: should be \"\""
test indexObj-5.5 {Tcl_WrongNumArgs} {
testwrongnumargs 1 "" mycmd foo
} "wrong # args: should be \"mycmd\""
test indexObj-5.6 {Tcl_WrongNumArgs} {
testwrongnumargs 2 "" mycmd foo
} "wrong # args: should be \"mycmd foo\""
# Contrast this with test proc-3.6; they have to be like this because
# of [Bug 1066837] so Itcl won't break.
test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj {
testwrongnumargs 2 "fee fi" "fo fum" foo bar
} "wrong # args: should be \"fo fum foo fee fi\""
test indexObj-6.1 {Tcl_GetIndexFromObjStruct} {
set x a
testgetindexfromobjstruct $x 0
} "wrong # args: should be \"testgetindexfromobjstruct a 0\""
test indexObj-6.2 {Tcl_GetIndexFromObjStruct} {
set x a
testgetindexfromobjstruct $x 0
testgetindexfromobjstruct $x 0
} "wrong # args: should be \"testgetindexfromobjstruct a 0\""
test indexObj-6.3 {Tcl_GetIndexFromObjStruct} {
set x c
testgetindexfromobjstruct $x 1
} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
test indexObj-6.4 {Tcl_GetIndexFromObjStruct} {
set x c
testgetindexfromobjstruct $x 1
testgetindexfromobjstruct $x 1
} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/regexpComp.test 0000644 0036047 0045461 00000055736 11737050674 015113 0 ustar dgp 771div # Commands covered: regexp, regsub
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Procedure to evaluate a script within a proc, to test compilation
# functionality
proc evalInProc { script } {
proc testProc {} $script
set status [catch {
testProc
} result]
rename testProc {}
return $result
#return [list $status $result]
}
catch {unset foo}
test regexpComp-1.1 {basic regexp operation} {
evalInProc {
regexp ab*c abbbc
}
} 1
test regexpComp-1.2 {basic regexp operation} {
evalInProc {
regexp ab*c ac
}
} 1
test regexpComp-1.3 {basic regexp operation} {
evalInProc {
regexp ab*c ab
}
} 0
test regexpComp-1.4 {basic regexp operation} {
evalInProc {
regexp -- -gorp abc-gorpxxx
}
} 1
test regexpComp-1.5 {basic regexp operation} {
evalInProc {
regexp {^([^ ]*)[ ]*([^ ]*)} "" a
}
} 1
test regexpComp-1.6 {basic regexp operation} {
list [catch {regexp {} abc} msg] $msg
} {0 1}
test regexpComp-1.7 {regexp utf compliance} {
# if not UTF-8 aware, result is "0 1"
evalInProc {
set foo "\u4e4eb q"
regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
list [string compare $foo $bar] [regexp 4 $bar]
}
} {0 0}
test regexpComp-2.1 {getting substrings back from regexp} {
evalInProc {
set foo {}
list [regexp ab*c abbbbc foo] $foo
}
} {1 abbbbc}
test regexpComp-2.2 {getting substrings back from regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp a(b*)c abbbbc foo f2] $foo $f2
}
} {1 abbbbc bbbb}
test regexpComp-2.3 {getting substrings back from regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp a(b*)(c) abbbbc foo f2] $foo $f2
}
} {1 abbbbc bbbb}
test regexpComp-2.4 {getting substrings back from regexp} {
evalInProc {
set foo {}
set f2 {}
set f3 {}
list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
}
} {1 abbbbc bbbb c}
test regexpComp-2.5 {getting substrings back from regexp} {
evalInProc {
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
set f6 {}; set f7 {}; set f8 {}; set f9 {}; set fa {}; set fb {};
list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*)(a*)(b*) \
12223345556789999aabbb \
foo f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb] $foo $f1 $f2 $f3 $f4 $f5 \
$f6 $f7 $f8 $f9 $fa $fb
}
} {1 12223345556789999aabbb 1 222 33 4 555 6 7 8 9999 aa bbb}
test regexpComp-2.6 {getting substrings back from regexp} {
evalInProc {
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 a a {} {}}
test regexpComp-2.7 {getting substrings back from regexp} {
evalInProc {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 ac a {} c}
test regexpComp-2.8 {getting substrings back from regexp} {
evalInProc {
set match {}
list [regexp {^a*b} aaaab match] $match
}
} {1 aaaab}
test regexpComp-3.1 {-indices option to regexp} {
evalInProc {
set foo {}
list [regexp -indices ab*c abbbbc foo] $foo
}
} {1 {0 5}}
test regexpComp-3.2 {-indices option to regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2
}
} {1 {0 5} {1 4}}
test regexpComp-3.3 {-indices option to regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2
}
} {1 {0 5} {1 4}}
test regexpComp-3.4 {-indices option to regexp} {
evalInProc {
set foo {}
set f2 {}
set f3 {}
list [regexp -indices a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
}
} {1 {0 5} {1 4} {5 5}}
test regexpComp-3.5 {-indices option to regexp} {
evalInProc {
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
set f6 {}; set f7 {}; set f8 {}; set f9 {}
list [regexp -indices (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) \
12223345556789999 \
foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \
$f6 $f7 $f8 $f9
}
} {1 {0 16} {0 0} {1 3} {4 5} {6 6} {7 9} {10 10} {11 11} {12 12} {13 16}}
test regexpComp-3.6 {getting substrings back from regexp} {
evalInProc {
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 {1 1} {1 1} {-1 -1} {-1 -1}}
test regexpComp-3.7 {getting substrings back from regexp} {
evalInProc {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 {1 2} {1 1} {-1 -1} {2 2}}
test regexpComp-4.1 {-nocase option to regexp} {
evalInProc {
regexp -nocase foo abcFOo
}
} 1
test regexpComp-4.2 {-nocase option to regexp} {
evalInProc {
set f1 22
set f2 33
set f3 44
list [regexp -nocase {a(b*)([xy]*)z} aBbbxYXxxZ22 f1 f2 f3] $f1 $f2 $f3
}
} {1 aBbbxYXxxZ Bbb xYXxx}
test regexpComp-4.3 {-nocase option to regexp} {
evalInProc {
regexp -nocase FOo abcFOo
}
} 1
set ::x abcdefghijklmnopqrstuvwxyz1234567890
set ::x $x$x$x$x$x$x$x$x$x$x$x$x
test regexpComp-4.4 {case conversion in regexp} {
evalInProc {
list [regexp -nocase $::x $::x foo] $foo
}
} "1 $x"
catch {unset ::x}
test regexpComp-5.1 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*a bbba
}
} 1
test regexpComp-5.2 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*b xxxb
}
} 1
test regexpComp-5.3 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*c yyyc
}
} 1
test regexpComp-5.4 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*d 1d
}
} 1
test regexpComp-5.5 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*e xe
}
} 1
test regexpComp-6.1 {regexp errors} {
evalInProc {
list [catch {regexp a} msg] $msg
}
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
test regexpComp-6.2 {regexp errors} {
evalInProc {
list [catch {regexp -nocase a} msg] $msg
}
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
test regexpComp-6.3 {regexp errors} {
evalInProc {
list [catch {regexp -gorp a} msg] $msg
}
} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-6.4 {regexp errors} {
evalInProc {
list [catch {regexp a( b} msg] $msg
}
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-6.5 {regexp errors} {
evalInProc {
list [catch {regexp a( b} msg] $msg
}
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-6.6 {regexp errors} {
evalInProc {
list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
}
} {0 1}
test regexpComp-6.7 {regexp errors} {
evalInProc {
list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
}
} {0 0}
test regexpComp-6.8 {regexp errors} {
evalInProc {
catch {unset f1}
set f1 44
list [catch {regexp abc abc f1(f2)} msg] $msg
}
} {1 {couldn't set variable "f1(f2)"}}
test regexpComp-6.9 {regexp errors, -start bad int check} {
evalInProc {
list [catch {regexp -start bogus {^$} {}} msg] $msg
}
} {1 {expected integer but got "bogus"}}
test regexpComp-7.1 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
}
} {1 xax111aaa222xaa}
test regexpComp-7.2 {basic regsub operation} {
evalInProc {
list [regsub aa+ aaaxaa &111 foo] $foo
}
} {1 aaa111xaa}
test regexpComp-7.3 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaa 111& foo] $foo
}
} {1 xax111aaa}
test regexpComp-7.4 {basic regsub operation} {
evalInProc {
list [regsub aa+ aaa 11&2&333 foo] $foo
}
} {1 11aaa2aaa333}
test regexpComp-7.5 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaaxaa &2&333 foo] $foo
}
} {1 xaxaaa2aaa333xaa}
test regexpComp-7.6 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaaxaa 1&22& foo] $foo
}
} {1 xax1aaa22aaaxaa}
test regexpComp-7.7 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo
}
} {1 xax1aa22aaxaa}
test regexpComp-7.8 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo
}
} "1 {xax1\\aa22aaxaa}"
test regexpComp-7.9 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo
}
} "1 {xax1\\122aaxaa}"
test regexpComp-7.10 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo
}
} "1 {xax1\\aaaaaxaa}"
test regexpComp-7.11 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo
}
} {1 xax1&aaxaa}
test regexpComp-7.12 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo
}
} {1 xaxaaaaaaaaaaaaaaxaa}
test regexpComp-7.13 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub abc xyz 111 foo] $foo
}
} {0 xyz}
test regexpComp-7.14 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub ^ xyz "111 " foo] $foo
}
} {1 {111 xyz}}
test regexpComp-7.15 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub -- -foo abc-foodef "111 " foo] $foo
}
} {1 {abc111 def}}
test regexpComp-7.16 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub x "" y foo] $foo
}
} {0 {}}
test regexpComp-7.17 {regsub utf compliance} {
evalInProc {
# if not UTF-8 aware, result is "0 1"
set foo "xyz555ijka\u4e4ebpqr"
regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
list [string compare $foo $bar] [regexp 4 $bar]
}
} {0 0}
test regexpComp-8.1 {case conversion in regsub} {
evalInProc {
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
}
} {1 xaAAaAAay}
test regexpComp-8.2 {case conversion in regsub} {
evalInProc {
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
}
} {1 xaAAaAAay}
test regexpComp-8.3 {case conversion in regsub} {
evalInProc {
set foo 123
list [regsub a(a+) xaAAaAAay & foo] $foo
}
} {0 xaAAaAAay}
test regexpComp-8.4 {case conversion in regsub} {
evalInProc {
set foo 123
list [regsub -nocase a CaDE b foo] $foo
}
} {1 CbDE}
test regexpComp-8.5 {case conversion in regsub} {
evalInProc {
set foo 123
list [regsub -nocase XYZ CxYzD b foo] $foo
}
} {1 CbD}
test regexpComp-8.6 {case conversion in regsub} {
evalInProc {
set x abcdefghijklmnopqrstuvwxyz1234567890
set x $x$x$x$x$x$x$x$x$x$x$x$x
set foo 123
list [regsub -nocase $x $x b foo] $foo
}
} {1 b}
test regexpComp-9.1 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub -all x+ axxxbxxcxdx |&| foo] $foo
}
} {4 a|xxx|b|xx|c|x|d|x|}
test regexpComp-9.2 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo
}
} {4 a|XxX|b|xx|c|X|d|x|}
test regexpComp-9.3 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub x+ axxxbxxcxdx |&| foo] $foo
}
} {1 a|xxx|bxxcxdx}
test regexpComp-9.4 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub -all bc axxxbxxcxdx |&| foo] $foo
}
} {0 axxxbxxcxdx}
test regexpComp-9.5 {-all option to regsub} {
evalInProc {
set foo xxx
list [regsub -all node "node node more" yy foo] $foo
}
} {2 {yy yy more}}
test regexpComp-9.6 {-all option to regsub} {
evalInProc {
set foo xxx
list [regsub -all ^ xxx 123 foo] $foo
}
} {1 123xxx}
test regexpComp-10.1 {expanded syntax in regsub} {
evalInProc {
set foo xxx
list [regsub -expanded ". \#comment\n . \#comment2" abc def foo] $foo
}
} {1 defc}
test regexpComp-10.2 {newline sensitivity in regsub} {
evalInProc {
set foo xxx
list [regsub -line {^a.*b$} "dabc\naxyb\n" 123 foo] $foo
}
} "1 {dabc\n123\n}"
test regexpComp-10.3 {newline sensitivity in regsub} {
evalInProc {
set foo xxx
list [regsub -line {^a.*b$} "dabc\naxyb\nxb" 123 foo] $foo
}
} "1 {dabc\n123\nxb}"
test regexpComp-10.4 {partial newline sensitivity in regsub} {
evalInProc {
set foo xxx
list [regsub -lineanchor {^a.*b$} "da\naxyb\nxb" 123 foo] $foo
}
} "1 {da\n123}"
test regexpComp-10.5 {inverse partial newline sensitivity in regsub} {
evalInProc {
set foo xxx
list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
}
} "1 {da\nb123\nxb}"
test regexpComp-11.1 {regsub errors} {
evalInProc {
list [catch {regsub a b} msg] $msg
}
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexpComp-11.2 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a b} msg] $msg
}
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexpComp-11.3 {regsub errors} {
evalInProc {
list [catch {regsub -nocase -all a b} msg] $msg
}
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexpComp-11.4 {regsub errors} {
evalInProc {
list [catch {regsub a b c d e f} msg] $msg
}
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexpComp-11.5 {regsub errors} {
evalInProc {
list [catch {regsub -gorp a b c} msg] $msg
}
} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexpComp-11.6 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a( b c d} msg] $msg
}
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-11.7 {regsub errors} {
evalInProc {
catch {unset f1}
set f1 44
list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
}
} {1 {couldn't set variable "f1(f2)"}}
test regexpComp-11.8 {regsub errors, -start bad int check} {
evalInProc {
list [catch {regsub -start bogus pattern string rep var} msg] $msg
}
} {1 {expected integer but got "bogus"}}
# This test crashes on the Mac unless you increase the Stack Space to about 1
# Meg. This is probably bigger than most users want...
# 8.2.3 regexp reduced stack space requirements, but this should be
# tested again
test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} {
evalInProc {
list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all a b c d e f g h i j k l m n o p q r s t u v w x y z] $all $a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s $t $u $v $w $x $y $z
}
} {1 abcdefghijklmnopqrstuvwxyz a b c d e f g h i j k l m n o p q r s t u v w x y z}
test regexpComp-13.1 {regsub of a very large string} {
# This test is designed to stress the memory subsystem in order
# to catch Bug #933. It only fails if the Tcl memory allocator
# is in use.
set line {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE}
set filedata [string repeat $line 200]
for {set i 1} {$i<10} {incr i} {
regsub -all "BEGIN_TABLE " $filedata "" newfiledata
}
set x done
} {done}
test regexpComp-14.1 {CompileRegexp: regexp cache} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
set x .
append x *a
regexp $x bbba
}
} 1
test regexpComp-14.2 {CompileRegexp: regexp cache, different flags} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
set x .
append x *a
regexp -nocase $x bbba
}
} 1
testConstraint exec [llength [info commands exec]]
test regexpComp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -constraints {
exec
} -setup {
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
test regexpComp-15.1 {regexp -start} {
catch {unset x}
list [regexp -start -10 {\d} 1abc2de3 x] $x
} {1 1}
test regexpComp-15.2 {regexp -start} {
catch {unset x}
list [regexp -start 2 {\d} 1abc2de3 x] $x
} {1 2}
test regexpComp-15.3 {regexp -start} {
catch {unset x}
list [regexp -start 4 {\d} 1abc2de3 x] $x
} {1 2}
test regexpComp-15.4 {regexp -start} {
catch {unset x}
list [regexp -start 5 {\d} 1abc2de3 x] $x
} {1 3}
test regexpComp-15.5 {regexp -start, over end of string} {
catch {unset x}
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexpComp-15.6 {regexp -start, loss of ^$ behavior} {
list [regexp -start 2 {^$} {}]
} {0}
test regexpComp-16.1 {regsub -start} {
catch {unset x}
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} {4 a1b/2c/3d/4e/5}
test regexpComp-16.2 {regsub -start} {
catch {unset x}
list [regsub -all -start -25 {z} hello {/&} x] $x
} {0 hello}
test regexpComp-16.3 {regsub -start} {
catch {unset x}
list [regsub -all -start 3 {z} hello {/&} x] $x
} {0 hello}
test regexpComp-16.4 {regsub -start, \A behavior} {
set out {}
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
} {5 /a/b/c/d/e 3 ab/c/d/e}
test regexpComp-17.1 {regexp -inline} {
regexp -inline b ababa
} {b}
test regexpComp-17.2 {regexp -inline} {
regexp -inline (b) ababa
} {b b}
test regexpComp-17.3 {regexp -inline -indices} {
regexp -inline -indices (b) ababa
} {{1 1} {1 1}}
test regexpComp-17.4 {regexp -inline} {
regexp -inline {\w(\d+)\w} " hello 23 there456def "
} {e456d 456}
test regexpComp-17.5 {regexp -inline no matches} {
regexp -inline {\w(\d+)\w} ""
} {}
test regexpComp-17.6 {regexp -inline no matches} {
regexp -inline hello goodbye
} {}
test regexpComp-17.7 {regexp -inline, no matchvars allowed} {
list [catch {regexp -inline b abc match} msg] $msg
} {1 {regexp match variables not allowed when using -inline}}
test regexpComp-18.1 {regexp -all} {
regexp -all b bbbbb
} {5}
test regexpComp-18.2 {regexp -all} {
regexp -all b abababbabaaaaaaaaaab
} {6}
test regexpComp-18.3 {regexp -all -inline} {
regexp -all -inline b abababbabaaaaaaaaaab
} {b b b b b b}
test regexpComp-18.4 {regexp -all -inline} {
regexp -all -inline {\w(\w)} abcdefg
} {ab b cd d ef f}
test regexpComp-18.5 {regexp -all -inline} {
regexp -all -inline {\w(\w)$} abcdefg
} {fg g}
test regexpComp-18.6 {regexp -all -inline} {
regexp -all -inline {\d+} 10:20:30:40
} {10 20 30 40}
test regexpComp-18.7 {regexp -all -inline} {
list [catch {regexp -all -inline b abc match} msg] $msg
} {1 {regexp match variables not allowed when using -inline}}
test regexpComp-18.8 {regexp -all} {
# This should not cause an infinite loop
regexp -all -inline {a*} a
} {a}
test regexpComp-18.9 {regexp -all} {
# Yes, the expected result is {a {}}. Here's why:
# Start at index 0; a* matches the "a" there then stops.
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
# that a* matches zero or more "a"'s; thus it matches the string "b", as
# there are zero or more "a"'s there.
# Go to index 2; this is past the end of the string, so stop.
regexp -all -inline {a*} ab
} {a {}}
test regexpComp-18.10 {regexp -all} {
# Yes, the expected result is {a {} a}. Here's why:
# Start at index 0; a* matches the "a" there then stops.
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
# that a* matches zero or more "a"'s; thus it matches the string "b", as
# there are zero or more "a"'s there.
# Go to index 2; a* matches the "a" there then stops.
# Go to index 3; this is past the end of the string, so stop.
regexp -all -inline {a*} aba
} {a {} a}
test regexpComp-18.11 {regexp -all} {
evalInProc {
regexp -all -inline {^a} aaaa
}
} {a}
test regexpComp-18.12 {regexp -all -inline -indices} {
evalInProc {
regexp -all -inline -indices a(b(c)d|e(f)g)h abcdhaefgh
}
} {{0 4} {1 3} {2 2} {-1 -1} {5 9} {6 8} {-1 -1} {7 7}}
test regexpComp-19.1 {regsub null replacement} {
evalInProc {
regsub -all {@} {@hel@lo@} "\0a\0" result
list $result [string length $result]
}
} "\0a\0hel\0a\0lo\0a\0 14"
test regexpComp-20.1 {regsub shared object shimmering} {
evalInProc {
# Bug #461322
set a abcdefghijklmnopqurstuvwxyz
set b $a
set c abcdefghijklmnopqurstuvwxyz0123456789
regsub $a $c $b d
list $d [string length $d] [string bytelength $d]
}
} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
test regexpComp-20.2 {regsub shared object shimmering with -about} {
evalInProc {
eval regexp -about abc
}
} {0 {}}
test regexpComp-21.1 {regexp command compiling tests} {
evalInProc {
regexp foo bar
}
} 0
test regexpComp-21.2 {regexp command compiling tests} {
evalInProc {
regexp {^foo$} dogfood
}
} 0
test regexpComp-21.3 {regexp command compiling tests} {
evalInProc {
set a foo
regexp {^foo$} $a
}
} 1
test regexpComp-21.4 {regexp command compiling tests} {
evalInProc {
regexp foo dogfood
}
} 1
test regexpComp-21.5 {regexp command compiling tests} {
evalInProc {
regexp -nocase FOO dogfod
}
} 0
test regexpComp-21.6 {regexp command compiling tests} {
evalInProc {
regexp -n foo dogfoOd
}
} 1
test regexpComp-21.7 {regexp command compiling tests} {
evalInProc {
regexp -no -- FoO dogfood
}
} 1
test regexpComp-21.8 {regexp command compiling tests} {
evalInProc {
regexp -- foo dogfod
}
} 0
test regexpComp-21.9 {regexp command compiling tests} {
evalInProc {
list [catch {regexp -- -nocase foo dogfod} msg] $msg
}
} {0 0}
test regexpComp-21.10 {regexp command compiling tests} {
evalInProc {
list [regsub -all "" foo bar str] $str
}
} {3 barfbarobaro}
test regexpComp-21.11 {regexp command compiling tests} {
evalInProc {
list [regsub -all "" "" bar str] $str
}
} {0 {}}
set i 0
foreach {str exp result} {
foo ^foo 1
foobar ^foobar$ 1
foobar bar$ 1
foobar ^$ 0
"" ^$ 1
anything $ 1
anything ^.*$ 1
anything ^.*a$ 0
anything ^.*a.*$ 1
anything ^.*.*$ 1
anything ^.*..*$ 1
anything ^.*b$ 0
anything ^a.*$ 1
} {
test regexpComp-22.[incr i] {regexp command compiling tests} \
[subst {evalInProc {set a "$str"; regexp {$exp} \$a}}] $result
}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/security.test 0000644 0036047 0045461 00000001544 11737050674 014635 0 ustar dgp 771div # security.test --
#
# Functionality covered: this file contains a collection of tests for the
# auto loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# If this proc becomes invoked, then there is a bug
proc BUG {args} {
set ::BUG 1
}
# Check and Clear the bug flag (to do before each test)
set ::BUG 0
proc CB {} {
set ret $::BUG
set ::BUG 0
return $ret
}
test sec-1.1 {tcl_endOfPreviousWord} {
catch {tcl_startOfPreviousWord x {[BUG]}}
CB
} 0
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/winFCmd.test 0000644 0036047 0045461 00000104550 12052456744 014315 0 ustar dgp 771div # This file tests the tclWinFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Initialise the test constraints
testConstraint winVista 0
testConstraint win2000orXP 0
testConstraint winOlderThan2000 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile [llength [info commands testfile]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint cdrom 0
testConstraint exdev 0
testConstraint longFileNames 0
proc createfile {file {string a}} {
set f [open $file w]
puts -nonewline $f $string
close $f
return $string
}
proc contents {file} {
set f [open $file r]
set r [read $f]
close $f
set r
}
proc cleanup {args} {
foreach p ". $args" {
set x ""
catch {
set x [glob -directory $p tf* td*]
}
if {$x != ""} {
catch {eval file delete -force -- $x}
}
}
}
if {[testConstraint winOnly]} {
set major [string index $tcl_platform(osVersion) 0]
if {[testConstraint nt] && $major > 4} {
if {$major > 5} {
testConstraint winVista 1
} elseif {$major == 5} {
testConstraint win2000orXP 1
}
} else {
testConstraint winOlderThan2000 1
}
}
# find a CD-ROM so we can test read-only filesystems.
set cdrom {}
if { [info commands ::testvolumetype] ne {} } {
foreach p {d e f g h i j k l m n o p q r s t u v w x y z} {
if { ! [catch { testvolumetype ${p}: } result] && $result eq {CDFS} } {
set cdrom ${p}:
}
}
}
proc findfile {dir} {
foreach p [glob $dir/*] {
if {[file type $p] == "file"} {
return $p
}
}
foreach p [glob $dir/*] {
if {[file type $p] == "directory"} {
set f [findfile $p]
if {$f != ""} {
return $f
}
}
}
return ""
}
if {$cdrom != ""} {
set ::tcltest::testConstraints(cdrom) 1
set cdfile [findfile $cdrom]
}
if {[file exists c:/] && [file exists d:/]} {
catch {file delete d:/tf1}
if {[catch {close [open d:/tf1 w]}] == 0} {
file delete d:/tf1
set ::tcltest::testConstraints(exdev) 1
}
}
file delete -force -- td1
set foo [catch {open td1 w} testfile]
if {$foo} {
set ::tcltest::testConstraints(longFileNames) 0
} else {
close $testfile
set ::tcltest::testConstraints(longFileNames) 1
file delete -force -- td1
}
# A really long file name
# length of longname is 1216 chars, which should be greater than any static
# buffer or allowable filename.
set longname "abcdefghihjllmnopqrstuvwxyz01234567890"
append longname $longname
append longname $longname
append longname $longname
append longname $longname
append longname $longname
# Uses the "testfile" command instead of the "file" command. The "file"
# command provides several layers of sanity checks on the arguments and
# it can be difficult to actually forward "insane" arguments to the
# low-level posix emulation layer.
test winFCmd-1.1 {TclpRenameFile: errno: EACCES} {pcOnly cdrom} {
list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} {pcOnly} {
cleanup
file mkdir td1/td2/td3
file mkdir td2
list [catch {testfile mv td2 td1/td2} msg] $msg
} {1 EEXIST}
test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {pcOnly} {
cleanup
list [catch {testfile mv / td1} msg] $msg
} {1 EINVAL}
test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} {pcOnly} {
cleanup
file mkdir td1
list [catch {testfile mv td1 td1/td2} msg] $msg
} {1 EINVAL}
test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} {pcOnly} {
cleanup
file mkdir td1
createfile tf1
list [catch {testfile mv tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-1.6 {TclpRenameFile: errno: ENOENT} {pcOnly} {
cleanup
list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.7 {TclpRenameFile: errno: ENOENT} {pcOnly} {
cleanup
list [catch {testfile mv "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.8 {TclpRenameFile: errno: ENOENT} {pcOnly} {
cleanup
createfile tf1
list [catch {testfile mv tf1 ""} msg] $msg
} {1 ENOENT}
test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} {pcOnly} {
cleanup
file mkdir td1
createfile tf1
list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR}
test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} {pcOnly exdev} {
file delete -force d:/tf1
file mkdir c:/tf1
set msg [list [catch {testfile mv c:/tf1 d:/tf1} msg] $msg]
file delete -force c:/tf1
set msg
} {1 EXDEV}
test winFCmd-1.11 {TclpRenameFile: errno: EACCES} {pcOnly} {
cleanup
set fd [open tf1 w]
set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
close $fd
set msg
} {1 EACCES}
test winFCmd-1.12 {TclpRenameFile: errno: EACCES} {pcOnly} {
cleanup
createfile tf1
set fd [open tf2 w]
set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
close $fd
set msg
} {1 EACCES}
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {pcOnly win2000orXP} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} {pcOnly winOlderThan2000} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {pcOnly 95} {
cleanup
createfile tf1
list [catch {testfile mv tf1 nul} msg] $msg
} {1 EACCES}
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {pcOnly nt} {
cleanup
createfile tf1
list [catch {testfile mv tf1 nul} msg] $msg
} {1 EEXIST}
test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} {pcOnly} {
cleanup
createfile tf1 tf1
testfile mv tf1 tf2
list [file exists tf1] [contents tf2]
} {0 tf1}
test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} {pcOnly} {
cleanup
list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {pcOnly} {
cleanup
list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {pcOnly win2000orXP} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} {pcOnly winOlderThan2000} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.20 {TclpRenameFile: src is dir} {pcOnly nt} {
# under 95, this would actually succeed and move the current dir out from
# under the current process!
cleanup
file delete /tf1
list [catch {testfile mv [pwd] /tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.21 {TclpRenameFile: long src} {pcOnly} {
cleanup
list [catch {testfile mv $longname tf1} msg] $msg
} {1 ENAMETOOLONG}
test winFCmd-1.22 {TclpRenameFile: long dst} {pcOnly} {
cleanup
createfile tf1
list [catch {testfile mv tf1 $longname} msg] $msg
} {1 ENAMETOOLONG}
test winFCmd-1.23 {TclpRenameFile: move dir into self} {pcOnly} {
cleanup
file mkdir td1
list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg
} {1 EINVAL}
test winFCmd-1.24 {TclpRenameFile: move a root dir} {pcOnly} {
cleanup
list [catch {testfile mv / c:/} msg] $msg
} {1 EINVAL}
test winFCmd-1.25 {TclpRenameFile: cross file systems} {pcOnly cdrom} {
cleanup
file mkdir td1
list [catch {testfile mv td1 $cdrom/td1} msg] $msg
} {1 EXDEV}
test winFCmd-1.26 {TclpRenameFile: readonly fs} {pcOnly cdrom} {
cleanup
list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-1.27 {TclpRenameFile: open file} {pcOnly} {
cleanup
set fd [open tf1 w]
set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
close $fd
set msg
} {1 EACCES}
test winFCmd-1.28 {TclpRenameFile: errno == EEXIST} {pcOnly} {
cleanup
createfile tf1
createfile tf2
testfile mv tf1 tf2
list [file exists tf1] [file exists tf2]
} {0 1}
test winFCmd-1.29 {TclpRenameFile: src is dir} {pcOnly} {
cleanup
file mkdir td1
createfile tf1
list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR}
test winFCmd-1.30 {TclpRenameFile: dst is dir} {pcOnly} {
cleanup
file mkdir td1
file mkdir td2/td2
list [catch {testfile mv td1 td2} msg] $msg
} {1 EEXIST}
test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} {pcOnly} {
cleanup
file mkdir td1
file mkdir td2/td2
list [catch {testfile mv td1 td2} msg] $msg
} {1 EEXIST}
test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} {pcOnly} {
cleanup
file mkdir td1/td2
file mkdir td2
testfile mv td1 td2
list [file exists td1] [file exists td2] [file exists td2/td2]
} {0 1 1}
test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \
{pcOnly exdev} {
file mkdir d:/td1
testchmod 000 d:/td1
file mkdir c:/tf1
set msg [list [catch {testfile mv c:/tf1 d:/td1} msg] $msg]
set msg "$msg [file writable d:/td1]"
file delete d:/td1
file delete -force c:/tf1
set msg
} {1 EXDEV 0}
test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} {pcOnly} {
file mkdir td1
createfile tf1
list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR}
test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} {pcOnly} {
file mkdir td1
createfile tf1
list [catch {testfile mv tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-1.36 {TclpRenameFile: src and dst not dir} {pcOnly} {
createfile tf1 tf1
createfile tf2 tf2
testfile mv tf1 tf2
contents tf2
} {tf1}
test winFCmd-1.37 {TclpRenameFile: need to restore temp file} {pcOnly} {
# Can't figure out how to cause this.
# Need a file that can't be copied.
} {}
test winFCmd-2.1 {TclpCopyFile: errno: EACCES} {pcOnly cdrom} {
cleanup
list [catch {testfile cp $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-2.2 {TclpCopyFile: errno: EISDIR} {pcOnly} {
cleanup
file mkdir td1
list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.3 {TclpCopyFile: errno: EISDIR} {pcOnly} {
cleanup
createfile tf1
file mkdir td1
list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-2.4 {TclpCopyFile: errno: ENOENT} {pcOnly} {
cleanup
list [catch {testfile cp tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.5 {TclpCopyFile: errno: ENOENT} {pcOnly} {
cleanup
list [catch {testfile cp "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {pcOnly} {
cleanup
createfile tf1
list [catch {testfile cp tf1 ""} msg] $msg
} {1 ENOENT}
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {pcOnly 95} {
cleanup
createfile tf1
set fd [open tf2 w]
set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
close $fd
set msg
} {1 EACCES}
test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {pcOnly win2000orXP} {
cleanup
list [catch {testfile cp nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} {pcOnly nt winOlderThan2000} {
cleanup
list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {pcOnly 95} {
cleanup
list [catch {testfile cp nul tf1} msg] $msg
} {1 ENOENT}
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} {pcOnly} {
cleanup
createfile tf1 tf1
testfile cp tf1 tf2
list [contents tf1] [contents tf2]
} {tf1 tf1}
test winFCmd-2.11 {TclpCopyFile: CopyFile succeeds} {pcOnly} {
cleanup
createfile tf1 tf1
createfile tf2 tf2
testfile cp tf1 tf2
list [contents tf1] [contents tf2]
} {tf1 tf1}
test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} {pcOnly} {
cleanup
createfile tf1 tf1
testchmod 000 tf1
testfile cp tf1 tf2
list [contents tf2] [file writable tf2]
} {tf1 0}
test winFCmd-2.13 {TclpCopyFile: CopyFile fails} {pcOnly} {
cleanup
createfile tf1
file mkdir td1
list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-2.14 {TclpCopyFile: errno == EACCES} {pcOnly} {
cleanup
file mkdir td1
list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.15 {TclpCopyFile: src is directory} {pcOnly} {
cleanup
file mkdir td1
list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.16 {TclpCopyFile: dst is directory} {pcOnly} {
cleanup
createfile tf1
file mkdir td1
list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-2.17 {TclpCopyFile: dst is readonly} {pcOnly} {
cleanup
createfile tf1 tf1
createfile tf2 tf2
testchmod 000 tf2
testfile cp tf1 tf2
list [file writable tf2] [contents tf2]
} {1 tf1}
test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} {pcOnly 95} {
cleanup
createfile tf1
createfile tf2
testchmod 000 tf2
set fd [open tf2]
set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
close $fd
set msg "$msg [file writable tf2]"
} {1 EACCES 0}
test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} {pcOnly cdrom} {
list [catch {testfile rm $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} {pcOnly} {
cleanup
file mkdir td1
list [catch {testfile rm td1} msg] $msg
} {1 EISDIR}
test winFCmd-3.3 {TclpDeleteFile: errno: ENOENT} {pcOnly} {
cleanup
list [catch {testfile rm tf1} msg] $msg
} {1 ENOENT}
test winFCmd-3.4 {TclpDeleteFile: errno: ENOENT} {pcOnly} {
cleanup
list [catch {testfile rm ""} msg] $msg
} {1 ENOENT}
test winFCmd-3.5 {TclpDeleteFile: errno: EACCES} {pcOnly} {
cleanup
set fd [open tf1 w]
set msg [list [catch {testfile rm tf1} msg] $msg]
close $fd
set msg
} {1 EACCES}
test winFCmd-3.6 {TclpDeleteFile: errno: EACCES} {pcOnly} {
cleanup
list [catch {testfile rm nul} msg] $msg
} {1 EACCES}
test winFCmd-3.7 {TclpDeleteFile: DeleteFile succeeds} {pcOnly} {
cleanup
createfile tf1
testfile rm tf1
file exists tf1
} {0}
test winFCmd-3.8 {TclpDeleteFile: DeleteFile fails} {pcOnly} {
cleanup
file mkdir td1
list [catch {testfile rm td1} msg] $msg
} {1 EISDIR}
test winFCmd-3.9 {TclpDeleteFile: errno == EACCES} {pcOnly} {
cleanup
set fd [open tf1 w]
set msg [list [catch {testfile rm tf1} msg] $msg]
close $fd
set msg
} {1 EACCES}
test winFCmd-3.10 {TclpDeleteFile: path is readonly} {pcOnly} {
cleanup
createfile tf1
testchmod 000 tf1
testfile rm tf1
file exists tf1
} {0}
test winFCmd-3.11 {TclpDeleteFile: still can't remove path} {pcOnly} {
cleanup
set fd [open tf1 w]
testchmod 000 tf1
set msg [list [catch {testfile rm tf1} msg] $msg]
close $fd
set msg
} {1 EACCES}
test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {pcOnly nt cdrom} {
list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 EACCES}
test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {pcOnly 95 cdrom} {
list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 ENOSPC}
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} {pcOnly} {
cleanup
file mkdir td1
list [catch {testfile mkdir td1} msg] $msg
} {1 EEXIST}
test winFCmd-4.4 {TclpCreateDirectory: errno: ENOENT} {pcOnly} {
cleanup
list [catch {testfile mkdir td1/td2} msg] $msg
} {1 ENOENT}
test winFCmd-4.5 {TclpCreateDirectory: CreateDirectory succeeds} {pcOnly} {
cleanup
testfile mkdir td1
file type td1
} {directory}
test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} {pcOnly} {
cleanup
file mkdir td1
testfile cpdir td1 td2
list [file type td1] [file type td2]
} {directory directory}
test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} {pcOnly} {
cleanup
file mkdir td1
testchmod 000 td1
catch {
testfile rmdir td1
file exists td1
} r
catch {
testchmod 777 td1
cleanup
}
set r
} {0}
test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} {pcOnly} {
cleanup
file mkdir td1/td2
list [catch {testfile rmdir td1} msg] [file tail $msg]
} {1 {td1 EEXIST}}
test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} {pcOnly} {
# can't test this w/o removing everything on your hard disk first!
# testfile rmdir /
} {}
test winFCmd-6.4 {TclpRemoveDirectory: errno: ENOENT} {pcOnly} {
cleanup
list [catch {testfile rmdir td1} msg] [file tail $msg]
} {1 {td1 ENOENT}}
test winFCmd-6.5 {TclpRemoveDirectory: errno: ENOENT} {pcOnly} {
cleanup
list [catch {testfile rmdir ""} msg] $msg
} {1 ENOENT}
test winFCmd-6.6 {TclpRemoveDirectory: errno: ENOTDIR} {pcOnly} {
cleanup
createfile tf1
list [catch {testfile rmdir tf1} msg] [file tail $msg]
} {1 {tf1 ENOTDIR}}
test winFCmd-6.7 {TclpRemoveDirectory: RemoveDirectory succeeds} {pcOnly} {
cleanup
file mkdir td1
testfile rmdir td1
file exists td1
} {0}
test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} {pcOnly} {
cleanup
createfile tf1
list [catch {testfile rmdir tf1} msg] [file tail $msg]
} {1 {tf1 ENOTDIR}}
test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {pcOnly} {
cleanup
file mkdir td1
testchmod 000 td1
catch {
testfile rmdir td1
file exists td1
} r
catch {
testchmod 777 td1
cleanup
}
set r
} {0}
test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {pcOnly 95} {
cleanup
list [catch {testfile rmdir nul} msg] $msg
} {1 {nul EACCES}}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {pcOnly nt} {
cleanup
set res [list [catch {testfile rmdir /} msg] $msg]
# WinXP returns EEXIST, WinNT seems to return EACCES. No policy
# decision has been made as to which is correct.
regsub {E(ACCES|EXIST)} $res "EACCES or EEXIST" res
# Don't mind which drive we're on
regsub {[A-Z]:} $res ""
} {1 {/ EACCES or EEXIST}}
test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {pcOnly 95} {
cleanup
createfile tf1
list [catch {testfile rmdir tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} {pcOnly} {
cleanup
file mkdir td1
testchmod 000 td1
catch {
testfile rmdir td1
file exists td1
} r
catch {
testchmod 777 td1
cleanup
}
set r
} {0}
test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {pcOnly 95} {
cleanup
file mkdir td1/td2
list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-6.15 {TclpRemoveDirectory: !recursive} {pcOnly} {
cleanup
file mkdir td1/td2
list [catch {testfile rmdir td1} msg] [file tail $msg]
} {1 {td1 EEXIST}}
test winFCmd-6.16 {TclpRemoveDirectory: recursive, but errno != EEXIST} {pcOnly} {
cleanup
createfile tf1
list [catch {testfile rmdir -force tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.17 {TclpRemoveDirectory: calls TraverseWinTree} {pcOnly} {
cleanup
file mkdir td1/td2
testfile rmdir -force td1
file exists td1
} {0}
test winFCmd-7.1 {TraverseWinTree: targetPtr == NULL} {pcOnly} {
cleanup
file mkdir td1/td2/td3
testfile rmdir -force td1
file exists td1
} {0}
test winFCmd-7.2 {TraverseWinTree: targetPtr != NULL} {pcOnly} {
cleanup
file mkdir td1/td2/td3
testfile cpdir td1 td2
list [file exists td1] [file exists td2]
} {1 1}
test winFCmd-7.3 {TraverseWinTree: sourceAttr == -1} {pcOnly} {
cleanup
list [catch {testfile cpdir td1 td2} msg] $msg
} {1 {td1 ENOENT}}
test winFCmd-7.4 {TraverseWinTree: source isn't directory} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
test winFCmd-7.5 {TraverseWinTree: call TraversalCopy: DOTREE_F} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
test winFCmd-7.6 {TraverseWinTree: call TraversalDelete: DOTREE_F} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile rmdir -force td1
file exists td1
} {0}
test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {pcOnly 95 cdrom} {
# cdrom can return either d:\ or D:/, but we only care about the errcode
list [catch {testfile rmdir $cdrom/} msg] [lindex $msg 1]
} {1 EEXIST}
test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {pcOnly nt cdrom} {
list [catch {testfile rmdir $cdrom/} msg] [lindex $msg 1]
} {1 EACCES}
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \
{pcOnly} {
# can't make it happen
} {}
test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testchmod 000 td1
catch {
testfile cpdir td1 td2
list [file exists td2] [file writable td2]
} r
catch {
testchmod 777 td1
cleanup
}
set r
} {1 1}
test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile rmdir -force td1
file exists td1
} {0}
test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {pcOnly 95} {
cleanup
file mkdir td1
list [catch {testfile cpdir td1 /} msg] $msg
} {1 {/ EEXIST}}
test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup {
cleanup
} -constraints {pcOnly nt} -body {
file mkdir td1
testfile cpdir td1 /
} -cleanup {
cleanup
# Windows7 returns EEXIST, XP returns EACCES
} -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$}
test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} {pcOnly} {
cleanup
file mkdir td1
testfile cpdir td1 td2
} {}
test winFCmd-7.17 {TraverseWinTree: recurse on files: one file} {pcOnly} {
cleanup
file mkdir td1
createfile td1/td2
testfile cpdir td1 td2
glob td2/*
} {td2/td2}
test winFCmd-7.18 {TraverseWinTree: recurse on files: several files and dir} \
{pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1
createfile td1/tf2
file mkdir td1/td2/td3
createfile td1/tf3
createfile td1/tf4
testfile cpdir td1 td2
lsort [glob td2/*]
} {td2/td2 td2/tf1 td2/tf2 td2/tf3 td2/tf4}
test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testchmod 000 td1
catch {
testfile cpdir td1 td2
list [file exists td2] [file writable td2]
} r
catch {
testchmod 777 td1
cleanup
}
set r
} {1 1}
test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} \
{pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile rmdir -force td1
file exists td1
} {0}
test winFCmd-7.21 {TraverseWinTree: fill errorPtr} {pcOnly} {
cleanup
list [catch {testfile cpdir td1 td2} msg] $msg
} {1 {td1 ENOENT}}
test winFCmd-8.1 {TraversalCopy: DOTREE_F} {pcOnly} {
cleanup
file mkdir td1
list [catch {testfile cpdir td1 td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} {pcOnly} {
cleanup
file mkdir td1/td2
testchmod 000 td1
catch {
testfile cpdir td1 td2
list [file writable td1] [file writable td1/td2]
} r
catch {
testchmod 777 td1
cleanup
}
set r
} {0 1}
test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} {pcOnly} {
cleanup
file mkdir td1
testfile cpdir td1 td2
} {}
test winFCmd-9.1 {TraversalDelete: DOTREE_F} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1
testfile rmdir -force td1
} {}
test winFCmd-9.2 {TraversalDelete: DOTREE_F} {pcOnly 95} {
cleanup
file mkdir td1
set fd [open td1/tf1 w]
set msg [list [catch {testfile rmdir -force td1} msg] $msg]
close $fd
set msg
} {1 {td1\tf1 EACCES}}
test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} {pcOnly} {
cleanup
file mkdir td1/td2
testchmod 000 td1
catch {
testfile rmdir -force td1
file exists td1
} r
catch {
testchmod 777 td1
cleanup
}
set r
} {0}
test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} {pcOnly} {
cleanup
file mkdir td1/td1/td3/td4/td5
testfile rmdir -force td1
} {}
test winFCmd-10.1 {AttributesPosixError - get} {pcOnly} {
cleanup
list [catch {file attributes td1 -archive} msg] $msg
} {1 {could not read "td1": no such file or directory}}
test winFCmd-10.2 {AttributesPosixError - set} {pcOnly} {
cleanup
list [catch {file attributes td1 -archive 0} msg] $msg
} {1 {could not read "td1": no such file or directory}}
test winFCmd-11.1 {GetWinFileAttributes} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -archive} msg] $msg [cleanup]
} {0 1 {}}
test winFCmd-11.2 {GetWinFileAttributes} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -readonly} msg] $msg [cleanup]
} {0 0 {}}
test winFCmd-11.3 {GetWinFileAttributes} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -hidden} msg] $msg [cleanup]
} {0 0 {}}
test winFCmd-11.4 {GetWinFileAttributes} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -system} msg] $msg [cleanup]
} {0 0 {}}
test winFCmd-11.5 {GetWinFileAttributes} {pcOnly} {
# attr of relative paths that resolve to root was failing
# don't care about answer, just that test runs.
set old [pwd]
cd c:/
file attr c:
file attr c:.
file attr .
cd $old
} {}
test winFCmd-11.6 {GetWinFileAttributes} {pcOnly} {
file attr c:/ -hidden
} {0}
test winFCmd-12.1 {ConvertFileNameFormat} {pcOnly} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-12.2 {ConvertFileNameFormat} {pcOnly} {
cleanup
file mkdir td1
close [open td1/td1 w]
list [catch {string tolower [file attributes td1/td1 -longname]} msg] $msg [cleanup]
} {0 td1/td1 {}}
test winFCmd-12.3 {ConvertFileNameFormat} {pcOnly} {
cleanup
file mkdir td1
file mkdir td1/td2
close [open td1/td3 w]
list [catch {string tolower [file attributes td1/td2/../td3 -longname]} msg] $msg [cleanup]
} {0 td1/td2/../td3 {}}
test winFCmd-12.4 {ConvertFileNameFormat} {pcOnly} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes ./td1 -longname]} msg] $msg [cleanup]
} {0 ./td1 {}}
test winFCmd-12.5 {ConvertFileNameFormat: absolute path} {pcOnly} {
list [file attributes / -longname] [file attributes \\ -longname]
} {/ /}
test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} {pcOnly} {
catch {file delete -force -- c:/td1}
close [open c:/td1 w]
list [catch {string tolower [file attributes c:/td1 -longname]} msg] $msg [file delete -force -- c:/td1]
} {0 c:/td1 {}}
test winFCmd-12.7 {ConvertFileNameFormat} {nonPortable pcOnly} {
string tolower [file attributes //bisque/tcl/ws -longname]
} {//bisque/tcl/ws}
test winFCmd-12.8 {ConvertFileNameFormat} {pcOnly longFileNames} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames pcOnly} {
cleanup
close [open td1td1td1 w]
list [catch {file attributes td1td1td1 -shortname}] [cleanup]
} {0 {}}
test winFCmd-12.11 {ConvertFileNameFormat} {longFileNames pcOnly} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-13.1 {GetWinFileLongName} {pcOnly} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-14.1 {GetWinFileShortName} {pcOnly} {
cleanup
close [open td1 w]
list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-15.1 {SetWinFileAttributes} {pcOnly} {
cleanup
list [catch {file attributes td1 -archive 0} msg] $msg
} {1 {could not read "td1": no such file or directory}}
test winFCmd-15.2 {SetWinFileAttributes - archive} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -archive 1} msg] $msg [file attributes td1 -archive] [cleanup]
} {0 {} 1 {}}
test winFCmd-15.3 {SetWinFileAttributes - archive} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -archive 0} msg] $msg [file attributes td1 -archive] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.4 {SetWinFileAttributes - hidden} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -hidden 1} msg] $msg [file attributes td1 -hidden] [file attributes td1 -hidden 0] [cleanup]
} {0 {} 1 {} {}}
test winFCmd-15.5 {SetWinFileAttributes - hidden} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -hidden 0} msg] $msg [file attributes td1 -hidden] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.6 {SetWinFileAttributes - readonly} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -readonly 1} msg] $msg [file attributes td1 -readonly] [cleanup]
} {0 {} 1 {}}
test winFCmd-15.7 {SetWinFileAttributes - readonly} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -readonly 0} msg] $msg [file attributes td1 -readonly] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.8 {SetWinFileAttributes - system} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -system 1} msg] $msg [file attributes td1 -system] [cleanup]
} {0 {} 1 {}}
test winFCmd-15.9 {SetWinFileAttributes - system} {pcOnly} {
cleanup
close [open td1 w]
list [catch {file attributes td1 -system 0} msg] $msg [file attributes td1 -system] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.10 {SetWinFileAttributes - failing} {pcOnly cdrom} {
cleanup
catch {file attributes $cdfile -archive 1}
} {1}
test winFCmd-16.1 {Windows file normalization} {pcOnly} {
list [file normalize c:/] [file normalize C:/]
} {C:/ C:/}
test winFCmd-16.2 {Windows file normalization} {pcOnly} {
close [open td1... w]
set res [file tail [file normalize td1]]
file delete td1...
set res
} {td1}
set pwd [pwd]
set d [string index $pwd 0]
test winFCmd-16.3 {Windows file normalization} {pcOnly} {
file norm ${d}:foo
} [file join $pwd foo]
test winFCmd-16.4 {Windows file normalization} {pcOnly} {
file norm [string tolower ${d}]:foo
} [file join $pwd foo]
test winFCmd-16.5 {Windows file normalization} {pcOnly} {
file norm ${d}:foo/bar
} [file join $pwd foo/bar]
test winFCmd-16.6 {Windows file normalization} {pcOnly} {
file norm ${d}:foo\\bar
} [file join $pwd foo/bar]
test winFCmd-16.7 {Windows file normalization} {pcOnly} {
file norm /bar
} "${d}:/bar"
test winFCmd-16.8 {Windows file normalization} {pcOnly} {
file norm ///bar
} "${d}:/bar"
test winFCmd-16.9 {Windows file normalization} {pcOnly} {
file norm /bar/foo
} "${d}:/bar/foo"
if {$d eq "C"} { set dd "D" } else { set dd "C" }
test winFCmd-16.10 {Windows file normalization} {pcOnly} {
file norm ${dd}:foo
} "${dd}:/foo"
test winFCmd-16.11 {Windows file normalization} {pcOnly cdrom} {
cd ${d}:
cd $cdrom
cd ${d}:
cd $cdrom
# Must not crash
set result "no crash"
} {no crash}
test winFCmd-16.12 {Windows file normalization} {pcOnly} {
set oldhome ""
catch {set oldhome $::env(HOME)}
set ::env(HOME) ${d}:
cd
set result [pwd]; # <- Must not crash
set ::env(HOME) $oldhome
set result
} ${d}:/
cd $pwd
unset d dd pwd
test winFCmd-18.1 {Windows reserved path names} -constraints win -body {
file pathtype com1
} -result "absolute"
test winFCmd-18.1.2 {Windows reserved path names} -constraints win -body {
file pathtype com4
} -result "absolute"
test winFCmd-18.1.3 {Windows reserved path names} -constraints win -body {
file pathtype com5
} -result "relative"
test winFCmd-18.1.4 {Windows reserved path names} -constraints win -body {
file pathtype lpt3
} -result "absolute"
test winFCmd-18.1.5 {Windows reserved path names} -constraints win -body {
file pathtype lpt4
} -result "relative"
test winFCmd-18.1.6 {Windows reserved path names} -constraints win -body {
file pathtype nul
} -result "absolute"
test winFCmd-18.1.7 {Windows reserved path names} -constraints win -body {
file pathtype null
} -result "relative"
test winFCmd-18.2 {Windows reserved path names} -constraints win -body {
file pathtype com1:
} -result "absolute"
test winFCmd-18.3 {Windows reserved path names} -constraints win -body {
file pathtype COM1
} -result "absolute"
test winFCmd-18.4 {Windows reserved path names} -constraints win -body {
file pathtype CoM1:
} -result "absolute"
test winFCmd-18.5 {Windows reserved path names} -constraints win -body {
file normalize com1:
} -result COM1
test winFCmd-18.6 {Windows reserved path names} -constraints win -body {
file normalize COM1:
} -result COM1
test winFCmd-18.7 {Windows reserved path names} -constraints win -body {
file normalize cOm1
} -result COM1
test winFCmd-18.8 {Windows reserved path names} -constraints win -body {
file normalize cOm1:
} -result COM1
# This block of code used to occur after the "return" call, so I'm
# commenting it out and assuming that this code is still under construction.
#foreach source {tef ted tnf tnd "" nul com1} {
# foreach chmodsrc {000 755} {
# foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" {
# foreach chmoddst {000 755} {
# puts hi
# cleanup
# file delete -force ted tef
# file mkdir ted
# createfile tef
# createfile tfe
# file mkdir tdempty
# file mkdir tdfull/td1/td2
#
# catch {testchmod $chmodsrc $source}
# catch {testchmod $chmoddst $dest}
#
# if [catch {file rename $source $dest} msg] {
# puts "file rename $source ($chmodsrc) $dest ($chmoddst)"
# puts $msg
# }
# }
# }
# }
#}
# cleanup
cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
tcl8.4.20/tests/while-old.test 0000644 0036047 0045461 00000006440 11737050674 014652 0 ustar dgp 771div # Commands covered: while
#
# This file contains the original set of tests for Tcl's while command.
# Since the while command is now compiled, a new set of tests covering
# the new implementation is in the file "while.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test while-old-1.1 {basic while loops} {
set count 0
while {$count < 10} {set count [expr $count+1]}
set count
} 10
test while-old-1.2 {basic while loops} {
set value xxx
while {2 > 3} {set value yyy}
set value
} xxx
test while-old-1.3 {basic while loops} {
set value 1
while {"true"} {
incr value;
if {$value > 5} {
break;
}
}
set value
} 6
test while-old-1.4 {basic while loops, multiline test expr} {
set value 1
while {($tcl_platform(platform) != "foobar1") && \
($tcl_platform(platform) != "foobar2")} {
incr value
break
}
set value
} {2}
test while-old-1.5 {basic while loops, test expr in quotes} {
set value 1
while "0 < 3" {set value 2; break}
set value
} {2}
test while-old-2.1 {continue in while loop} {
set list {1 2 3 4 5}
set index 0
set result {}
while {$index < 5} {
if {$index == 2} {set index [expr $index+1]; continue}
set result [concat $result [lindex $list $index]]
set index [expr $index+1]
}
set result
} {1 2 4 5}
test while-old-3.1 {break in while loop} {
set list {1 2 3 4 5}
set index 0
set result {}
while {$index < 5} {
if {$index == 3} break
set result [concat $result [lindex $list $index]]
set index [expr $index+1]
}
set result
} {1 2 3}
test while-old-4.1 {errors in while loops} {
set err [catch {while} msg]
list $err $msg
} {1 {wrong # args: should be "while test command"}}
test while-old-4.2 {errors in while loops} {
set err [catch {while 1} msg]
list $err $msg
} {1 {wrong # args: should be "while test command"}}
test while-old-4.3 {errors in while loops} {
set err [catch {while 1 2 3} msg]
list $err $msg
} {1 {wrong # args: should be "while test command"}}
test while-old-4.4 {errors in while loops} {
set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
list $err $msg
} {1 {can't use non-numeric string as operand of "+"}}
test while-old-4.5 {errors in while loops} {
catch {unset x}
set x 1
set err [catch {while {$x} {set x foo}} msg]
list $err $msg
} {1 {expected boolean value but got "foo"}}
test while-old-4.6 {errors in while loops} {
set err [catch {while {1} {error "loop aborted"}} msg]
list $err $msg $errorInfo
} {1 {loop aborted} {loop aborted
while executing
"error "loop aborted""}}
test while-old-5.1 {while return result} {
while {0} {set a 400}
} {}
test while-old-5.2 {while return result} {
set x 1
while {$x} {set x 0}
} {}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/async.test 0000644 0036047 0045461 00000007440 11737050674 014104 0 ustar dgp 771div # Commands covered: none
#
# This file contains a collection of tests for Tcl_AsyncCreate and related
# library procedures. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {[info commands testasync] == {}} {
puts "This application hasn't been compiled with the \"testasync\""
puts "command, so I can't test Tcl_AsyncCreate et al."
::tcltest::cleanupTests
return
}
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
return "new result"
}
proc async2 {result code} {
global aresult acode
set aresult $result
set acode $code
return -code error "xyzzy"
}
proc async3 {result code} {
global aresult
set aresult "test pattern"
return -code $code $result
}
set handler1 [testasync create async1]
set handler2 [testasync create async2]
set handler3 [testasync create async3]
test async-1.1 {basic async handlers} {
set aresult xxx
set acode yyy
list [catch {testasync mark $handler1 "original" 0} msg] $msg \
$acode $aresult
} {0 {new result} 0 original}
test async-1.2 {basic async handlers} {
set aresult xxx
set acode yyy
list [catch {testasync mark $handler1 "original" 1} msg] $msg \
$acode $aresult
} {0 {new result} 1 original}
test async-1.3 {basic async handlers} {
set aresult xxx
set acode yyy
list [catch {testasync mark $handler2 "old" 0} msg] $msg \
$acode $aresult
} {1 xyzzy 0 old}
test async-1.4 {basic async handlers} {
set aresult xxx
set acode yyy
list [catch {testasync mark $handler2 "old" 3} msg] $msg \
$acode $aresult
} {1 xyzzy 3 old}
test async-1.5 {basic async handlers} {
set aresult xxx
list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult
} {0 foobar {test pattern}}
test async-1.6 {basic async handlers} {
set aresult xxx
list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
} {1 foobar {test pattern}}
proc mult1 {result code} {
global x
lappend x mult1
return -code 7 mult1
}
set hm1 [testasync create mult1]
proc mult2 {result code} {
global x
lappend x mult2
return -code 9 mult2
}
set hm2 [testasync create mult2]
proc mult3 {result code} {
global x hm1 hm2
lappend x [catch {testasync mark $hm2 serial2 0}]
lappend x [catch {testasync mark $hm1 serial1 0}]
lappend x mult3
return -code 11 mult3
}
set hm3 [testasync create mult3]
test async-2.1 {multiple handlers} {
set x {}
list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x
} {9 mult2 {0 0 mult3 mult1 mult2}}
proc del1 {result code} {
global x hm1 hm2 hm3 hm4
lappend x [catch {testasync mark $hm3 serial2 0}]
lappend x [catch {testasync mark $hm1 serial1 0}]
lappend x [catch {testasync mark $hm4 serial1 0}]
testasync delete $hm1
testasync delete $hm2
testasync delete $hm3
lappend x del1
return -code 13 del1
}
proc del2 {result code} {
global x
lappend x del2
return -code 3 del2
}
testasync delete $handler1
testasync delete $hm2
testasync delete $hm3
set hm2 [testasync create del1]
set hm3 [testasync create mult2]
set hm4 [testasync create del2]
test async-3.1 {deleting handlers} {
set x {}
list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}
# cleanup
testasync delete
::tcltest::cleanupTests
return
tcl8.4.20/tests/winFile.test 0000644 0036047 0045461 00000004470 11737050674 014364 0 ustar dgp 771div # This file tests the tclWinFile.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test winFile-1.1 {TclpGetUserHome} {pcOnly} {
list [catch {glob ~nosuchuser} msg] $msg
} {1 {user "nosuchuser" doesn't exist}}
test winFile-1.2 {TclpGetUserHome} {pcOnly nt nonPortable} {
# The administrator account should always exist.
catch {glob ~administrator}
} {0}
test winFile-1.3 {TclpGetUserHome} {pcOnly 95} {
# Find some user in system.ini and then see if they have a home.
set f [open $::env(windir)/system.ini]
set x 0
while {![eof $f]} {
set line [gets $f]
if {$line == "\[Password Lists]"} {
gets $f
set name [lindex [split [gets $f] =] 0]
if {$name != ""} {
set x [catch {glob ~$name}]
break
}
}
}
close $f
set x
} {0}
test winFile-1.4 {TclpGetUserHome} {pcOnly nt nonPortable} {
catch {glob ~stanton@workgroup}
} {0}
test winFile-2.1 {TclpMatchFiles: case sensitivity} {pcOnly} {
makeFile {} GlobCapS
set result [list [glob -nocomplain GlobC*] [glob -nocomplain globc*]]
removeFile GlobCapS
set result
} {GlobCapS GlobCapS}
test winFile-2.2 {TclpMatchFiles: case sensitivity} {pcOnly} {
makeFile {} globlower
set result [list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]]
removeFile globlower
set result
} {globlower globlower}
test winFile-3.1 {file system} {pcOnly} {
set res "volume types ok"
foreach vol [file volumes] {
# Have to catch in case there is a removable drive (CDROM, floppy)
# with nothing in it.
catch {
if {![string equal [lindex [file system $vol] 1] [testvolumetype $vol]]} {
set res "For $vol, we found [file system $vol]\
and [testvolumetype $vol] are different"
break
}
}
}
set res
} {volume types ok}
# cleanup
::tcltest::cleanupTests
return
tcl8.4.20/tests/for.test 0000644 0036047 0045461 00000056405 11737050674 013562 0 ustar dgp 771div # Commands covered: for, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# 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.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Basic "for" operation.
test for-1.1 {TclCompileForCmd: missing initial command} {
list [catch {for} msg] $msg
} {1 {wrong # args: should be "for start test next command"}}
test for-1.2 {TclCompileForCmd: error in initial command} {
list [catch {for {set}} msg] $msg $errorInfo
} {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command"
while compiling
"for {set}"}}
catch {unset i}
test for-1.3 {TclCompileForCmd: missing test expression} {
catch {for {set i 0}} msg
set msg
} {wrong # args: should be "for start test next command"}
test for-1.4 {TclCompileForCmd: error in test expression} {
catch {for {set i 0} {$i<}} msg
set errorInfo
} {wrong # args: should be "for start test next command"
while compiling
"for {set i 0} {$i<}"}
test for-1.5 {TclCompileForCmd: test expression is enclosed in quotes} {
set i 0
for {} "$i > 5" {incr i} {}
} {}
test for-1.6 {TclCompileForCmd: missing "next" command} {
catch {for {set i 0} {$i < 5}} msg
set msg
} {wrong # args: should be "for start test next command"}
test for-1.7 {TclCompileForCmd: missing command body} {
catch {for {set i 0} {$i < 5} {incr i}} msg
set msg
} {wrong # args: should be "for start test next command"}
test for-1.8 {TclCompileForCmd: error compiling command body} {
catch {for {set i 0} {$i < 5} {incr i} {set}} msg
set errorInfo
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
("for" body line 1)
while compiling
"for {set i 0} {$i < 5} {incr i} {set}"}
catch {unset a}
test for-1.9 {TclCompileForCmd: simple command body} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
if $i==4 break
set a [concat $a $i]
}
set a
} {1 2 3}
test for-1.10 {TclCompileForCmd: command body in quotes} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} "append a x"
set a
} {xxxxx}
test for-1.11 {TclCompileForCmd: computed command body} {
catch {unset x1}
catch {unset bb}
catch {unset x2}
set x1 {append a x1; }
set bb {break}
set x2 {; append a x2}
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2
set a
} {x1}
test for-1.12 {TclCompileForCmd: error in "next" command} {
catch {for {set i 0} {$i < 5} {set} {puts $i}} msg
set errorInfo
} {wrong # args: should be "set varName ?newValue?"
while compiling
"set"
("for" loop-end command)
while compiling
"for {set i 0} {$i < 5} {set} {puts $i}"}
test for-1.13 {TclCompileForCmd: long command body} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
if $i==4 break
if $i>5 continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
}
set a
} {1 2 3}
test for-1.14 {TclCompileForCmd: for command result} {
set a [for {set i 0} {$i < 5} {incr i} {}]
set a
} {}
test for-1.15 {TclCompileForCmd: for command result} {
set a [for {set i 0} {$i < 5} {incr i} {if $i==3 break}]
set a
} {}
# Check "for" and "continue".
test for-2.1 {TclCompileContinueCmd: arguments after "continue"} {
catch {continue foo} msg
set msg
} {wrong # args: should be "continue"}
test for-2.2 {TclCompileContinueCmd: continue result} {
catch continue
} 4
test for-2.3 {continue tests} {
set a {}
for {set i 1} {$i <= 4} {set i [expr $i+1]} {
if {$i == 2} continue
set a [concat $a $i]
}
set a
} {1 3 4}
test for-2.4 {continue tests} {
set a {}
for {set i 1} {$i <= 4} {set i [expr $i+1]} {
if {$i != 2} continue
set a [concat $a $i]
}
set a
} {2}
test for-2.5 {continue tests, nested loops} {
set msg {}
for {set i 1} {$i <= 4} {incr i} {
for {set a 1} {$a <= 2} {incr a} {
if {$i>=2 && $a>=2} continue
set msg [concat $msg "$i.$a"]
}
}
set msg
} {1.1 1.2 2.1 3.1 4.1}
test for-2.6 {continue tests, long command body} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
if $i==2 continue
if $i==4 break
if $i>5 continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
}
set a
} {1 3}
# Check "for" and "break".
test for-3.1 {TclCompileBreakCmd: arguments after "break"} {
catch {break foo} msg
set msg
} {wrong # args: should be "break"}
test for-3.2 {TclCompileBreakCmd: break result} {
catch break
} 3
test for-3.3 {break tests} {
set a {}
for {set i 1} {$i <= 4} {incr i} {
if {$i == 3} break
set a [concat $a $i]
}
set a
} {1 2}
test for-3.4 {break tests, nested loops} {
set msg {}
for {set i 1} {$i <= 4} {incr i} {
for {set a 1} {$a <= 2} {incr a} {
if {$i>=2 && $a>=2} break
set msg [concat $msg "$i.$a"]
}
}
set msg
} {1.1 1.2 2.1 3.1 4.1}
test for-3.5 {break tests, long command body} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
if $i==2 continue
if $i==5 break
if $i>5 continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if $i==4 break
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
set a [concat $a $i]
}
set a
} {1 3}
# A simplified version of exmh's mail formatting routine to stress "for",
# "break", "while", and "if".
proc formatMail {} {
array set lines {
0 {Return-path: george@tcl} \
1 {Return-path: |