summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/http2.3/http.tcl881
-rw-r--r--library/http2.3/pkgIndex.tcl11
-rw-r--r--library/msgcat1.0/msgcat.tcl302
-rw-r--r--library/msgcat1.0/pkgIndex.tcl1
-rw-r--r--library/opt0.4/optparse.tcl1089
-rw-r--r--library/opt0.4/pkgIndex.tcl11
6 files changed, 0 insertions, 2295 deletions
diff --git a/library/http2.3/http.tcl b/library/http2.3/http.tcl
deleted file mode 100644
index c8c9908..0000000
--- a/library/http2.3/http.tcl
+++ /dev/null
@@ -1,881 +0,0 @@
-# http.tcl --
-#
-# Client-side HTTP for GET, POST, and HEAD commands.
-# These routines can be used in untrusted code that uses
-# the Safesock security policy. These procedures use a
-# callback interface to avoid using vwait, which is not
-# defined in the safe base.
-#
-# See the file "license.terms" for information on usage and
-# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: http.tcl,v 1.33 2000/06/02 23:14:46 hobbs Exp $
-
-# Rough version history:
-# 1.0 Old http_get interface
-# 2.0 http:: namespace and http::geturl
-# 2.1 Added callbacks to handle arriving data, and timeouts
-# 2.2 Added ability to fetch into a channel
-# 2.3 Added SSL support, and ability to post from a channel
-# This version also cleans up error cases and eliminates the
-# "ioerror" status in favor of raising an error
-
-package provide http 2.3
-
-namespace eval http {
- variable http
- array set http {
- -accept */*
- -proxyhost {}
- -proxyport {}
- -useragent {Tcl http client package 2.3}
- -proxyfilter http::ProxyRequired
- }
-
- variable formMap
- variable alphanumeric a-zA-Z0-9
- variable c
- variable i 0
- for {} {$i <= 256} {incr i} {
- set c [format %c $i]
- if {![string match \[$alphanumeric\] $c]} {
- set formMap($c) %[format %.2x $i]
- }
- }
- # These are handled specially
- array set formMap {
- " " + \n %0d%0a
- }
-
- variable urlTypes
- array set urlTypes {
- http {80 ::socket}
- }
-
- namespace export geturl config reset wait formatQuery register unregister
- # Useful, but not exported: data size status code
-}
-
-# http::register --
-#
-# See documentaion for details.
-#
-# Arguments:
-# proto URL protocol prefix, e.g. https
-# port Default port for protocol
-# command Command to use to create socket
-# Results:
-# list of port and command that was registered.
-
-proc http::register {proto port command} {
- variable urlTypes
- set urlTypes($proto) [list $port $command]
-}
-
-# http::unregister --
-#
-# Unregisters URL protocol handler
-#
-# Arguments:
-# proto URL protocol prefix, e.g. https
-# Results:
-# list of port and command that was unregistered.
-
-proc http::unregister {proto} {
- variable urlTypes
- if {![info exists urlTypes($proto)]} {
- return -code error "unsupported url type \"$proto\""
- }
- set old $urlTypes($proto)
- unset urlTypes($proto)
- return $old
-}
-
-# http::config --
-#
-# See documentaion for details.
-#
-# Arguments:
-# args Options parsed by the procedure.
-# Results:
-# TODO
-
-proc http::config {args} {
- variable http
- set options [lsort [array names http -*]]
- set usage [join $options ", "]
- if {[llength $args] == 0} {
- set result {}
- foreach name $options {
- lappend result $name $http($name)
- }
- return $result
- }
- regsub -all -- - $options {} options
- set pat ^-([join $options |])$
- if {[llength $args] == 1} {
- set flag [lindex $args 0]
- if {[regexp -- $pat $flag]} {
- return $http($flag)
- } else {
- return -code error "Unknown option $flag, must be: $usage"
- }
- } else {
- foreach {flag value} $args {
- if {[regexp -- $pat $flag]} {
- set http($flag) $value
- } else {
- return -code error "Unknown option $flag, must be: $usage"
- }
- }
- }
-}
-
-# http::Finish --
-#
-# Clean up the socket and eval close time callbacks
-#
-# Arguments:
-# token Connection token.
-# errormsg (optional) If set, forces status to error.
-# skipCB (optional) If set, don't call the -command callback. This
-# is useful when geturl wants to throw an exception instead
-# of calling the callback. That way, the same error isn't
-# reported to two places.
-#
-# Side Effects:
-# Closes the socket
-
-proc http::Finish { token {errormsg ""} {skipCB 0}} {
- variable $token
- upvar 0 $token state
- global errorInfo errorCode
- if {[string length $errormsg] != 0} {
- set state(error) [list $errormsg $errorInfo $errorCode]
- set state(status) error
- }
- catch {close $state(sock)}
- catch {after cancel $state(after)}
- if {[info exists state(-command)] && !$skipCB} {
- if {[catch {eval $state(-command) {$token}} err]} {
- if {[string length $errormsg] == 0} {
- set state(error) [list $err $errorInfo $errorCode]
- set state(status) error
- }
- }
- if {[info exist state(-command)]} {
- # Command callback may already have unset our state
- unset state(-command)
- }
- }
-}
-
-# http::reset --
-#
-# See documentaion for details.
-#
-# Arguments:
-# token Connection token.
-# why Status info.
-#
-# Side Effects:
-# See Finish
-
-proc http::reset { token {why reset} } {
- variable $token
- upvar 0 $token state
- set state(status) $why
- catch {fileevent $state(sock) readable {}}
- catch {fileevent $state(sock) writable {}}
- Finish $token
- if {[info exists state(error)]} {
- set errorlist $state(error)
- unset state
- eval error $errorlist
- }
-}
-
-# http::geturl --
-#
-# Establishes a connection to a remote url via http.
-#
-# Arguments:
-# url The http URL to goget.
-# args Option value pairs. Valid options include:
-# -blocksize, -validate, -headers, -timeout
-# Results:
-# Returns a token for this connection.
-# This token is the name of an array that the caller should
-# unset to garbage collect the state.
-
-proc http::geturl { url args } {
- variable http
- variable urlTypes
-
- # Initialize the state variable, an array. We'll return the
- # name of this array as the token for the transaction.
-
- if {![info exists http(uid)]} {
- set http(uid) 0
- }
- set token [namespace current]::[incr http(uid)]
- variable $token
- upvar 0 $token state
- reset $token
-
- # Process command options.
-
- array set state {
- -blocksize 8192
- -queryblocksize 8192
- -validate 0
- -headers {}
- -timeout 0
- -type application/x-www-form-urlencoded
- -queryprogress {}
- state header
- meta {}
- currentsize 0
- totalsize 0
- querylength 0
- queryoffset 0
- type text/html
- body {}
- status ""
- http ""
- }
- set options {-blocksize -channel -command -handler -headers \
- -progress -query -queryblocksize -querychannel -queryprogress\
- -validate -timeout -type}
- set usage [join $options ", "]
- regsub -all -- - $options {} options
- set pat ^-([join $options |])$
- foreach {flag value} $args {
- if {[regexp $pat $flag]} {
- # Validate numbers
- if {[info exists state($flag)] && \
- [string is integer -strict $state($flag)] && \
- ![string is integer -strict $value]} {
- unset $token
- return -code error "Bad value for $flag ($value), must be integer"
- }
- set state($flag) $value
- } else {
- unset $token
- return -code error "Unknown option $flag, can be: $usage"
- }
- }
-
- # Make sure -query and -querychannel aren't both specified
-
- set isQueryChannel [info exists state(-querychannel)]
- set isQuery [info exists state(-query)]
- if {$isQuery && $isQueryChannel} {
- unset $token
- return -code error "Can't combine -query and -querychannel options!"
- }
-
- # Validate URL, determine the server host and port, and check proxy case
-
- if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
- x prefix proto host y port srvurl]} {
- unset $token
- return -code error "Unsupported URL: $url"
- }
- if {[string length $proto] == 0} {
- set proto http
- set url ${proto}://$url
- }
- if {![info exists urlTypes($proto)]} {
- unset $token
- return -code error "Unsupported URL type \"$proto\""
- }
- set defport [lindex $urlTypes($proto) 0]
- set defcmd [lindex $urlTypes($proto) 1]
-
- if {[string length $port] == 0} {
- set port $defport
- }
- if {[string length $srvurl] == 0} {
- set srvurl /
- }
- if {[string length $proto] == 0} {
- set url http://$url
- }
- set state(url) $url
- if {![catch {$http(-proxyfilter) $host} proxy]} {
- set phost [lindex $proxy 0]
- set pport [lindex $proxy 1]
- }
-
- # If a timeout is specified we set up the after event
- # and arrange for an asynchronous socket connection.
-
- if {$state(-timeout) > 0} {
- set state(after) [after $state(-timeout) \
- [list http::reset $token timeout]]
- set async -async
- } else {
- set async ""
- }
-
- # If we are using the proxy, we must pass in the full URL that
- # includes the server name.
-
- if {[info exists phost] && [string length $phost]} {
- set srvurl $url
- set conStat [catch {eval $defcmd $async {$phost $pport}} s]
- } else {
- set conStat [catch {eval $defcmd $async {$host $port}} s]
- }
- if {$conStat} {
-
- # something went wrong while trying to establish the connection
- # Clean up after events and such, but DON'T call the command callback
- # (if available) because we're going to throw an exception from here
- # instead.
- Finish $token "" 1
- cleanup $token
- return -code error $s
- }
- set state(sock) $s
-
- # Wait for the connection to complete
-
- if {$state(-timeout) > 0} {
- fileevent $s writable [list http::Connect $token]
- http::wait $token
-
- if {[string equal $state(status) "error"]} {
- # something went wrong while trying to establish the connection
- # Clean up after events and such, but DON'T call the command
- # callback (if available) because we're going to throw an
- # exception from here instead.
- set err [lindex $state(error) 0]
- cleanup $token
- return -code error $err
- } elseif {![string equal $state(status) "connect"]} {
- # Likely to be connection timeout
- return $token
- }
- set state(status) ""
- }
-
- # Send data in cr-lf format, but accept any line terminators
-
- fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
-
- # The following is disallowed in safe interpreters, but the socket
- # is already in non-blocking mode in that case.
-
- catch {fconfigure $s -blocking off}
- set how GET
- if {$isQuery} {
- set state(querylength) [string length $state(-query)]
- if {$state(querylength) > 0} {
- set how POST
- set contDone 0
- } else {
- # there's no query data
- unset state(-query)
- set isQuery 0
- }
- } elseif {$state(-validate)} {
- set how HEAD
- } elseif {$isQueryChannel} {
- set how POST
- # The query channel must be blocking for the async Write to
- # work properly.
- fconfigure $state(-querychannel) -blocking 1 -translation binary
- set contDone 0
- }
-
- if {[catch {
- puts $s "$how $srvurl HTTP/1.0"
- puts $s "Accept: $http(-accept)"
- puts $s "Host: $host"
- puts $s "User-Agent: $http(-useragent)"
- foreach {key value} $state(-headers) {
- regsub -all \[\n\r\] $value {} value
- set key [string trim $key]
- if {[string equal $key "Content-Length"]} {
- set contDone 1
- set state(querylength) $value
- }
- if {[string length $key]} {
- puts $s "$key: $value"
- }
- }
- if {$isQueryChannel && $state(querylength) == 0} {
- # Try to determine size of data in channel
- # If we cannot seek, the surrounding catch will trap us
-
- set start [tell $state(-querychannel)]
- seek $state(-querychannel) 0 end
- set state(querylength) \
- [expr {[tell $state(-querychannel)] - $start}]
- seek $state(-querychannel) $start
- }
-
- # Flush the request header and set up the fileevent that will
- # either push the POST data or read the response.
- #
- # fileevent note:
- #
- # It is possible to have both the read and write fileevents active
- # at this point. The only scenario it seems to affect is a server
- # that closes the connection without reading the POST data.
- # (e.g., early versions TclHttpd in various error cases).
- # Depending on the platform, the client may or may not be able to
- # get the response from the server because of the error it will
- # get trying to write the post data. Having both fileevents active
- # changes the timing and the behavior, but no two platforms
- # (among Solaris, Linux, and NT) behave the same, and none
- # behave all that well in any case. Servers should always read thier
- # POST data if they expect the client to read their response.
-
- if {$isQuery || $isQueryChannel} {
- puts $s "Content-Type: $state(-type)"
- if {!$contDone} {
- puts $s "Content-Length: $state(querylength)"
- }
- puts $s ""
- fconfigure $s -translation {auto binary}
- fileevent $s writable [list http::Write $token]
- } else {
- puts $s ""
- flush $s
- fileevent $s readable [list http::Event $token]
- }
-
- if {! [info exists state(-command)]} {
-
- # geturl does EVERYTHING asynchronously, so if the user
- # calls it synchronously, we just do a wait here.
-
- wait $token
- if {[string equal $state(status) "error"]} {
- # Something went wrong, so throw the exception, and the
- # enclosing catch will do cleanup.
- return -code error [lindex $state(error) 0]
- }
- }
- } err]} {
- # The socket probably was never connected,
- # or the connection dropped later.
-
- # Clean up after events and such, but DON'T call the command callback
- # (if available) because we're going to throw an exception from here
- # instead.
-
- # if state(status) is error, it means someone's already called Finish
- # to do the above-described clean up.
- if {[string equal $state(status) "error"]} {
- Finish $token $err 1
- }
- cleanup $token
- return -code error $err
- }
-
- return $token
-}
-
-# Data access functions:
-# Data - the URL data
-# Status - the transaction status: ok, reset, eof, timeout
-# Code - the HTTP transaction code, e.g., 200
-# Size - the size of the URL data
-
-proc http::data {token} {
- variable $token
- upvar 0 $token state
- return $state(body)
-}
-proc http::status {token} {
- variable $token
- upvar 0 $token state
- return $state(status)
-}
-proc http::code {token} {
- variable $token
- upvar 0 $token state
- return $state(http)
-}
-proc http::ncode {token} {
- variable $token
- upvar 0 $token state
- if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
- return $numeric_code
- } else {
- return $state(http)
- }
-}
-proc http::size {token} {
- variable $token
- upvar 0 $token state
- return $state(currentsize)
-}
-
-proc http::error {token} {
- variable $token
- upvar 0 $token state
- if {[info exists state(error)]} {
- return $state(error)
- }
- return ""
-}
-
-# http::cleanup
-#
-# Garbage collect the state associated with a transaction
-#
-# Arguments
-# token The token returned from http::geturl
-#
-# Side Effects
-# unsets the state array
-
-proc http::cleanup {token} {
- variable $token
- upvar 0 $token state
- if {[info exist state]} {
- unset state
- }
-}
-
-# http::Connect
-#
-# This callback is made when an asyncronous connection completes.
-#
-# Arguments
-# token The token returned from http::geturl
-#
-# Side Effects
-# Sets the status of the connection, which unblocks
-# the waiting geturl call
-
-proc http::Connect {token} {
- variable $token
- upvar 0 $token state
- global errorInfo errorCode
- if {[eof $state(sock)] ||
- [string length [fconfigure $state(sock) -error]]} {
- Finish $token "connect failed [fconfigure $state(sock) -error]" 1
- } else {
- set state(status) connect
- fileevent $state(sock) writable {}
- }
- return
-}
-
-# http::Write
-#
-# Write POST query data to the socket
-#
-# Arguments
-# token The token for the connection
-#
-# Side Effects
-# Write the socket and handle callbacks.
-
-proc http::Write {token} {
- variable $token
- upvar 0 $token state
- set s $state(sock)
-
- # Output a block. Tcl will buffer this if the socket blocks
-
- set done 0
- if {[catch {
-
- # Catch I/O errors on dead sockets
-
- if {[info exists state(-query)]} {
-
- # Chop up large query strings so queryprogress callback
- # can give smooth feedback
-
- puts -nonewline $s \
- [string range $state(-query) $state(queryoffset) \
- [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
- incr state(queryoffset) $state(-queryblocksize)
- if {$state(queryoffset) >= $state(querylength)} {
- set state(queryoffset) $state(querylength)
- set done 1
- }
- } else {
-
- # Copy blocks from the query channel
-
- set outStr [read $state(-querychannel) $state(-queryblocksize)]
- puts -nonewline $s $outStr
- incr state(queryoffset) [string length $outStr]
- if {[eof $state(-querychannel)]} {
- set done 1
- }
- }
- } err]} {
- # Do not call Finish here, but instead let the read half of
- # the socket process whatever server reply there is to get.
-
- set state(posterror) $err
- set done 1
- }
- if {$done} {
- catch {flush $s}
- fileevent $s writable {}
- fileevent $s readable [list http::Event $token]
- }
-
- # Callback to the client after we've completely handled everything
-
- if {[string length $state(-queryprogress)]} {
- eval $state(-queryprogress) [list $token $state(querylength)\
- $state(queryoffset)]
- }
-}
-
-# http::Event
-#
-# Handle input on the socket
-#
-# Arguments
-# token The token returned from http::geturl
-#
-# Side Effects
-# Read the socket and handle callbacks.
-
- proc http::Event {token} {
- variable $token
- upvar 0 $token state
- set s $state(sock)
-
- if {[eof $s]} {
- Eof $token
- return
- }
- if {[string equal $state(state) "header"]} {
- if {[catch {gets $s line} n]} {
- Finish $token $n
- } elseif {$n == 0} {
- set state(state) body
- if {![regexp -nocase ^text $state(type)]} {
- # Turn off conversions for non-text data
- fconfigure $s -translation binary
- if {[info exists state(-channel)]} {
- fconfigure $state(-channel) -translation binary
- }
- }
- if {[info exists state(-channel)] &&
- ![info exists state(-handler)]} {
- # Initiate a sequence of background fcopies
- fileevent $s readable {}
- CopyStart $s $token
- }
- } elseif {$n > 0} {
- if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
- set state(type) [string trim $type]
- }
- if {[regexp -nocase {^content-length:(.+)$} $line x length]} {
- set state(totalsize) [string trim $length]
- }
- if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
- lappend state(meta) $key [string trim $value]
- } elseif {[regexp ^HTTP $line]} {
- set state(http) $line
- }
- }
- } else {
- if {[catch {
- if {[info exists state(-handler)]} {
- set n [eval $state(-handler) {$s $token}]
- } else {
- set block [read $s $state(-blocksize)]
- set n [string length $block]
- if {$n >= 0} {
- append state(body) $block
- }
- }
- if {$n >= 0} {
- incr state(currentsize) $n
- }
- } err]} {
- Finish $token $err
- } else {
- if {[info exists state(-progress)]} {
- eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
- }
- }
- }
-}
-
-# http::CopyStart
-#
-# Error handling wrapper around fcopy
-#
-# Arguments
-# s The socket to copy from
-# token The token returned from http::geturl
-#
-# Side Effects
-# This closes the connection upon error
-
- proc http::CopyStart {s token} {
- variable $token
- upvar 0 $token state
- if {[catch {
- fcopy $s $state(-channel) -size $state(-blocksize) -command \
- [list http::CopyDone $token]
- } err]} {
- Finish $token $err
- }
-}
-
-# http::CopyDone
-#
-# fcopy completion callback
-#
-# Arguments
-# token The token returned from http::geturl
-# count The amount transfered
-#
-# Side Effects
-# Invokes callbacks
-
- proc http::CopyDone {token count {error {}}} {
- variable $token
- upvar 0 $token state
- set s $state(sock)
- incr state(currentsize) $count
- if {[info exists state(-progress)]} {
- eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
- }
- # At this point the token may have been reset
- if {[string length $error]} {
- Finish $token $error
- } elseif {[catch {eof $s} iseof] || $iseof} {
- Eof $token
- } else {
- CopyStart $s $token
- }
-}
-
-# http::Eof
-#
-# Handle eof on the socket
-#
-# Arguments
-# token The token returned from http::geturl
-#
-# Side Effects
-# Clean up the socket
-
- proc http::Eof {token} {
- variable $token
- upvar 0 $token state
- if {[string equal $state(state) "header"]} {
- # Premature eof
- set state(status) eof
- } else {
- set state(status) ok
- }
- set state(state) eof
- Finish $token
-}
-
-# http::wait --
-#
-# See documentaion for details.
-#
-# Arguments:
-# token Connection token.
-#
-# Results:
-# The status after the wait.
-
-proc http::wait {token} {
- variable $token
- upvar 0 $token state
-
- if {![info exists state(status)] || [string length $state(status)] == 0} {
- # We must wait on the original variable name, not the upvar alias
- vwait $token\(status)
- }
-
- return $state(status)
-}
-
-# http::formatQuery --
-#
-# See documentaion for details.
-# Call http::formatQuery with an even number of arguments, where
-# the first is a name, the second is a value, the third is another
-# name, and so on.
-#
-# Arguments:
-# args A list of name-value pairs.
-#
-# Results:
-# TODO
-
-proc http::formatQuery {args} {
- set result ""
- set sep ""
- foreach i $args {
- append result $sep [mapReply $i]
- if {[string compare $sep "="]} {
- set sep =
- } else {
- set sep &
- }
- }
- return $result
-}
-
-# http::mapReply --
-#
-# Do x-www-urlencoded character mapping
-#
-# Arguments:
-# string The string the needs to be encoded
-#
-# Results:
-# The encoded string
-
- proc http::mapReply {string} {
- variable formMap
-
- # The spec says: "non-alphanumeric characters are replaced by '%HH'"
- # 1 leave alphanumerics characters alone
- # 2 Convert every other character to an array lookup
- # 3 Escape constructs that are "special" to the tcl parser
- # 4 "subst" the result, doing all the array substitutions
-
- set alphanumeric a-zA-Z0-9
- regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
- regsub -all \n $string {\\n} string
- regsub -all \t $string {\\t} string
- regsub -all {[][{})\\]\)} $string {\\&} string
- return [subst $string]
-}
-
-# http::ProxyRequired --
-# Default proxy filter.
-#
-# Arguments:
-# host The destination host
-#
-# Results:
-# The current proxy settings
-
- proc http::ProxyRequired {host} {
- variable http
- if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
- if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} {
- set http(-proxyport) 8080
- }
- return [list $http(-proxyhost) $http(-proxyport)]
- } else {
- return {}
- }
-}
diff --git a/library/http2.3/pkgIndex.tcl b/library/http2.3/pkgIndex.tcl
deleted file mode 100644
index 32b17c7..0000000
--- a/library/http2.3/pkgIndex.tcl
+++ /dev/null
@@ -1,11 +0,0 @@
-# Tcl package index file, version 1.1
-# This file is generated by the "pkg_mkIndex" command
-# and sourced either when an application starts up or
-# by a "package unknown" script. It invokes the
-# "package ifneeded" command to set up package-related
-# information so that packages will be loaded automatically
-# in response to "package require" commands. When this
-# script is sourced, the variable $dir must contain the
-# full path name of this file's directory.
-
-package ifneeded http 2.3 [list tclPkgSetup $dir http 2.3 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}]
diff --git a/library/msgcat1.0/msgcat.tcl b/library/msgcat1.0/msgcat.tcl
deleted file mode 100644
index c4c4d81..0000000
--- a/library/msgcat1.0/msgcat.tcl
+++ /dev/null
@@ -1,302 +0,0 @@
-# msgcat.tcl --
-#
-# This file defines various procedures which implement a
-# message catalog facility for Tcl programs. It should be
-# loaded with the command "package require msgcat".
-#
-# Copyright (c) 1998-2000 by Ajuba Solutions.
-# Copyright (c) 1998 by Mark Harrison.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: msgcat.tcl,v 1.9 2000/08/11 00:45:32 ericm Exp $
-
-package provide msgcat 1.2
-
-namespace eval msgcat {
- namespace export mc mcset mcmset mclocale mcpreferences mcunknown mcmax
-
- # Records the current locale as passed to mclocale
- variable locale ""
-
- # Records the list of locales to search
- variable loclist {}
-
- # Records the mapping between source strings and translated strings. The
- # array key is of the form "<locale>,<namespace>,<src>" and the value is
- # the translated string.
- array set msgs {}
-}
-
-# msgcat::mc --
-#
-# Find the translation for the given string based on the current
-# locale setting. Check the local namespace first, then look in each
-# parent namespace until the source is found. If additional args are
-# specified, use the format command to work them into the traslated
-# string.
-#
-# Arguments:
-# src The string to translate.
-# args Args to pass to the format command
-#
-# Results:
-# Returns the translatd string. Propagates errors thrown by the
-# format command.
-
-proc msgcat::mc {src args} {
- # Check for the src in each namespace starting from the local and
- # ending in the global.
-
- set ns [uplevel {namespace current}]
-
- while {$ns != ""} {
- foreach loc $::msgcat::loclist {
- if {[info exists ::msgcat::msgs($loc,$ns,$src)]} {
- if {[llength $args] == 0} {
- return $::msgcat::msgs($loc,$ns,$src)
- } else {
- return [eval \
- [list format $::msgcat::msgs($loc,$ns,$src)] \
- $args]
- }
- }
- }
- set ns [namespace parent $ns]
- }
- # we have not found the translation
- return [uplevel 1 [list [namespace origin mcunknown] \
- $::msgcat::locale $src] $args]
-}
-
-# msgcat::mclocale --
-#
-# Query or set the current locale.
-#
-# Arguments:
-# newLocale (Optional) The new locale string. Locale strings
-# should be composed of one or more sublocale parts
-# separated by underscores (e.g. en_US).
-#
-# Results:
-# Returns the current locale.
-
-proc msgcat::mclocale {args} {
- set len [llength $args]
-
- if {$len > 1} {
- error {wrong # args: should be "mclocale ?newLocale?"}
- }
-
- set args [string tolower $args]
- if {$len == 1} {
- set ::msgcat::locale $args
- set ::msgcat::loclist {}
- set word ""
- foreach part [split $args _] {
- set word [string trimleft "${word}_${part}" _]
- set ::msgcat::loclist [linsert $::msgcat::loclist 0 $word]
- }
- }
- return $::msgcat::locale
-}
-
-# msgcat::mcpreferences --
-#
-# Fetch the list of locales used to look up strings, ordered from
-# most preferred to least preferred.
-#
-# Arguments:
-# None.
-#
-# Results:
-# Returns an ordered list of the locales preferred by the user.
-
-proc msgcat::mcpreferences {} {
- return $::msgcat::loclist
-}
-
-# msgcat::mcload --
-#
-# Attempt to load message catalogs for each locale in the
-# preference list from the specified directory.
-#
-# Arguments:
-# langdir The directory to search.
-#
-# Results:
-# Returns the number of message catalogs that were loaded.
-
-proc msgcat::mcload {langdir} {
- set x 0
- foreach p [::msgcat::mcpreferences] {
- set langfile [file join $langdir $p.msg]
- if {[file exists $langfile]} {
- incr x
- set fid [open $langfile "r"]
- fconfigure $fid -encoding utf-8
- uplevel [list eval [read $fid]]
- close $fid
- }
- }
- return $x
-}
-
-# msgcat::mcset --
-#
-# Set the translation for a given string in a specified locale.
-#
-# Arguments:
-# locale The locale to use.
-# src The source string.
-# dest (Optional) The translated string. If omitted,
-# the source string is used.
-#
-# Results:
-# Returns the new locale.
-
-proc msgcat::mcset {locale src {dest ""}} {
- if {[string equal $dest ""]} {
- set dest $src
- }
-
- set ns [uplevel {namespace current}]
-
- set ::msgcat::msgs([string tolower $locale],$ns,$src) $dest
- return $dest
-}
-
-# msgcat::mcmset --
-#
-# Set the translation for multiple strings in a specified locale.
-#
-# Arguments:
-# locale The locale to use.
-# pairs One or more src/dest pairs (must be even length)
-#
-# Results:
-# Returns the number of pairs processed
-
-proc msgcat::mcmset {locale pairs } {
-
- set length [llength $pairs]
- if {$length % 2} {
- error {bad translation list: should be "mcmset locale {src dest ...}"}
- }
-
- set locale [string tolower $locale]
- set ns [uplevel {namespace current}]
-
- foreach {src dest} $pairs {
- set ::msgcat::msgs($locale,$ns,$src) $dest
- }
-
- return $length
-}
-
-# msgcat::mcunknown --
-#
-# This routine is called by msgcat::mc if a translation cannot
-# be found for a string. This routine is intended to be replaced
-# by an application specific routine for error reporting
-# purposes. The default behavior is to return the source string.
-# If additional args are specified, the format command will be used
-# to work them into the traslated string.
-#
-# Arguments:
-# locale The current locale.
-# src The string to be translated.
-# args Args to pass to the format command
-#
-# Results:
-# Returns the translated value.
-
-proc msgcat::mcunknown {locale src args} {
- if {[llength $args]} {
- return [eval [list format $src] $args]
- } else {
- return $src
- }
-}
-
-# msgcat::mcmax --
-#
-# Calculates the maximun length of the translated strings of the given
-# list.
-#
-# Arguments:
-# args strings to translate.
-#
-# Results:
-# Returns the length of the longest translated string.
-
-proc msgcat::mcmax {args} {
- set max 0
- foreach string $args {
- set len [string length [msgcat::mc $string]]
- if {$len>$max} {
- set max $len
- }
- }
- return $max
-}
-
-# Initialize the default locale
-
-namespace eval msgcat {
- # set default locale, try to get from environment
- if {[info exists ::env(LANG)]} {
- mclocale $::env(LANG)
- } else {
- if { $tcl_platform(platform) == "windows" } {
- # try to set locale depending on registry settings
- #
- set key {HKEY_CURRENT_USER\Control Panel\International}
- if {[catch {package require registry}] || \
- [catch {registry get $key "locale"} locale]} {
- mclocale "C"
- } else {
-
- #
- # Clean up registry value for translating LCID value
- # by using only the last 2 digits, since first
- # 2 digits appear to be the country... For example
- # 0409 - English - United States
- # 0809 - English - United Kingdom
- #
- set locale [string trimleft $locale "0"]
- set locale [string range $locale end-1 end]
- set locale [string tolower $locale]
- switch -- $locale {
- 01 { mclocale "ar" }
- 02 { mclocale "bg" }
- 03 { mclocale "ca" }
- 04 { mclocale "zh" }
- 05 { mclocale "cs" }
- 06 { mclocale "da" }
- 07 { mclocale "de" }
- 08 { mclocale "el" }
- 09 { mclocale "en" }
- 0a { mclocale "es" }
- 0b { mclocale "fi" }
- 0c { mclocale "fr" }
- 0d { mclocale "he" }
- 0e { mclocale "hu" }
- 0f { mclocale "is" }
- 10 { mclocale "it" }
- 11 { mclocale "ja" }
- 12 { mclocale "ko" }
- 13 { mclocale "da" }
- 14 { mclocale "no" }
- 15 { mclocale "pl" }
- 16 { mclocale "pt" }
-
- default { mclocale "C" }
- }
- }
- } else {
- mclocale "C"
- }
- }
-}
diff --git a/library/msgcat1.0/pkgIndex.tcl b/library/msgcat1.0/pkgIndex.tcl
deleted file mode 100644
index af800dc..0000000
--- a/library/msgcat1.0/pkgIndex.tcl
+++ /dev/null
@@ -1 +0,0 @@
-package ifneeded msgcat 1.2 [list source [file join $dir msgcat.tcl]]
diff --git a/library/opt0.4/optparse.tcl b/library/opt0.4/optparse.tcl
deleted file mode 100644
index 0f6019a..0000000
--- a/library/opt0.4/optparse.tcl
+++ /dev/null
@@ -1,1089 +0,0 @@
-# optparse.tcl --
-#
-# (private) Option parsing package
-# Primarily used internally by the safe:: code.
-#
-# WARNING: This code will go away in a future release
-# of Tcl. It is NOT supported and you should not rely
-# on it. If your code does rely on this package you
-# may directly incorporate this code into your application.
-#
-# RCS: @(#) $Id: optparse.tcl,v 1.4 2000/07/18 21:30:41 ericm Exp $
-
-package provide opt 0.4.1
-
-namespace eval ::tcl {
-
- # Exported APIs
- namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
- OptProc OptProcArgGiven OptParse \
- Lempty Lget \
- Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \
- SetMax SetMin
-
-
-################# Example of use / 'user documentation' ###################
-
- proc OptCreateTestProc {} {
-
- # Defines ::tcl::OptParseTest as a test proc with parsed arguments
- # (can't be defined before the code below is loaded (before "OptProc"))
-
- # Every OptProc give usage information on "procname -help".
- # Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
- # then other arguments.
- #
- # example of 'valid' call:
- # ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
- # -nostatics false ch1
- OptProc OptParseTest {
- {subcommand -choice {save print} "sub command"}
- {arg1 3 "some number"}
- {-aflag}
- {-intflag 7}
- {-weirdflag "help string"}
- {-noStatics "Not ok to load static packages"}
- {-nestedloading1 true "OK to load into nested slaves"}
- {-nestedloading2 -boolean true "OK to load into nested slaves"}
- {-libsOK -choice {Tk SybTcl}
- "List of packages that can be loaded"}
- {-precision -int 12 "Number of digits of precision"}
- {-intval 7 "An integer"}
- {-scale -float 1.0 "Scale factor"}
- {-zoom 1.0 "Zoom factor"}
- {-arbitrary foobar "Arbitrary string"}
- {-random -string 12 "Random string"}
- {-listval -list {} "List value"}
- {-blahflag -blah abc "Funny type"}
- {arg2 -boolean "a boolean"}
- {arg3 -choice "ch1 ch2"}
- {?optarg? -list {} "optional argument"}
- } {
- foreach v [info locals] {
- puts stderr [format "%14s : %s" $v [set $v]]
- }
- }
- }
-
-################### No User serviceable part below ! ###############
-# You should really not look any further :
-# The following is private unexported undocumented unblessed... code
-# time to hit "q" ;-) !
-
-# Hmmm... ok, you really want to know ?
-
-# You've been warned... Here it is...
-
- # Array storing the parsed descriptions
- variable OptDesc;
- array set OptDesc {};
- # Next potentially free key id (numeric)
- variable OptDescN 0;
-
-# Inside algorithm/mechanism description:
-# (not for the faint hearted ;-)
-#
-# The argument description is parsed into a "program tree"
-# It is called a "program" because it is the program used by
-# the state machine interpreter that use that program to
-# actually parse the arguments at run time.
-#
-# The general structure of a "program" is
-# notation (pseudo bnf like)
-# name :== definition defines "name" as being "definition"
-# { x y z } means list of x, y, and z
-# x* means x repeated 0 or more time
-# x+ means "x x*"
-# x? means optionally x
-# x | y means x or y
-# "cccc" means the literal string
-#
-# program :== { programCounter programStep* }
-#
-# programStep :== program | singleStep
-#
-# programCounter :== {"P" integer+ }
-#
-# singleStep :== { instruction parameters* }
-#
-# instruction :== single element list
-#
-# (the difference between singleStep and program is that \
-# llength [lindex $program 0] >= 2
-# while
-# llength [lindex $singleStep 0] == 1
-# )
-#
-# And for this application:
-#
-# singleStep :== { instruction varname {hasBeenSet currentValue} type
-# typeArgs help }
-# instruction :== "flags" | "value"
-# type :== knowType | anyword
-# knowType :== "string" | "int" | "boolean" | "boolflag" | "float"
-# | "choice"
-#
-# for type "choice" typeArgs is a list of possible choices, the first one
-# is the default value. for all other types the typeArgs is the default value
-#
-# a "boolflag" is the type for a flag whose presence or absence, without
-# additional arguments means respectively true or false (default flag type).
-#
-# programCounter is the index in the list of the currently processed
-# programStep (thus starting at 1 (0 is {"P" prgCounterValue}).
-# If it is a list it points toward each currently selected programStep.
-# (like for "flags", as they are optional, form a set and programStep).
-
-# Performance/Implementation issues
-# ---------------------------------
-# We use tcl lists instead of arrays because with tcl8.0
-# they should start to be much faster.
-# But this code use a lot of helper procs (like Lvarset)
-# which are quite slow and would be helpfully optimized
-# for instance by being written in C. Also our struture
-# is complex and there is maybe some places where the
-# string rep might be calculated at great exense. to be checked.
-
-#
-# Parse a given description and saves it here under the given key
-# generate a unused keyid if not given
-#
-proc ::tcl::OptKeyRegister {desc {key ""}} {
- variable OptDesc;
- variable OptDescN;
- if {[string compare $key ""] == 0} {
- # in case a key given to us as a parameter was a number
- while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
- set key $OptDescN;
- incr OptDescN;
- }
- # program counter
- set program [list [list "P" 1]];
-
- # are we processing flags (which makes a single program step)
- set inflags 0;
-
- set state {};
-
- # flag used to detect that we just have a single (flags set) subprogram.
- set empty 1;
-
- foreach item $desc {
- if {$state == "args"} {
- # more items after 'args'...
- return -code error "'args' special argument must be the last one";
- }
- set res [OptNormalizeOne $item];
- set state [lindex $res 0];
- if {$inflags} {
- if {$state == "flags"} {
- # add to 'subprogram'
- lappend flagsprg $res;
- } else {
- # put in the flags
- # structure for flag programs items is a list of
- # {subprgcounter {prg flag 1} {prg flag 2} {...}}
- lappend program $flagsprg;
- # put the other regular stuff
- lappend program $res;
- set inflags 0;
- set empty 0;
- }
- } else {
- if {$state == "flags"} {
- set inflags 1;
- # sub program counter + first sub program
- set flagsprg [list [list "P" 1] $res];
- } else {
- lappend program $res;
- set empty 0;
- }
- }
- }
- if {$inflags} {
- if {$empty} {
- # We just have the subprogram, optimize and remove
- # unneeded level:
- set program $flagsprg;
- } else {
- lappend program $flagsprg;
- }
- }
-
- set OptDesc($key) $program;
-
- return $key;
-}
-
-#
-# Free the storage for that given key
-#
-proc ::tcl::OptKeyDelete {key} {
- variable OptDesc;
- unset OptDesc($key);
-}
-
- # Get the parsed description stored under the given key.
- proc OptKeyGetDesc {descKey} {
- variable OptDesc;
- if {![info exists OptDesc($descKey)]} {
- return -code error "Unknown option description key \"$descKey\"";
- }
- set OptDesc($descKey);
- }
-
-# Parse entry point for ppl who don't want to register with a key,
-# for instance because the description changes dynamically.
-# (otherwise one should really use OptKeyRegister once + OptKeyParse
-# as it is way faster or simply OptProc which does it all)
-# Assign a temporary key, call OptKeyParse and then free the storage
-proc ::tcl::OptParse {desc arglist} {
- set tempkey [OptKeyRegister $desc];
- set ret [catch {uplevel [list ::tcl::OptKeyParse $tempkey $arglist]} res];
- OptKeyDelete $tempkey;
- return -code $ret $res;
-}
-
-# Helper function, replacement for proc that both
-# register the description under a key which is the name of the proc
-# (and thus unique to that code)
-# and add a first line to the code to call the OptKeyParse proc
-# Stores the list of variables that have been actually given by the user
-# (the other will be sets to their default value)
-# into local variable named "Args".
-proc ::tcl::OptProc {name desc body} {
- set namespace [uplevel namespace current];
- if { ([string match "::*" $name])
- || ([string compare $namespace "::"]==0)} {
- # absolute name or global namespace, name is the key
- set key $name;
- } else {
- # we are relative to some non top level namespace:
- set key "${namespace}::${name}";
- }
- OptKeyRegister $desc $key;
- uplevel [list proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"];
- return $key;
-}
-# Check that a argument has been given
-# assumes that "OptProc" has been used as it will check in "Args" list
-proc ::tcl::OptProcArgGiven {argname} {
- upvar Args alist;
- expr {[lsearch $alist $argname] >=0}
-}
-
- #######
- # Programs/Descriptions manipulation
-
- # Return the instruction word/list of a given step/(sub)program
- proc OptInstr {lst} {
- lindex $lst 0;
- }
- # Is a (sub) program or a plain instruction ?
- proc OptIsPrg {lst} {
- expr {[llength [OptInstr $lst]]>=2}
- }
- # Is this instruction a program counter or a real instr
- proc OptIsCounter {item} {
- expr {[lindex $item 0]=="P"}
- }
- # Current program counter (2nd word of first word)
- proc OptGetPrgCounter {lst} {
- Lget $lst {0 1}
- }
- # Current program counter (2nd word of first word)
- proc OptSetPrgCounter {lstName newValue} {
- upvar $lstName lst;
- set lst [lreplace $lst 0 0 [concat "P" $newValue]];
- }
- # returns a list of currently selected items.
- proc OptSelection {lst} {
- set res {};
- foreach idx [lrange [lindex $lst 0] 1 end] {
- lappend res [Lget $lst $idx];
- }
- return $res;
- }
-
- # Advance to next description
- proc OptNextDesc {descName} {
- uplevel [list Lvarincr $descName {0 1}];
- }
-
- # Get the current description, eventually descend
- proc OptCurDesc {descriptions} {
- lindex $descriptions [OptGetPrgCounter $descriptions];
- }
- # get the current description, eventually descend
- # through sub programs as needed.
- proc OptCurDescFinal {descriptions} {
- set item [OptCurDesc $descriptions];
- # Descend untill we get the actual item and not a sub program
- while {[OptIsPrg $item]} {
- set item [OptCurDesc $item];
- }
- return $item;
- }
- # Current final instruction adress
- proc OptCurAddr {descriptions {start {}}} {
- set adress [OptGetPrgCounter $descriptions];
- lappend start $adress;
- set item [lindex $descriptions $adress];
- if {[OptIsPrg $item]} {
- return [OptCurAddr $item $start];
- } else {
- return $start;
- }
- }
- # Set the value field of the current instruction
- proc OptCurSetValue {descriptionsName value} {
- upvar $descriptionsName descriptions
- # get the current item full adress
- set adress [OptCurAddr $descriptions];
- # use the 3th field of the item (see OptValue / OptNewInst)
- lappend adress 2
- Lvarset descriptions $adress [list 1 $value];
- # ^hasBeenSet flag
- }
-
- # empty state means done/paste the end of the program
- proc OptState {item} {
- lindex $item 0
- }
-
- # current state
- proc OptCurState {descriptions} {
- OptState [OptCurDesc $descriptions];
- }
-
- #######
- # Arguments manipulation
-
- # Returns the argument that has to be processed now
- proc OptCurrentArg {lst} {
- lindex $lst 0;
- }
- # Advance to next argument
- proc OptNextArg {argsName} {
- uplevel [list Lvarpop1 $argsName];
- }
- #######
-
-
-
-
-
- # Loop over all descriptions, calling OptDoOne which will
- # eventually eat all the arguments.
- proc OptDoAll {descriptionsName argumentsName} {
- upvar $descriptionsName descriptions
- upvar $argumentsName arguments;
-# puts "entered DoAll";
- # Nb: the places where "state" can be set are tricky to figure
- # because DoOne sets the state to flagsValue and return -continue
- # when needed...
- set state [OptCurState $descriptions];
- # We'll exit the loop in "OptDoOne" or when state is empty.
- while 1 {
- set curitem [OptCurDesc $descriptions];
- # Do subprograms if needed, call ourselves on the sub branch
- while {[OptIsPrg $curitem]} {
- OptDoAll curitem arguments
-# puts "done DoAll sub";
- # Insert back the results in current tree;
- Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
- $curitem;
- OptNextDesc descriptions;
- set curitem [OptCurDesc $descriptions];
- set state [OptCurState $descriptions];
- }
-# puts "state = \"$state\" - arguments=($arguments)";
- if {[Lempty $state]} {
- # Nothing left to do, we are done in this branch:
- break;
- }
- # The following statement can make us terminate/continue
- # as it use return -code {break, continue, return and error}
- # codes
- OptDoOne descriptions state arguments;
- # If we are here, no special return code where issued,
- # we'll step to next instruction :
-# puts "new state = \"$state\"";
- OptNextDesc descriptions;
- set state [OptCurState $descriptions];
- }
- }
-
- # Process one step for the state machine,
- # eventually consuming the current argument.
- proc OptDoOne {descriptionsName stateName argumentsName} {
- upvar $argumentsName arguments;
- upvar $descriptionsName descriptions;
- upvar $stateName state;
-
- # the special state/instruction "args" eats all
- # the remaining args (if any)
- if {($state == "args")} {
- if {![Lempty $arguments]} {
- # If there is no additional arguments, leave the default value
- # in.
- OptCurSetValue descriptions $arguments;
- set arguments {};
- }
-# puts "breaking out ('args' state: consuming every reminding args)"
- return -code break;
- }
-
- if {[Lempty $arguments]} {
- if {$state == "flags"} {
- # no argument and no flags : we're done
-# puts "returning to previous (sub)prg (no more args)";
- return -code return;
- } elseif {$state == "optValue"} {
- set state next; # not used, for debug only
- # go to next state
- return ;
- } else {
- return -code error [OptMissingValue $descriptions];
- }
- } else {
- set arg [OptCurrentArg $arguments];
- }
-
- switch $state {
- flags {
- # A non-dash argument terminates the options, as does --
-
- # Still a flag ?
- if {![OptIsFlag $arg]} {
- # don't consume the argument, return to previous prg
- return -code return;
- }
- # consume the flag
- OptNextArg arguments;
- if {[string compare "--" $arg] == 0} {
- # return from 'flags' state
- return -code return;
- }
-
- set hits [OptHits descriptions $arg];
- if {$hits > 1} {
- return -code error [OptAmbigous $descriptions $arg]
- } elseif {$hits == 0} {
- return -code error [OptFlagUsage $descriptions $arg]
- }
- set item [OptCurDesc $descriptions];
- if {[OptNeedValue $item]} {
- # we need a value, next state is
- set state flagValue;
- } else {
- OptCurSetValue descriptions 1;
- }
- # continue
- return -code continue;
- }
- flagValue -
- value {
- set item [OptCurDesc $descriptions];
- # Test the values against their required type
- if {[catch {OptCheckType $arg\
- [OptType $item] [OptTypeArgs $item]} val]} {
- return -code error [OptBadValue $item $arg $val]
- }
- # consume the value
- OptNextArg arguments;
- # set the value
- OptCurSetValue descriptions $val;
- # go to next state
- if {$state == "flagValue"} {
- set state flags
- return -code continue;
- } else {
- set state next; # not used, for debug only
- return ; # will go on next step
- }
- }
- optValue {
- set item [OptCurDesc $descriptions];
- # Test the values against their required type
- if {![catch {OptCheckType $arg\
- [OptType $item] [OptTypeArgs $item]} val]} {
- # right type, so :
- # consume the value
- OptNextArg arguments;
- # set the value
- OptCurSetValue descriptions $val;
- }
- # go to next state
- set state next; # not used, for debug only
- return ; # will go on next step
- }
- }
- # If we reach this point: an unknown
- # state as been entered !
- return -code error "Bug! unknown state in DoOne \"$state\"\
- (prg counter [OptGetPrgCounter $descriptions]:\
- [OptCurDesc $descriptions])";
- }
-
-# Parse the options given the key to previously registered description
-# and arguments list
-proc ::tcl::OptKeyParse {descKey arglist} {
-
- set desc [OptKeyGetDesc $descKey];
-
- # make sure -help always give usage
- if {[string compare "-help" [string tolower $arglist]] == 0} {
- return -code error [OptError "Usage information:" $desc 1];
- }
-
- OptDoAll desc arglist;
-
- if {![Lempty $arglist]} {
- return -code error [OptTooManyArgs $desc $arglist];
- }
-
- # Analyse the result
- # Walk through the tree:
- OptTreeVars $desc "#[expr {[info level]-1}]" ;
-}
-
- # determine string length for nice tabulated output
- proc OptTreeVars {desc level {vnamesLst {}}} {
- foreach item $desc {
- if {[OptIsCounter $item]} continue;
- if {[OptIsPrg $item]} {
- set vnamesLst [OptTreeVars $item $level $vnamesLst];
- } else {
- set vname [OptVarName $item];
- upvar $level $vname var
- if {[OptHasBeenSet $item]} {
-# puts "adding $vname"
- # lets use the input name for the returned list
- # it is more usefull, for instance you can check that
- # no flags at all was given with expr
- # {![string match "*-*" $Args]}
- lappend vnamesLst [OptName $item];
- set var [OptValue $item];
- } else {
- set var [OptDefaultValue $item];
- }
- }
- }
- return $vnamesLst
- }
-
-
-# Check the type of a value
-# and emit an error if arg is not of the correct type
-# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
-proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
-# puts "checking '$arg' against '$type' ($typeArgs)";
-
- # only types "any", "choice", and numbers can have leading "-"
-
- switch -exact -- $type {
- int {
- if {![regexp {^(-+)?[0-9]+$} $arg]} {
- error "not an integer"
- }
- return $arg;
- }
- float {
- return [expr {double($arg)}]
- }
- script -
- list {
- # if llength fail : malformed list
- if {[llength $arg]==0} {
- if {[OptIsFlag $arg]} {
- error "no values with leading -"
- }
- }
- return $arg;
- }
- boolean {
- if {![regexp -nocase {^(true|false|0|1)$} $arg]} {
- error "non canonic boolean"
- }
- # convert true/false because expr/if is broken with "!,...
- if {$arg} {
- return 1
- } else {
- return 0
- }
- }
- choice {
- if {[lsearch -exact $typeArgs $arg] < 0} {
- error "invalid choice"
- }
- return $arg;
- }
- any {
- return $arg;
- }
- string -
- default {
- if {[OptIsFlag $arg]} {
- error "no values with leading -"
- }
- return $arg
- }
- }
- return neverReached;
-}
-
- # internal utilities
-
- # returns the number of flags matching the given arg
- # sets the (local) prg counter to the list of matches
- proc OptHits {descName arg} {
- upvar $descName desc;
- set hits 0
- set hitems {}
- set i 1;
-
- set larg [string tolower $arg];
- set len [string length $larg];
- set last [expr {$len-1}];
-
- foreach item [lrange $desc 1 end] {
- set flag [OptName $item]
- # lets try to match case insensitively
- # (string length ought to be cheap)
- set lflag [string tolower $flag];
- if {$len == [string length $lflag]} {
- if {[string compare $larg $lflag]==0} {
- # Exact match case
- OptSetPrgCounter desc $i;
- return 1;
- }
- } else {
- if {[string compare $larg [string range $lflag 0 $last]]==0} {
- lappend hitems $i;
- incr hits;
- }
- }
- incr i;
- }
- if {$hits} {
- OptSetPrgCounter desc $hitems;
- }
- return $hits
- }
-
- # Extract fields from the list structure:
-
- proc OptName {item} {
- lindex $item 1;
- }
- #
- proc OptHasBeenSet {item} {
- Lget $item {2 0};
- }
- #
- proc OptValue {item} {
- Lget $item {2 1};
- }
-
- proc OptIsFlag {name} {
- string match "-*" $name;
- }
- proc OptIsOpt {name} {
- string match {\?*} $name;
- }
- proc OptVarName {item} {
- set name [OptName $item];
- if {[OptIsFlag $name]} {
- return [string range $name 1 end];
- } elseif {[OptIsOpt $name]} {
- return [string trim $name "?"];
- } else {
- return $name;
- }
- }
- proc OptType {item} {
- lindex $item 3
- }
- proc OptTypeArgs {item} {
- lindex $item 4
- }
- proc OptHelp {item} {
- lindex $item 5
- }
- proc OptNeedValue {item} {
- string compare [OptType $item] boolflag
- }
- proc OptDefaultValue {item} {
- set val [OptTypeArgs $item]
- switch -exact -- [OptType $item] {
- choice {return [lindex $val 0]}
- boolean -
- boolflag {
- # convert back false/true to 0/1 because expr !$bool
- # is broken..
- if {$val} {
- return 1
- } else {
- return 0
- }
- }
- }
- return $val
- }
-
- # Description format error helper
- proc OptOptUsage {item {what ""}} {
- return -code error "invalid description format$what: $item\n\
- should be a list of {varname|-flagname ?-type? ?defaultvalue?\
- ?helpstring?}";
- }
-
-
- # Generate a canonical form single instruction
- proc OptNewInst {state varname type typeArgs help} {
- list $state $varname [list 0 {}] $type $typeArgs $help;
- # ^ ^
- # | |
- # hasBeenSet=+ +=currentValue
- }
-
- # Translate one item to canonical form
- proc OptNormalizeOne {item} {
- set lg [Lassign $item varname arg1 arg2 arg3];
-# puts "called optnormalizeone '$item' v=($varname), lg=$lg";
- set isflag [OptIsFlag $varname];
- set isopt [OptIsOpt $varname];
- if {$isflag} {
- set state "flags";
- } elseif {$isopt} {
- set state "optValue";
- } elseif {[string compare $varname "args"]} {
- set state "value";
- } else {
- set state "args";
- }
-
- # apply 'smart' 'fuzzy' logic to try to make
- # description writer's life easy, and our's difficult :
- # let's guess the missing arguments :-)
-
- switch $lg {
- 1 {
- if {$isflag} {
- return [OptNewInst $state $varname boolflag false ""];
- } else {
- return [OptNewInst $state $varname any "" ""];
- }
- }
- 2 {
- # varname default
- # varname help
- set type [OptGuessType $arg1]
- if {[string compare $type "string"] == 0} {
- if {$isflag} {
- set type boolflag
- set def false
- } else {
- set type any
- set def ""
- }
- set help $arg1
- } else {
- set help ""
- set def $arg1
- }
- return [OptNewInst $state $varname $type $def $help];
- }
- 3 {
- # varname type value
- # varname value comment
-
- if {[regexp {^-(.+)$} $arg1 x type]} {
- # flags/optValue as they are optional, need a "value",
- # on the contrary, for a variable (non optional),
- # default value is pointless, 'cept for choices :
- if {$isflag || $isopt || ($type == "choice")} {
- return [OptNewInst $state $varname $type $arg2 ""];
- } else {
- return [OptNewInst $state $varname $type "" $arg2];
- }
- } else {
- return [OptNewInst $state $varname\
- [OptGuessType $arg1] $arg1 $arg2]
- }
- }
- 4 {
- if {[regexp {^-(.+)$} $arg1 x type]} {
- return [OptNewInst $state $varname $type $arg2 $arg3];
- } else {
- return -code error [OptOptUsage $item];
- }
- }
- default {
- return -code error [OptOptUsage $item];
- }
- }
- }
-
- # Auto magic lasy type determination
- proc OptGuessType {arg} {
- if {[regexp -nocase {^(true|false)$} $arg]} {
- return boolean
- }
- if {[regexp {^(-+)?[0-9]+$} $arg]} {
- return int
- }
- if {![catch {expr {double($arg)}}]} {
- return float
- }
- return string
- }
-
- # Error messages front ends
-
- proc OptAmbigous {desc arg} {
- OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
- }
- proc OptFlagUsage {desc arg} {
- OptError "bad flag \"$arg\", must be one of" $desc;
- }
- proc OptTooManyArgs {desc arguments} {
- OptError "too many arguments (unexpected argument(s): $arguments),\
- usage:"\
- $desc 1
- }
- proc OptParamType {item} {
- if {[OptIsFlag $item]} {
- return "flag";
- } else {
- return "parameter";
- }
- }
- proc OptBadValue {item arg {err {}}} {
-# puts "bad val err = \"$err\"";
- OptError "bad value \"$arg\" for [OptParamType $item]"\
- [list $item]
- }
- proc OptMissingValue {descriptions} {
-# set item [OptCurDescFinal $descriptions];
- set item [OptCurDesc $descriptions];
- OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
- (use -help for full usage) :"\
- [list $item]
- }
-
-proc ::tcl::OptKeyError {prefix descKey {header 0}} {
- OptError $prefix [OptKeyGetDesc $descKey] $header;
-}
-
- # determine string length for nice tabulated output
- proc OptLengths {desc nlName tlName dlName} {
- upvar $nlName nl;
- upvar $tlName tl;
- upvar $dlName dl;
- foreach item $desc {
- if {[OptIsCounter $item]} continue;
- if {[OptIsPrg $item]} {
- OptLengths $item nl tl dl
- } else {
- SetMax nl [string length [OptName $item]]
- SetMax tl [string length [OptType $item]]
- set dv [OptTypeArgs $item];
- if {[OptState $item] != "header"} {
- set dv "($dv)";
- }
- set l [string length $dv];
- # limit the space allocated to potentially big "choices"
- if {([OptType $item] != "choice") || ($l<=12)} {
- SetMax dl $l
- } else {
- if {![info exists dl]} {
- set dl 0
- }
- }
- }
- }
- }
- # output the tree
- proc OptTree {desc nl tl dl} {
- set res "";
- foreach item $desc {
- if {[OptIsCounter $item]} continue;
- if {[OptIsPrg $item]} {
- append res [OptTree $item $nl $tl $dl];
- } else {
- set dv [OptTypeArgs $item];
- if {[OptState $item] != "header"} {
- set dv "($dv)";
- }
- append res [format "\n %-*s %-*s %-*s %s" \
- $nl [OptName $item] $tl [OptType $item] \
- $dl $dv [OptHelp $item]]
- }
- }
- return $res;
- }
-
-# Give nice usage string
-proc ::tcl::OptError {prefix desc {header 0}} {
- # determine length
- if {$header} {
- # add faked instruction
- set h [list [OptNewInst header Var/FlagName Type Value Help]];
- lappend h [OptNewInst header ------------ ---- ----- ----];
- lappend h [OptNewInst header {( -help} "" "" {gives this help )}]
- set desc [concat $h $desc]
- }
- OptLengths $desc nl tl dl
- # actually output
- return "$prefix[OptTree $desc $nl $tl $dl]"
-}
-
-
-################ General Utility functions #######################
-
-#
-# List utility functions
-# Naming convention:
-# "Lvarxxx" take the list VARiable name as argument
-# "Lxxxx" take the list value as argument
-# (which is not costly with Tcl8 objects system
-# as it's still a reference and not a copy of the values)
-#
-
-# Is that list empty ?
-proc ::tcl::Lempty {list} {
- expr {[llength $list]==0}
-}
-
-# Gets the value of one leaf of a lists tree
-proc ::tcl::Lget {list indexLst} {
- if {[llength $indexLst] <= 1} {
- return [lindex $list $indexLst];
- }
- Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end];
-}
-# Sets the value of one leaf of a lists tree
-# (we use the version that does not create the elements because
-# it would be even slower... needs to be written in C !)
-# (nb: there is a non trivial recursive problem with indexes 0,
-# which appear because there is no difference between a list
-# of 1 element and 1 element alone : [list "a"] == "a" while
-# it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
-# and [listp "a b"] maybe 0. listp does not exist either...)
-proc ::tcl::Lvarset {listName indexLst newValue} {
- upvar $listName list;
- if {[llength $indexLst] <= 1} {
- Lvarset1nc list $indexLst $newValue;
- } else {
- set idx [lindex $indexLst 0];
- set targetList [lindex $list $idx];
- # reduce refcount on targetList (not really usefull now,
- # could be with optimizing compiler)
-# Lvarset1 list $idx {};
- # recursively replace in targetList
- Lvarset targetList [lrange $indexLst 1 end] $newValue;
- # put updated sub list back in the tree
- Lvarset1nc list $idx $targetList;
- }
-}
-# Set one cell to a value, eventually create all the needed elements
-# (on level-1 of lists)
-variable emptyList {}
-proc ::tcl::Lvarset1 {listName index newValue} {
- upvar $listName list;
- if {$index < 0} {return -code error "invalid negative index"}
- set lg [llength $list];
- if {$index >= $lg} {
- variable emptyList;
- for {set i $lg} {$i<$index} {incr i} {
- lappend list $emptyList;
- }
- lappend list $newValue;
- } else {
- set list [lreplace $list $index $index $newValue];
- }
-}
-# same as Lvarset1 but no bound checking / creation
-proc ::tcl::Lvarset1nc {listName index newValue} {
- upvar $listName list;
- set list [lreplace $list $index $index $newValue];
-}
-# Increments the value of one leaf of a lists tree
-# (which must exists)
-proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
- upvar $listName list;
- if {[llength $indexLst] <= 1} {
- Lvarincr1 list $indexLst $howMuch;
- } else {
- set idx [lindex $indexLst 0];
- set targetList [lindex $list $idx];
- # reduce refcount on targetList
- Lvarset1nc list $idx {};
- # recursively replace in targetList
- Lvarincr targetList [lrange $indexLst 1 end] $howMuch;
- # put updated sub list back in the tree
- Lvarset1nc list $idx $targetList;
- }
-}
-# Increments the value of one cell of a list
-proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
- upvar $listName list;
- set newValue [expr {[lindex $list $index]+$howMuch}];
- set list [lreplace $list $index $index $newValue];
- return $newValue;
-}
-# Removes the first element of a list
-# and returns the new list value
-proc ::tcl::Lvarpop1 {listName} {
- upvar $listName list;
- set list [lrange $list 1 end];
-}
-# Same but returns the removed element
-# (Like the tclX version)
-proc ::tcl::Lvarpop {listName} {
- upvar $listName list;
- set el [lindex $list 0];
- set list [lrange $list 1 end];
- return $el;
-}
-# Assign list elements to variables and return the length of the list
-proc ::tcl::Lassign {list args} {
- # faster than direct blown foreach (which does not byte compile)
- set i 0;
- set lg [llength $list];
- foreach vname $args {
- if {$i>=$lg} break
- uplevel [list set $vname [lindex $list $i]];
- incr i;
- }
- return $lg;
-}
-
-# Misc utilities
-
-# Set the varname to value if value is greater than varname's current value
-# or if varname is undefined
-proc ::tcl::SetMax {varname value} {
- upvar 1 $varname var
- if {![info exists var] || $value > $var} {
- set var $value
- }
-}
-
-# Set the varname to value if value is smaller than varname's current value
-# or if varname is undefined
-proc ::tcl::SetMin {varname value} {
- upvar 1 $varname var
- if {![info exists var] || $value < $var} {
- set var $value
- }
-}
-
-
- # everything loaded fine, lets create the test proc:
- # OptCreateTestProc
- # Don't need the create temp proc anymore:
- # rename OptCreateTestProc {}
-}
diff --git a/library/opt0.4/pkgIndex.tcl b/library/opt0.4/pkgIndex.tcl
deleted file mode 100644
index 260e572..0000000
--- a/library/opt0.4/pkgIndex.tcl
+++ /dev/null
@@ -1,11 +0,0 @@
-# Tcl package index file, version 1.1
-# This file is generated by the "pkg_mkIndex -direct" command
-# and sourced either when an application starts up or
-# by a "package unknown" script. It invokes the
-# "package ifneeded" command to set up package-related
-# information so that packages will be loaded automatically
-# in response to "package require" commands. When this
-# script is sourced, the variable $dir must contain the
-# full path name of this file's directory.
-
-package ifneeded opt 0.4.1 [list source [file join $dir optparse.tcl]]