diff options
Diffstat (limited to 'library')
| -rw-r--r-- | library/http2.3/http.tcl | 881 | ||||
| -rw-r--r-- | library/http2.3/pkgIndex.tcl | 11 | ||||
| -rw-r--r-- | library/msgcat1.0/msgcat.tcl | 302 | ||||
| -rw-r--r-- | library/msgcat1.0/pkgIndex.tcl | 1 | ||||
| -rw-r--r-- | library/opt0.4/optparse.tcl | 1089 | ||||
| -rw-r--r-- | library/opt0.4/pkgIndex.tcl | 11 |
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]] |