Tcl Source Code

# the information gets recomputed the next time it's needed.  Also delete any
# commands that are listed in the auto-load index.
#
# Arguments:
# None.

proc auto_reset {} {

    if {[array exists ::auto_index]} {
	foreach cmdName [array names ::auto_index] {
	    set fqcn [namespace which $cmdName]
	    if {$fqcn eq ""} {
		continue
	    }
	    rename $fqcn {}
	}
    }
    unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath
    if {[catch {llength $::auto_path}]} {
	set ::auto_path [list [info library]]
    } elseif {[info library] ni $::auto_path} {
	lappend ::auto_path [info library]
    }
}

# tcl_findLibrary --
#
#	This is a utility for extensions that searches for a library directory
#	using a canonical searching algorithm. A side effect is to source the
#	initialization script and set a global library variable.
#
# Arguments:
# 	basename	Prefix of the directory name, (e.g., "tk")
#	version		Version number of the package, (e.g., "8.0")
#	patch		Patchlevel of the package, (e.g., "8.0.3")
#	initScript	Initialization script to source (e.g., tk.tcl)
#	enVarName	environment variable to honor (e.g., TK_LIBRARY)
#	varName		Global variable to set when done (e.g., tk_library)

proc tcl_findLibrary {basename version patch initScript enVarName varName} {
    upvar #0 $varName the_library
    global env

    set dirs {}
    set errors {}

    # The C application may have hardwired a path, which we honor

    if {[info exists the_library] && $the_library ne ""} {

	catch {
	    lappend dirs [::${basename}::pkgconfig get scriptdir,runtime]
	}

	# 3. Relative to auto_path directories.  This checks relative to the
	# Tcl library as well as allowing loading of libraries added to the
	# auto_path that is not relative to the core library or binary paths.
	foreach d $::auto_path {
	    lappend dirs [file join $d $basename$version]
	    if {
		$::tcl_platform(platform) eq "unix"
		&& $::tcl_platform(os) eq "Darwin"
	    } then {
		# 4. On MacOSX, check the Resources/Scripts subdir too
		lappend dirs [file join $d $basename$version Resources Scripts]
	    }
	}

	# 3. Various locations relative to the executable
	# ../lib/foo1.0		(From bin directory in install hierarchy)

# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#


if {[info commands package] == ""} {
    error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
package require -exact Tcl 8.6.0

# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:

}

# Windows specific end of initialization

if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
    namespace eval tcl {
	proc EnvTraceProc {lo n1 n2 op} {

	    set x $::env($n2)
	    set ::env($lo) $x
	    set ::env([string toupper $lo]) $x
	}
	proc InitWinEnv {} {
	    global env tcl_platform
	    foreach p [array names env] {
		set u [string toupper $p]
		if {$u ne $p} {
		    switch -- $u {

if {[interp issafe]} {
    package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
} else {
    # Set up search for Tcl Modules (TIP #189).
    # and setup platform specific unknown package handlers
    if {$::tcl_platform(os) eq "Darwin"
	    && $::tcl_platform(platform) eq "unix"} {
	package unknown {::tcl::tm::UnknownHandler \
		{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
    } else {
	package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
    }

    # Set up the 'clock' ensemble

#
# Arguments:
# args -	A list whose elements are the words of the original
#		command, including the command name.

proc unknown args {
    variable ::tcl::UnknownPending
    global auto_noexec auto_noload env tcl_interactive


    if {[info exists ::errorInfo]} {
	set savedErrorInfo $::errorInfo
    }
    if {[info exists ::errorCode]} {
	set savedErrorCode $::errorCode
    }

    set name [lindex $args 0]
    if {![info exists auto_noload]} {
	#
	# Make sure we're not trying to load the same proc twice.
	#

	if {$msg} {
	    if {[info exists savedErrorCode]} {
		set ::errorCode $savedErrorCode
	    } else {
		unset -nocomplain ::errorCode
	    }
	    if {[info exists savedErrorInfo]} {
		set ::errorInfo $savedErrorInfo
	    } else {
		unset -nocomplain ::errorInfo
	    }
	    set code [catch {uplevel 1 $args} msg opts]
	    if {$code ==  1} {
		#
		# Compute stack trace contribution from the [uplevel].
		# Note the dependence on how Tcl_AddErrorInfo, etc.
		# construct the stack trace.
		#
		set errorInfo [dict get $opts -errorinfo]
		set errorCode [dict get $opts -errorcode]
		set cinfo $args
		if {[string bytelength $cinfo] > 150} {
		    set cinfo [string range $cinfo 0 150]
		    while {[string bytelength $cinfo] > 150} {
			set cinfo [string range $cinfo 0 end-1]
		    }
		    append cinfo ...
		}
		append cinfo "\"\n    (\"uplevel\" body line 1)"
		append cinfo "\n    invoked from within"
		append cinfo "\n\"uplevel 1 \$args\""
		#
		# Try each possible form of the stack trace
		# and trim the extra contribution from the matching case
		#
		set expect "$msg\n    while executing\n\"$cinfo"
		if {$errorInfo eq $expect} {
		    #
		    # The stack has only the eval from the expanded command
		    # Do not generate any stack trace here.
		    #
		    dict unset opts -errorinfo
		    dict incr opts -level
		    return -options $opts $msg
		}
		#
		# Stack trace is nested, trim off just the contribution
		# from the extra "eval" of $args due to the "catch" above.
		#
		set expect "\n    invoked from within\n\"$cinfo"
		set exlen [string length $expect]
		set eilen [string length $errorInfo]
		set i [expr {$eilen - $exlen - 1}]
		set einfo [string range $errorInfo 0 $i]
		#
		# For now verify that $errorInfo consists of what we are about
		# to return plus what we expected to trim off.
		#
		if {$errorInfo ne "$einfo$expect"} {
		    error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
			[list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo]
		}
		return -code error -errorcode $errorCode \
			-errorinfo $einfo $msg
	    } else {
		dict incr opts -level
		return -options $opts $msg
	    }
	}
    }

    if {([info level] == 1) && ([info script] eq "") \
	    && [info exists tcl_interactive] && $tcl_interactive} {
	if {![info exists auto_noexec]} {
	    set new [auto_execok $name]
	    if {$new ne ""} {
		set redir ""
		if {[namespace which -command console] eq ""} {
		    set redir ">&@stdout <@stdin"

	    # working directory, the directories '.', '..'
	    # can be returned in various combinations.  Anyway,
	    # if any other file is returned, we must signal an error.
	    set existing [glob -nocomplain -directory $dest * .*]
	    lappend existing {*}[glob -nocomplain -directory $dest \
		    -type hidden * .*]
	    foreach s $existing {
		if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
		    return -code error "error $action \"$src\" to\
		      \"$dest\": file already exists"
		}
	    }
	}
    } else {
	if {[string first $nsrc $ndest] != -1} {
	    set srclen [expr {[llength [file split $nsrc]] -1}]
	    set ndest [lindex [file split $ndest] $srclen]
	    if {$ndest eq [file tail $nsrc]} {
		return -code error "error $action \"$src\" to\
		  \"$dest\": trying to rename a volume or move a directory\
		  into itself"
	    }
	}
	file mkdir $dest
    }
    # Have to be careful to capture both visible and hidden files.
    # We will also be more generous to the file system and not
    # assume the hidden and non-hidden lists are non-overlapping.
    #
    # On Unix 'hidden' files begin with '.'.  On other platforms
    # or filesystems hidden files may have other interpretations.
    set filelist [concat [glob -nocomplain -directory $src *] \
      [glob -nocomplain -directory $src -types hidden *]]

    foreach s [lsort -unique $filelist] {
	if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
	    file copy -force $s [file join $dest [file tail $s]]
	}
    }
    return
}

# TIP 131
if 0 {
proc tcl::rmmadwiw {} {
    set magic {
        42 83 fe f6 ff f8 f1 e5 c6 f9 eb fd ff fb f1 e5 cc f5 ec f5 e3 fd fe
        ff f5 fa f3 e1 c7 f9 f2 fd ff f9 fe f9 ed f4 fa f6 e6 f9 f2 e6 fd f9
        ff f9 f6 e6 fa fd ff fc fb fc f9 f1 ed
    }
    foreach mystic [lassign $magic tragic] {
        set comic [expr (0x$mystic ^ 0x$tragic) - 255 + 0x$tragic]
        append logic [format %x $comic]
        set tragic $mystic
    }
    binary format H* $logic
}

proc tcl::mathfunc::rmmadwiw {} {
    set age [expr {9*6}]
    set mind ""
    while {$age} {
        lappend mind [expr {$age%13}]
        set age [expr {$age/13}]
    }
    set matter [lreverse $mind]
    return [join $matter ""]
}
}

# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

proc tcl_wordBreakAfter {str start} {
    variable ::tcl::WordBreakRE
    set result {-1 -1}
    regexp -indices -start $start $WordBreakRE(after) $str result
    return [lindex $result 1]
}

# tcl_wordBreakBefore --
#
# This procedure returns the index of the first word boundary before the
# starting point in the given string, or -1 if there are no more boundaries in
# the given string. The index returned refers to the second character of the
# pair that comprises a boundary.
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

proc tcl_wordBreakBefore {str start} {
    variable ::tcl::WordBreakRE
    set result {-1 -1}
    regexp -indices $WordBreakRE(before) [string range $str 0 $start] result
    return [lindex $result 1]
}

# tcl_endOfWord --
#
# This procedure returns the index of the first end-of-word location after a
# starting index in the given string. An end-of-word location is defined to be
# the first whitespace character following the first non-whitespace character
# after the starting point. Returns -1 if there are no more words after the
# starting point.
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

proc tcl_endOfWord {str start} {
    variable ::tcl::WordBreakRE
    set result {-1 -1}
    regexp -indices -start $start $WordBreakRE(end) $str result
    return [lindex $result 1]
}

# tcl_startOfNextWord --
#
# This procedure returns the index of the first start-of-word location after a
# starting index in the given string. A start-of-word location is defined to
# be a non-whitespace character following a whitespace character. Returns -1
# if there are no more start-of-word locations after the starting point.
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

proc tcl_startOfNextWord {str start} {
    variable ::tcl::WordBreakRE
    set result {-1 -1}
    regexp -indices -start $start $WordBreakRE(next) $str result
    return [lindex $result 1]
}

# tcl_startOfPreviousWord --
#
# This procedure returns the index of the first start-of-word location before
# a starting index in the given string.
#
# Arguments:
# str -		String to search.
# start -	Index into string specifying starting point.

proc tcl_startOfPreviousWord {str start} {
    variable ::tcl::WordBreakRE
    set word {-1 -1}
    regexp -indices $WordBreakRE(previous) [string range $str 0 $start-1] \
	    result word
    return [lindex $word 0]
}

# 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::*

}


::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testCPUID [llength [info commands testcpuid]]

test platform-1.1 {TclpSetVariables: tcl_platform} {

	    [lindex $cpudata 3] \
	    [lindex $cpudata 2] 
    } \
    -match regexp \
    -result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}

# cleanup
::tcltest::cleanupTests



return

# Local Variables:
# mode: tcl
# End:

# 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.2
namespace import -force ::tcltest::*
unset -nocomplain path
catch {set oldlang $env(LANG)}
set env(LANG) C

test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} {
    set x {}
    # Watch out for a race condition here.  If tcltest is too slow to start

test unixInit-1.2 {initialisation: standard channel type deduction} {unix 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 -myaddr 127.0.0.1 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 {

	[file join [temporaryDirectory] tmp library] ]

test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
	unix 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
    return $enc
} -cleanup {
    unset -nocomplain env(LANG)
} -match regexp -result [expr {
	($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}]
test unixInit-3.2 {TclpSetInitialEncodings} -setup {
    catch {set oldlc_all $env(LC_ALL)}
} -constraints {unix stdio} -body {
    set env(LANG) japanese
    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
    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.

    exec $tclsh $crashtest
} -cleanup {
    removeFile crash.tcl
    removeFile crashtest.tcl
} -returnCodes 0

# cleanup
catch {unset env(LANG)}
catch {set env(LANG) $oldlang}
unset -nocomplain path
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

# 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} {

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 

# Local Variables:
# mode: tcl
# End: