diff options
author | rjohnson <rjohnson> | 1998-03-26 14:45:59 (GMT) |
---|---|---|
committer | rjohnson <rjohnson> | 1998-03-26 14:45:59 (GMT) |
commit | 2b5738da524e944cda39e24c0a87b745a43bd8c3 (patch) | |
tree | 6e8c9473978f6dab66c601e911721a7bd9d70b1b /library | |
parent | c6a259aeeca4814a97cf6694814c63e74e4e18fa (diff) | |
download | tcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.zip tcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.tar.gz tcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.tar.bz2 |
Initial revision
Diffstat (limited to 'library')
-rw-r--r-- | library/history.tcl | 369 | ||||
-rw-r--r-- | library/http/http.tcl | 462 | ||||
-rw-r--r-- | library/http/pkgIndex.tcl | 11 | ||||
-rw-r--r-- | library/http1.0/http.tcl | 379 | ||||
-rw-r--r-- | library/http1.0/pkgIndex.tcl | 11 | ||||
-rw-r--r-- | library/http2.0/http.tcl | 462 | ||||
-rw-r--r-- | library/http2.0/pkgIndex.tcl | 11 | ||||
-rw-r--r-- | library/http2.1/http.tcl | 462 | ||||
-rw-r--r-- | library/http2.1/pkgIndex.tcl | 11 | ||||
-rw-r--r-- | library/http2.3/http.tcl | 462 | ||||
-rw-r--r-- | library/http2.3/pkgIndex.tcl | 11 | ||||
-rw-r--r-- | library/init.tcl | 785 | ||||
-rw-r--r-- | library/ldAout.tcl | 240 | ||||
-rw-r--r-- | library/opt0.1/optparse.tcl | 1094 | ||||
-rw-r--r-- | library/opt0.1/pkgIndex.tcl | 7 | ||||
-rw-r--r-- | library/parray.tcl | 29 | ||||
-rw-r--r-- | library/safe.tcl | 893 | ||||
-rw-r--r-- | library/tclIndex | 30 | ||||
-rw-r--r-- | library/word.tcl | 135 |
19 files changed, 5864 insertions, 0 deletions
diff --git a/library/history.tcl b/library/history.tcl new file mode 100644 index 0000000..a6beb43 --- /dev/null +++ b/library/history.tcl @@ -0,0 +1,369 @@ +# history.tcl -- +# +# Implementation of the history command. +# +# SCCS: @(#) history.tcl 1.7 97/08/07 16:45:50 +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# The tcl::history array holds the history list and +# some additional bookkeeping variables. +# +# nextid the index used for the next history list item. +# keep the max size of the history list +# oldest the index of the oldest item in the history. + +namespace eval tcl { + variable history + if ![info exists history] { + array set history { + nextid 0 + keep 20 + oldest -20 + } + } +} + +# history -- +# +# This is the main history command. See the man page for its interface. +# This does argument checking and calls helper procedures in the +# history namespace. + +proc history {args} { + set len [llength $args] + if {$len == 0} { + return [tcl::HistInfo] + } + set key [lindex $args 0] + set options "add, change, clear, event, info, keep, nextid, or redo" + switch -glob -- $key { + a* { # history add + + if {$len > 3} { + return -code error "wrong # args: should be \"history add event ?exec?\"" + } + if {![string match $key* add]} { + return -code error "bad option \"$key\": must be $options" + } + if {$len == 3} { + set arg [lindex $args 2] + if {! ([string match e* $arg] && [string match $arg* exec])} { + return -code error "bad argument \"$arg\": should be \"exec\"" + } + } + return [tcl::HistAdd [lindex $args 1] [lindex $args 2]] + } + ch* { # history change + + if {($len > 3) || ($len < 2)} { + return -code error "wrong # args: should be \"history change newValue ?event?\"" + } + if {![string match $key* change]} { + return -code error "bad option \"$key\": must be $options" + } + if {$len == 2} { + set event 0 + } else { + set event [lindex $args 2] + } + + return [tcl::HistChange [lindex $args 1] $event] + } + cl* { # history clear + + if {($len > 1)} { + return -code error "wrong # args: should be \"history clear\"" + } + if {![string match $key* clear]} { + return -code error "bad option \"$key\": must be $options" + } + return [tcl::HistClear] + } + e* { # history event + + if {$len > 2} { + return -code error "wrong # args: should be \"history event ?event?\"" + } + if {![string match $key* event]} { + return -code error "bad option \"$key\": must be $options" + } + if {$len == 1} { + set event -1 + } else { + set event [lindex $args 1] + } + return [tcl::HistEvent $event] + } + i* { # history info + + if {$len > 2} { + return -code error "wrong # args: should be \"history info ?count?\"" + } + if {![string match $key* info]} { + return -code error "bad option \"$key\": must be $options" + } + return [tcl::HistInfo [lindex $args 1]] + } + k* { # history keep + + if {$len > 2} { + return -code error "wrong # args: should be \"history keep ?count?\"" + } + if {$len == 1} { + return [tcl::HistKeep] + } else { + set limit [lindex $args 1] + if {[catch {expr $limit}] || ($limit < 0)} { + return -code error "illegal keep count \"$limit\"" + } + return [tcl::HistKeep $limit] + } + } + n* { # history nextid + + if {$len > 1} { + return -code error "wrong # args: should be \"history nextid\"" + } + if {![string match $key* nextid]} { + return -code error "bad option \"$key\": must be $options" + } + return [expr $tcl::history(nextid) + 1] + } + r* { # history redo + + if {$len > 2} { + return -code error "wrong # args: should be \"history redo ?event?\"" + } + if {![string match $key* redo]} { + return -code error "bad option \"$key\": must be $options" + } + return [tcl::HistRedo [lindex $args 1]] + } + default { + return -code error "bad option \"$key\": must be $options" + } + } +} + +# tcl::HistAdd -- +# +# Add an item to the history, and optionally eval it at the global scope +# +# Parameters: +# command the command to add +# exec (optional) a substring of "exec" causes the +# command to be evaled. +# Results: +# If executing, then the results of the command are returned +# +# Side Effects: +# Adds to the history list + + proc tcl::HistAdd {command {exec {}}} { + variable history + set i [incr history(nextid)] + set history($i) $command + set j [incr history(oldest)] + if {[info exists history($j)]} {unset history($j)} + if {[string match e* $exec]} { + return [uplevel #0 $command] + } else { + return {} + } +} + +# tcl::HistKeep -- +# +# Set or query the limit on the length of the history list +# +# Parameters: +# limit (optional) the length of the history list +# +# Results: +# If no limit is specified, the current limit is returned +# +# Side Effects: +# Updates history(keep) if a limit is specified + + proc tcl::HistKeep {{limit {}}} { + variable history + if {[string length $limit] == 0} { + return $history(keep) + } else { + set oldold $history(oldest) + set history(oldest) [expr $history(nextid) - $limit] + for {} {$oldold <= $history(oldest)} {incr oldold} { + if {[info exists history($oldold)]} {unset history($oldold)} + } + set history(keep) $limit + } +} + +# tcl::HistClear -- +# +# Erase the history list +# +# Parameters: +# none +# +# Results: +# none +# +# Side Effects: +# Resets the history array, except for the keep limit + + proc tcl::HistClear {} { + variable history + set keep $history(keep) + unset history + array set history [list \ + nextid 0 \ + keep $keep \ + oldest -$keep \ + ] +} + +# tcl::HistInfo -- +# +# Return a pretty-printed version of the history list +# +# Parameters: +# num (optional) the length of the history list to return +# +# Results: +# A formatted history list + + proc tcl::HistInfo {{num {}}} { + variable history + if {$num == {}} { + set num [expr $history(keep) + 1] + } + set result {} + set newline "" + for {set i [expr $history(nextid) - $num + 1]} \ + {$i <= $history(nextid)} {incr i} { + if ![info exists history($i)] { + continue + } + set cmd [string trimright $history($i) \ \n] + regsub -all \n $cmd "\n\t" cmd + append result $newline[format "%6d %s" $i $cmd] + set newline \n + } + return $result +} + +# tcl::HistRedo -- +# +# Fetch the previous or specified event, execute it, and then +# replace the current history item with that event. +# +# Parameters: +# event (optional) index of history item to redo. Defaults to -1, +# which means the previous event. +# +# Results: +# Those of the command being redone. +# +# Side Effects: +# Replaces the current history list item with the one being redone. + + proc tcl::HistRedo {{event -1}} { + variable history + if {[string length $event] == 0} { + set event -1 + } + set i [HistIndex $event] + if {$i == $history(nextid)} { + return -code error "cannot redo the current event" + } + set cmd $history($i) + HistChange $cmd 0 + uplevel #0 $cmd +} + +# tcl::HistIndex -- +# +# Map from an event specifier to an index in the history list. +# +# Parameters: +# event index of history item to redo. +# If this is a positive number, it is used directly. +# If it is a negative number, then it counts back to a previous +# event, where -1 is the most recent event. +# A string can be matched, either by being the prefix of +# a command or by matching a command with string match. +# +# Results: +# The index into history, or an error if the index didn't match. + + proc tcl::HistIndex {event} { + variable history + if {[catch {expr $event}]} { + for {set i $history(nextid)} {[info exists history($i)]} {incr i -1} { + if {[string match $event* $history($i)]} { + return $i; + } + if {[string match $event $history($i)]} { + return $i; + } + } + return -code error "no event matches \"$event\"" + } elseif {$event <= 0} { + set i [expr $history(nextid) + $event] + } else { + set i $event + } + if {$i <= $history(oldest)} { + return -code error "event \"$event\" is too far in the past" + } + if {$i > $history(nextid)} { + return -code error "event \"$event\" hasn't occured yet" + } + return $i +} + +# tcl::HistEvent -- +# +# Map from an event specifier to the value in the history list. +# +# Parameters: +# event index of history item to redo. See index for a +# description of possible event patterns. +# +# Results: +# The value from the history list. + + proc tcl::HistEvent {event} { + variable history + set i [HistIndex $event] + if {[info exists history($i)]} { + return [string trimright $history($i) \ \n] + } else { + return ""; + } +} + +# tcl::HistChange -- +# +# Replace a value in the history list. +# +# Parameters: +# cmd The new value to put into the history list. +# event (optional) index of history item to redo. See index for a +# description of possible event patterns. This defaults +# to 0, which specifies the current event. +# +# Side Effects: +# Changes the history list. + + proc tcl::HistChange {cmd {event 0}} { + variable history + set i [HistIndex $event] + set history($i) $cmd +} diff --git a/library/http/http.tcl b/library/http/http.tcl new file mode 100644 index 0000000..79c83c3 --- /dev/null +++ b/library/http/http.tcl @@ -0,0 +1,462 @@ +# 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. +# +# SCCS: @(#) http.tcl 1.8 97/10/28 16:23:30 + +package provide http 2.0 ;# This uses Tcl namespaces + +namespace eval http { + variable http + + array set http { + -accept */* + -proxyhost {} + -proxyport {} + -useragent {Tcl http client package 2.0} + -proxyfilter http::ProxyRequired + } + + variable formMap + set alphanumeric a-zA-Z0-9 + + for {set i 1} {$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 + } + + namespace export geturl config reset wait formatQuery + # Useful, but not exported: data size status code +} + +# 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" + } + } + } +} + + proc http::Finish { token {errormsg ""} } { + 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)]} { + if {[catch {eval $state(-command) {$token}} err]} { + if {[string length $errormsg] == 0} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + unset state(-command) + } +} + +# http::reset -- +# +# See documentaion for details. +# +# Arguments: +# token Connection token. +# why Status info. +# Results: +# TODO + +proc http::reset { token {why reset} } { + variable $token + upvar 0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + Finish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + 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. + + +proc http::geturl { url args } { + variable http + if ![info exists http(uid)] { + set http(uid) 0 + } + set token [namespace current]::[incr http(uid)] + variable $token + upvar 0 $token state + reset $token + array set state { + -blocksize 8192 + -validate 0 + -headers {} + -timeout 0 + state header + meta {} + currentsize 0 + totalsize 0 + type text/html + body {} + status "" + } + set options {-blocksize -channel -command -handler -headers \ + -progress -query -validate -timeout} + 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)] && \ + [regexp {^[0-9]+$} $state($flag)] && \ + ![regexp {^[0-9]+$} $value]} { + return -code error "Bad value for $flag ($value), must be integer" + } + set state($flag) $value + } else { + return -code error "Unknown option $flag, can be: $usage" + } + } + if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ + x proto host y port srvurl]} { + error "Unsupported URL: $url" + } + if {[string length $port] == 0} { + set port 80 + } + 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 {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) [list http::reset $token timeout]] + } + if {[info exists phost] && [string length $phost]} { + set srvurl $url + set s [socket $phost $pport] + } else { + set s [socket $host $port] + } + set state(sock) $s + + # 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 len 0 + set how GET + if {[info exists state(-query)]} { + set len [string length $state(-query)] + if {$len > 0} { + set how POST + } + } elseif {$state(-validate)} { + set how HEAD + } + 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 length $key]} { + puts $s "$key: $value" + } + } + if {$len > 0} { + puts $s "Content-Length: $len" + puts $s "Content-Type: application/x-www-form-urlencoded" + puts $s "" + fconfigure $s -translation {auto binary} + puts $s $state(-query) + } else { + puts $s "" + } + flush $s + fileevent $s readable [list http::Event $token] + if {! [info exists state(-command)]} { + wait $token + } + 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::size {token} { + variable $token + upvar 0 $token state + return $state(currentsize) +} + + proc http::Event {token} { + variable $token + upvar 0 $token state + set s $state(sock) + + if [::eof $s] then { + Eof $token + return + } + if {$state(state) == "header"} { + set n [gets $s line] + if {$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 $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)} + } + } + } +} + 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 + } +} + 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)} + } + if {([string length $error] != 0)} { + Finish $token $error + } elseif {[::eof $s]} { + Eof $token + } else { + CopyStart $s $token + } +} + proc http::Eof {token} { + variable $token + upvar 0 $token state + if {$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} { + vwait $token\(status) + } + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } + 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 {$sep != "="} { + set sep = + } else { + set sep & + } + } + return $result +} + +# do x-www-urlencoded character mapping +# 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 + + proc http::mapReply {string} { + variable formMap + 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] +} + +# Default proxy filter. + 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/http/pkgIndex.tcl b/library/http/pkgIndex.tcl new file mode 100644 index 0000000..01052f3 --- /dev/null +++ b/library/http/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.0 +# 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.0 [list tclPkgSetup $dir http 2.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait}}}] diff --git a/library/http1.0/http.tcl b/library/http1.0/http.tcl new file mode 100644 index 0000000..f6dd351 --- /dev/null +++ b/library/http1.0/http.tcl @@ -0,0 +1,379 @@ +# 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. +# +# SCCS: @(#) http.tcl 1.10 97/10/29 16:12:55 +# +# See the http.n man page for documentation + +package provide http 1.0 + +array set http { + -accept */* + -proxyhost {} + -proxyport {} + -useragent {Tcl http client package 1.0} + -proxyfilter httpProxyRequired +} +proc http_config {args} { + global 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" + } + } + } +} + + proc httpFinish { token {errormsg ""} } { + 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)]} { + if {[catch {eval $state(-command) {$token}} err]} { + if {[string length $errormsg] == 0} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + unset state(-command) + } +} +proc http_reset { token {why reset} } { + upvar #0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + httpFinish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } +} +proc http_get { url args } { + global http + if ![info exists http(uid)] { + set http(uid) 0 + } + set token http#[incr http(uid)] + upvar #0 $token state + http_reset $token + array set state { + -blocksize 8192 + -validate 0 + -headers {} + -timeout 0 + state header + meta {} + currentsize 0 + totalsize 0 + type text/html + body {} + status "" + } + set options {-blocksize -channel -command -handler -headers \ + -progress -query -validate -timeout} + 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)] && \ + [regexp {^[0-9]+$} $state($flag)] && \ + ![regexp {^[0-9]+$} $value]} { + return -code error "Bad value for $flag ($value), must be integer" + } + set state($flag) $value + } else { + return -code error "Unknown option $flag, can be: $usage" + } + } + if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ + x proto host y port srvurl]} { + error "Unsupported URL: $url" + } + if {[string length $port] == 0} { + set port 80 + } + 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 {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) [list http_reset $token timeout]] + } + if {[info exists phost] && [string length $phost]} { + set srvurl $url + set s [socket $phost $pport] + } else { + set s [socket $host $port] + } + set state(sock) $s + + # 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 len 0 + set how GET + if {[info exists state(-query)]} { + set len [string length $state(-query)] + if {$len > 0} { + set how POST + } + } elseif {$state(-validate)} { + set how HEAD + } + 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 length $key]} { + puts $s "$key: $value" + } + } + if {$len > 0} { + puts $s "Content-Length: $len" + puts $s "Content-Type: application/x-www-form-urlencoded" + puts $s "" + fconfigure $s -translation {auto binary} + puts $s $state(-query) + } else { + puts $s "" + } + flush $s + fileevent $s readable [list httpEvent $token] + if {! [info exists state(-command)]} { + http_wait $token + } + return $token +} +proc http_data {token} { + upvar #0 $token state + return $state(body) +} +proc http_status {token} { + upvar #0 $token state + return $state(status) +} +proc http_code {token} { + upvar #0 $token state + return $state(http) +} +proc http_size {token} { + upvar #0 $token state + return $state(currentsize) +} + + proc httpEvent {token} { + upvar #0 $token state + set s $state(sock) + + if [eof $s] then { + httpEof $token + return + } + if {$state(state) == "header"} { + set n [gets $s line] + if {$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 {} + httpCopyStart $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 $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] { + httpFinish $token $err + } else { + if [info exists state(-progress)] { + eval $state(-progress) {$token $state(totalsize) $state(currentsize)} + } + } + } +} + proc httpCopyStart {s token} { + upvar #0 $token state + if [catch { + fcopy $s $state(-channel) -size $state(-blocksize) -command \ + [list httpCopyDone $token] + } err] { + httpFinish $token $err + } +} + proc httpCopyDone {token count {error {}}} { + 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)} + } + if {([string length $error] != 0)} { + httpFinish $token $error + } elseif {[eof $s]} { + httpEof $token + } else { + httpCopyStart $s $token + } +} + proc httpEof {token} { + upvar #0 $token state + if {$state(state) == "header"} { + # Premature eof + set state(status) eof + } else { + set state(status) ok + } + set state(state) eof + httpFinish $token +} +proc http_wait {token} { + upvar #0 $token state + if {![info exists state(status)] || [string length $state(status)] == 0} { + vwait $token\(status) + } + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } + return $state(status) +} + +# 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. + +proc http_formatQuery {args} { + set result "" + set sep "" + foreach i $args { + append result $sep [httpMapReply $i] + if {$sep != "="} { + set sep = + } else { + set sep & + } + } + return $result +} + +# do x-www-urlencoded character mapping +# 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 + + proc httpMapReply {string} { + global httpFormMap + set alphanumeric a-zA-Z0-9 + if ![info exists httpFormMap] { + + for {set i 1} {$i <= 256} {incr i} { + set c [format %c $i] + if {![string match \[$alphanumeric\] $c]} { + set httpFormMap($c) %[format %.2x $i] + } + } + # These are handled specially + array set httpFormMap { + " " + \n %0d%0a + } + } + regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string + regsub -all \n $string {\\n} string + regsub -all \t $string {\\t} string + regsub -all {[][{})\\]\)} $string {\\&} string + return [subst $string] +} + +# Default proxy filter. + proc httpProxyRequired {host} { + global 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/http1.0/pkgIndex.tcl b/library/http1.0/pkgIndex.tcl new file mode 100644 index 0000000..ab6170f --- /dev/null +++ b/library/http1.0/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.0 +# 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 1.0 [list tclPkgSetup $dir http 1.0 {{http.tcl source {httpCopyDone httpCopyStart httpEof httpEvent httpFinish httpMapReply httpProxyRequired http_code http_config http_data http_formatQuery http_get http_reset http_size http_status http_wait}}}] diff --git a/library/http2.0/http.tcl b/library/http2.0/http.tcl new file mode 100644 index 0000000..79c83c3 --- /dev/null +++ b/library/http2.0/http.tcl @@ -0,0 +1,462 @@ +# 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. +# +# SCCS: @(#) http.tcl 1.8 97/10/28 16:23:30 + +package provide http 2.0 ;# This uses Tcl namespaces + +namespace eval http { + variable http + + array set http { + -accept */* + -proxyhost {} + -proxyport {} + -useragent {Tcl http client package 2.0} + -proxyfilter http::ProxyRequired + } + + variable formMap + set alphanumeric a-zA-Z0-9 + + for {set i 1} {$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 + } + + namespace export geturl config reset wait formatQuery + # Useful, but not exported: data size status code +} + +# 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" + } + } + } +} + + proc http::Finish { token {errormsg ""} } { + 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)]} { + if {[catch {eval $state(-command) {$token}} err]} { + if {[string length $errormsg] == 0} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + unset state(-command) + } +} + +# http::reset -- +# +# See documentaion for details. +# +# Arguments: +# token Connection token. +# why Status info. +# Results: +# TODO + +proc http::reset { token {why reset} } { + variable $token + upvar 0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + Finish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + 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. + + +proc http::geturl { url args } { + variable http + if ![info exists http(uid)] { + set http(uid) 0 + } + set token [namespace current]::[incr http(uid)] + variable $token + upvar 0 $token state + reset $token + array set state { + -blocksize 8192 + -validate 0 + -headers {} + -timeout 0 + state header + meta {} + currentsize 0 + totalsize 0 + type text/html + body {} + status "" + } + set options {-blocksize -channel -command -handler -headers \ + -progress -query -validate -timeout} + 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)] && \ + [regexp {^[0-9]+$} $state($flag)] && \ + ![regexp {^[0-9]+$} $value]} { + return -code error "Bad value for $flag ($value), must be integer" + } + set state($flag) $value + } else { + return -code error "Unknown option $flag, can be: $usage" + } + } + if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ + x proto host y port srvurl]} { + error "Unsupported URL: $url" + } + if {[string length $port] == 0} { + set port 80 + } + 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 {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) [list http::reset $token timeout]] + } + if {[info exists phost] && [string length $phost]} { + set srvurl $url + set s [socket $phost $pport] + } else { + set s [socket $host $port] + } + set state(sock) $s + + # 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 len 0 + set how GET + if {[info exists state(-query)]} { + set len [string length $state(-query)] + if {$len > 0} { + set how POST + } + } elseif {$state(-validate)} { + set how HEAD + } + 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 length $key]} { + puts $s "$key: $value" + } + } + if {$len > 0} { + puts $s "Content-Length: $len" + puts $s "Content-Type: application/x-www-form-urlencoded" + puts $s "" + fconfigure $s -translation {auto binary} + puts $s $state(-query) + } else { + puts $s "" + } + flush $s + fileevent $s readable [list http::Event $token] + if {! [info exists state(-command)]} { + wait $token + } + 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::size {token} { + variable $token + upvar 0 $token state + return $state(currentsize) +} + + proc http::Event {token} { + variable $token + upvar 0 $token state + set s $state(sock) + + if [::eof $s] then { + Eof $token + return + } + if {$state(state) == "header"} { + set n [gets $s line] + if {$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 $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)} + } + } + } +} + 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 + } +} + 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)} + } + if {([string length $error] != 0)} { + Finish $token $error + } elseif {[::eof $s]} { + Eof $token + } else { + CopyStart $s $token + } +} + proc http::Eof {token} { + variable $token + upvar 0 $token state + if {$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} { + vwait $token\(status) + } + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } + 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 {$sep != "="} { + set sep = + } else { + set sep & + } + } + return $result +} + +# do x-www-urlencoded character mapping +# 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 + + proc http::mapReply {string} { + variable formMap + 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] +} + +# Default proxy filter. + 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.0/pkgIndex.tcl b/library/http2.0/pkgIndex.tcl new file mode 100644 index 0000000..01052f3 --- /dev/null +++ b/library/http2.0/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.0 +# 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.0 [list tclPkgSetup $dir http 2.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait}}}] diff --git a/library/http2.1/http.tcl b/library/http2.1/http.tcl new file mode 100644 index 0000000..79c83c3 --- /dev/null +++ b/library/http2.1/http.tcl @@ -0,0 +1,462 @@ +# 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. +# +# SCCS: @(#) http.tcl 1.8 97/10/28 16:23:30 + +package provide http 2.0 ;# This uses Tcl namespaces + +namespace eval http { + variable http + + array set http { + -accept */* + -proxyhost {} + -proxyport {} + -useragent {Tcl http client package 2.0} + -proxyfilter http::ProxyRequired + } + + variable formMap + set alphanumeric a-zA-Z0-9 + + for {set i 1} {$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 + } + + namespace export geturl config reset wait formatQuery + # Useful, but not exported: data size status code +} + +# 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" + } + } + } +} + + proc http::Finish { token {errormsg ""} } { + 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)]} { + if {[catch {eval $state(-command) {$token}} err]} { + if {[string length $errormsg] == 0} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + unset state(-command) + } +} + +# http::reset -- +# +# See documentaion for details. +# +# Arguments: +# token Connection token. +# why Status info. +# Results: +# TODO + +proc http::reset { token {why reset} } { + variable $token + upvar 0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + Finish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + 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. + + +proc http::geturl { url args } { + variable http + if ![info exists http(uid)] { + set http(uid) 0 + } + set token [namespace current]::[incr http(uid)] + variable $token + upvar 0 $token state + reset $token + array set state { + -blocksize 8192 + -validate 0 + -headers {} + -timeout 0 + state header + meta {} + currentsize 0 + totalsize 0 + type text/html + body {} + status "" + } + set options {-blocksize -channel -command -handler -headers \ + -progress -query -validate -timeout} + 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)] && \ + [regexp {^[0-9]+$} $state($flag)] && \ + ![regexp {^[0-9]+$} $value]} { + return -code error "Bad value for $flag ($value), must be integer" + } + set state($flag) $value + } else { + return -code error "Unknown option $flag, can be: $usage" + } + } + if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ + x proto host y port srvurl]} { + error "Unsupported URL: $url" + } + if {[string length $port] == 0} { + set port 80 + } + 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 {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) [list http::reset $token timeout]] + } + if {[info exists phost] && [string length $phost]} { + set srvurl $url + set s [socket $phost $pport] + } else { + set s [socket $host $port] + } + set state(sock) $s + + # 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 len 0 + set how GET + if {[info exists state(-query)]} { + set len [string length $state(-query)] + if {$len > 0} { + set how POST + } + } elseif {$state(-validate)} { + set how HEAD + } + 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 length $key]} { + puts $s "$key: $value" + } + } + if {$len > 0} { + puts $s "Content-Length: $len" + puts $s "Content-Type: application/x-www-form-urlencoded" + puts $s "" + fconfigure $s -translation {auto binary} + puts $s $state(-query) + } else { + puts $s "" + } + flush $s + fileevent $s readable [list http::Event $token] + if {! [info exists state(-command)]} { + wait $token + } + 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::size {token} { + variable $token + upvar 0 $token state + return $state(currentsize) +} + + proc http::Event {token} { + variable $token + upvar 0 $token state + set s $state(sock) + + if [::eof $s] then { + Eof $token + return + } + if {$state(state) == "header"} { + set n [gets $s line] + if {$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 $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)} + } + } + } +} + 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 + } +} + 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)} + } + if {([string length $error] != 0)} { + Finish $token $error + } elseif {[::eof $s]} { + Eof $token + } else { + CopyStart $s $token + } +} + proc http::Eof {token} { + variable $token + upvar 0 $token state + if {$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} { + vwait $token\(status) + } + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } + 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 {$sep != "="} { + set sep = + } else { + set sep & + } + } + return $result +} + +# do x-www-urlencoded character mapping +# 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 + + proc http::mapReply {string} { + variable formMap + 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] +} + +# Default proxy filter. + 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.1/pkgIndex.tcl b/library/http2.1/pkgIndex.tcl new file mode 100644 index 0000000..01052f3 --- /dev/null +++ b/library/http2.1/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.0 +# 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.0 [list tclPkgSetup $dir http 2.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait}}}] diff --git a/library/http2.3/http.tcl b/library/http2.3/http.tcl new file mode 100644 index 0000000..79c83c3 --- /dev/null +++ b/library/http2.3/http.tcl @@ -0,0 +1,462 @@ +# 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. +# +# SCCS: @(#) http.tcl 1.8 97/10/28 16:23:30 + +package provide http 2.0 ;# This uses Tcl namespaces + +namespace eval http { + variable http + + array set http { + -accept */* + -proxyhost {} + -proxyport {} + -useragent {Tcl http client package 2.0} + -proxyfilter http::ProxyRequired + } + + variable formMap + set alphanumeric a-zA-Z0-9 + + for {set i 1} {$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 + } + + namespace export geturl config reset wait formatQuery + # Useful, but not exported: data size status code +} + +# 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" + } + } + } +} + + proc http::Finish { token {errormsg ""} } { + 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)]} { + if {[catch {eval $state(-command) {$token}} err]} { + if {[string length $errormsg] == 0} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + unset state(-command) + } +} + +# http::reset -- +# +# See documentaion for details. +# +# Arguments: +# token Connection token. +# why Status info. +# Results: +# TODO + +proc http::reset { token {why reset} } { + variable $token + upvar 0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + Finish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + 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. + + +proc http::geturl { url args } { + variable http + if ![info exists http(uid)] { + set http(uid) 0 + } + set token [namespace current]::[incr http(uid)] + variable $token + upvar 0 $token state + reset $token + array set state { + -blocksize 8192 + -validate 0 + -headers {} + -timeout 0 + state header + meta {} + currentsize 0 + totalsize 0 + type text/html + body {} + status "" + } + set options {-blocksize -channel -command -handler -headers \ + -progress -query -validate -timeout} + 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)] && \ + [regexp {^[0-9]+$} $state($flag)] && \ + ![regexp {^[0-9]+$} $value]} { + return -code error "Bad value for $flag ($value), must be integer" + } + set state($flag) $value + } else { + return -code error "Unknown option $flag, can be: $usage" + } + } + if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ + x proto host y port srvurl]} { + error "Unsupported URL: $url" + } + if {[string length $port] == 0} { + set port 80 + } + 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 {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) [list http::reset $token timeout]] + } + if {[info exists phost] && [string length $phost]} { + set srvurl $url + set s [socket $phost $pport] + } else { + set s [socket $host $port] + } + set state(sock) $s + + # 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 len 0 + set how GET + if {[info exists state(-query)]} { + set len [string length $state(-query)] + if {$len > 0} { + set how POST + } + } elseif {$state(-validate)} { + set how HEAD + } + 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 length $key]} { + puts $s "$key: $value" + } + } + if {$len > 0} { + puts $s "Content-Length: $len" + puts $s "Content-Type: application/x-www-form-urlencoded" + puts $s "" + fconfigure $s -translation {auto binary} + puts $s $state(-query) + } else { + puts $s "" + } + flush $s + fileevent $s readable [list http::Event $token] + if {! [info exists state(-command)]} { + wait $token + } + 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::size {token} { + variable $token + upvar 0 $token state + return $state(currentsize) +} + + proc http::Event {token} { + variable $token + upvar 0 $token state + set s $state(sock) + + if [::eof $s] then { + Eof $token + return + } + if {$state(state) == "header"} { + set n [gets $s line] + if {$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 $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)} + } + } + } +} + 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 + } +} + 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)} + } + if {([string length $error] != 0)} { + Finish $token $error + } elseif {[::eof $s]} { + Eof $token + } else { + CopyStart $s $token + } +} + proc http::Eof {token} { + variable $token + upvar 0 $token state + if {$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} { + vwait $token\(status) + } + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } + 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 {$sep != "="} { + set sep = + } else { + set sep & + } + } + return $result +} + +# do x-www-urlencoded character mapping +# 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 + + proc http::mapReply {string} { + variable formMap + 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] +} + +# Default proxy filter. + 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 new file mode 100644 index 0000000..01052f3 --- /dev/null +++ b/library/http2.3/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.0 +# 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.0 [list tclPkgSetup $dir http 2.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait}}}] diff --git a/library/init.tcl b/library/init.tcl new file mode 100644 index 0000000..ebf1913 --- /dev/null +++ b/library/init.tcl @@ -0,0 +1,785 @@ +# init.tcl -- +# +# Default system startup file for Tcl-based applications. Defines +# "unknown" procedure and auto-load facilities. +# +# SCCS: @(#) init.tcl 1.95 97/11/19 17:16:34 +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +if {[info commands package] == ""} { + error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" +} +package require -exact Tcl 8.0 + +# Compute the auto path to use in this interpreter. +# (auto_path could be already set, in safe interps for instance) + +if {![info exists auto_path]} { + if [catch {set auto_path $env(TCLLIBPATH)}] { + set auto_path "" + } +} +if {[lsearch -exact $auto_path [info library]] < 0} { + lappend auto_path [info library] +} +catch { + foreach __dir $tcl_pkgPath { + if {[lsearch -exact $auto_path $__dir] < 0} { + lappend auto_path $__dir + } + } + unset __dir +} + +# Setup the unknown package handler + +package unknown tclPkgUnknown + +# Conditionalize for presence of exec. + +if {[info commands exec] == ""} { + + # Some machines, such as the Macintosh, do not have exec. Also, on all + # platforms, safe interpreters do not have exec. + + set auto_noexec 1 +} +set errorCode "" +set errorInfo "" + +# Define a log command (which can be overwitten to log errors +# differently, specially when stderr is not available) + +if {[info commands tclLog] == ""} { + proc tclLog {string} { + catch {puts stderr $string} + } +} + +# The procs defined in this file that have a leading space +# are 'hidden' from auto_mkindex because they are not +# auto-loadable. + + +# unknown -- +# This procedure is called when a Tcl command is invoked that doesn't +# exist in the interpreter. It takes the following steps to make the +# command available: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !<number>, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + + proc unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + return -code error "self-referential recursion in \"unknown\" for command \"$name\""; + } + set unknown_pending($name) pending; + set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg] + unset unknown_pending($name); + if {$ret != 0} { + return -code $ret -errorcode $errorCode \ + "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { + unset unknown_pending + } + if $msg { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set code [catch {uplevel 1 $args} msg] + if {$code == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code error -errorcode $errorCode \ + -errorinfo $new $msg + } else { + return -code $code $msg + } + } + } + + if {([info level] == 1) && ([info script] == "") \ + && [info exists tcl_interactive] && $tcl_interactive} { + if ![info exists auto_noexec] { + set new [auto_execok $name] + if {$new != ""} { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set redir "" + if {[info commands console] == ""} { + set redir ">&@stdout <@stdin" + } + return [uplevel exec $redir $new [lrange $args 1 end]] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + if {$name == "!!"} { + set newcmd [history event] + } elseif {[regexp {^!(.+)$} $name dummy event]} { + set newcmd [history event $event] + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} { + set newcmd [history event -1] + catch {regsub -all -- $old $newcmd $new newcmd} + } + if [info exists newcmd] { + tclLog $newcmd + history change $newcmd 0 + return [uplevel $newcmd] + } + + set ret [catch {set cmds [info commands $name*]} msg] + if {[string compare $name "::"] == 0} { + set name "" + } + if {$ret != 0} { + return -code $ret -errorcode $errorCode \ + "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg" + } + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } + if {[llength $cmds] != 0} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error \ + "ambiguous command name \"$name\": [lsort $cmds]" + } + } + } + return -code error "invalid command name \"$name\"" +} + +# auto_load -- +# Checks a collection of library directories to see if a procedure +# is defined in one of them. If so, it sources the appropriate +# library file to create the procedure. Returns 1 if it successfully +# loaded the procedure, 0 otherwise. +# +# Arguments: +# cmd - Name of the command to find and load. +# namespace (optional) The namespace where the command is being used - must be +# a canonical namespace as returned [namespace current] +# for instance. If not given, namespace current is used. + + proc auto_load {cmd {namespace {}}} { + global auto_index auto_oldpath auto_path env errorInfo errorCode + + if {[string length $namespace] == 0} { + set namespace [uplevel {namespace current}] + } + set nameList [auto_qualify $cmd $namespace] + # workaround non canonical auto_index entries that might be around + # from older auto_mkindex versions + lappend nameList $cmd + foreach name $nameList { + if [info exists auto_index($name)] { + uplevel #0 $auto_index($name) + return [expr {[info commands $name] != ""}] + } + } + if ![info exists auto_path] { + return 0 + } + if [info exists auto_oldpath] { + if {$auto_oldpath == $auto_path} { + return 0 + } + } + set auto_oldpath $auto_path + + # Check if we are a safe interpreter. In that case, we support only + # newer format tclIndex files. + + set issafe [interp issafe] + for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + set dir [lindex $auto_path $i] + set f "" + if {$issafe} { + catch {source [file join $dir tclIndex]} + } elseif [catch {set f [open [file join $dir tclIndex]]}] { + continue + } else { + set error [catch { + set id [gets $f] + if {$id == "# Tcl autoload index file, version 2.0"} { + eval [read $f] + } elseif {$id == \ + "# Tcl autoload index file: each line identifies a Tcl"} { + while {[gets $f line] >= 0} { + if {([string index $line 0] == "#") + || ([llength $line] != 2)} { + continue + } + set name [lindex $line 0] + set auto_index($name) \ + "source [file join $dir [lindex $line 1]]" + } + } else { + error \ + "[file join $dir tclIndex] isn't a proper Tcl index file" + } + } msg] + if {$f != ""} { + close $f + } + if $error { + error $msg $errorInfo $errorCode + } + } + } + foreach name $nameList { + if [info exists auto_index($name)] { + uplevel #0 $auto_index($name) + if {[info commands $name] != ""} { + return 1 + } + } + } + return 0 +} + +# auto_qualify -- +# compute a fully qualified names list for use in the auto_index array. +# For historical reasons, commands in the global namespace do not have leading +# :: in the index key. The list has two elements when the command name is +# relative (no leading ::) and the namespace is not the global one. Otherwise +# only one name is returned (and searched in the auto_index). +# +# Arguments - +# cmd The command name. Can be any name accepted for command +# invocations (Like "foo::::bar"). +# namespace The namespace where the command is being used - must be +# a canonical namespace as returned by [namespace current] +# for instance. + + proc auto_qualify {cmd namespace} { + + # count separators and clean them up + # (making sure that foo:::::bar will be treated as foo::bar) + set n [regsub -all {::+} $cmd :: cmd] + + # Ignore namespace if the name starts with :: + # Handle special case of only leading :: + + # Before each return case we give an example of which category it is + # with the following form : + # ( inputCmd, inputNameSpace) -> output + + if {[regexp {^::(.*)$} $cmd x tail]} { + if {$n > 1} { + # ( ::foo::bar , * ) -> ::foo::bar + return [list $cmd] + } else { + # ( ::global , * ) -> global + return [list $tail] + } + } + + # Potentially returning 2 elements to try : + # (if the current namespace is not the global one) + + if {$n == 0} { + if {[string compare $namespace ::] == 0} { + # ( nocolons , :: ) -> nocolons + return [list $cmd] + } else { + # ( nocolons , ::sub ) -> ::sub::nocolons nocolons + return [list ${namespace}::$cmd $cmd] + } + } else { + if {[string compare $namespace ::] == 0} { + # ( foo::bar , :: ) -> ::foo::bar + return [list ::$cmd] + } else { + # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar + return [list ${namespace}::$cmd ::$cmd] + } + } +} + +if {[string compare $tcl_platform(platform) windows] == 0} { + +# auto_execok -- +# +# Returns string that indicates name of program to execute if +# name corresponds to a shell builtin or an executable in the +# Windows search path, or "" otherwise. Builds an associative +# array auto_execs that caches information about previous checks, +# for speed. +# +# Arguments: +# name - Name of a command. + +# Windows version. +# +# Note that info executable doesn't work under Windows, so we have to +# look for files with .exe, .com, or .bat extensions. Also, the path +# may be in the Path or PATH environment variables, and path +# components are separated with semicolons, not colons as under Unix. +# +proc auto_execok name { + global auto_execs env tcl_platform + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) "" + + if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename + ren rmdir rd time type ver vol} $name] != -1} { + return [set auto_execs($name) [list $env(COMSPEC) /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext {{} .com .exe .bat} { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + return "" + } + + set path "[file dirname [info nameof]];.;" + if {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + if {$tcl_platform(os) == "Windows NT"} { + append path "$windir/system32;" + } + append path "$windir/system;$windir;" + } + + if {[info exists env(PATH)]} { + append path $env(PATH) + } + + foreach dir [split $path {;}] { + if {$dir == ""} { + set dir . + } + foreach ext {{} .com .exe .bat} { + set file [file join $dir ${name}${ext}] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + } + return "" +} + +} else { + +# auto_execok -- +# +# Returns string that indicates name of program to execute if +# name corresponds to an executable in the path. Builds an associative +# array auto_execs that caches information about previous checks, +# for speed. +# +# Arguments: +# name - Name of a command. + +# Unix version. +# +proc auto_execok name { + global auto_execs env + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) "" + if {[llength [file split $name]] != 1} { + if {[file executable $name] && ![file isdirectory $name]} { + set auto_execs($name) [list $name] + } + return $auto_execs($name) + } + foreach dir [split $env(PATH) :] { + if {$dir == ""} { + set dir . + } + set file [file join $dir $name] + if {[file executable $file] && ![file isdirectory $file]} { + set auto_execs($name) [list $file] + return $auto_execs($name) + } + } + return "" +} + +} +# auto_reset -- +# Destroy all cached information for auto-loading and auto-execution, +# so that the information gets recomputed the next time it's needed. +# Also delete any procedures that are listed in the auto-load index +# except those defined in this file. +# +# Arguments: +# None. + +proc auto_reset {} { + global auto_execs auto_index auto_oldpath + foreach p [info procs] { + if {[info exists auto_index($p)] && ![string match auto_* $p] + && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup + tclMacPkgSearch tclPkgUnknown} $p] < 0)} { + rename $p {} + } + } + catch {unset auto_execs} + catch {unset auto_index} + catch {unset auto_oldpath} +} + +# auto_mkindex -- +# Regenerate a tclIndex file from Tcl source files. Takes as argument +# the name of the directory in which the tclIndex file is to be placed, +# followed by any number of glob patterns to use in that directory to +# locate all of the relevant files. It does not parse or source the file +# so the generated index will not contain the appropriate namespace qualifiers +# if you don't explicitly specify it. +# +# Arguments: +# dir - Name of the directory in which to create an index. +# args - Any number of additional arguments giving the +# names of files within dir. If no additional +# are given auto_mkindex will look for *.tcl. + +proc auto_mkindex {dir args} { + global errorCode errorInfo + set oldDir [pwd] + cd $dir + set dir [pwd] + append index "# Tcl autoload index file, version 2.0\n" + append index "# This file is generated by the \"auto_mkindex\" command\n" + append index "# and sourced to set up indexing information for one or\n" + append index "# more commands. Typically each line is a command that\n" + append index "# sets an element in the auto_index array, where the\n" + append index "# element name is the name of a command and the value is\n" + append index "# a script that loads the command.\n\n" + if {$args == ""} { + set args *.tcl + } + foreach file [eval glob $args] { + set f "" + set error [catch { + set f [open $file] + while {[gets $f line] >= 0} { + if [regexp {^proc[ ]+([^ ]*)} $line match procName] { + set procName [lindex [auto_qualify $procName "::"] 0] + append index "set [list auto_index($procName)]" + append index " \[list source \[file join \$dir [list $file]\]\]\n" + } + } + close $f + } msg] + if $error { + set code $errorCode + set info $errorInfo + catch {close $f} + cd $oldDir + error $msg $info $code + } + } + set f "" + set error [catch { + set f [open tclIndex w] + puts $f $index nonewline + close $f + cd $oldDir + } msg] + if $error { + set code $errorCode + set info $errorInfo + catch {close $f} + cd $oldDir + error $msg $info $code + } +} + +# pkg_mkIndex -- +# This procedure creates a package index in a given directory. The +# package index consists of a "pkgIndex.tcl" file whose contents are +# a Tcl script that sets up package information with "package require" +# commands. The commands describe all of the packages defined by the +# files given as arguments. +# +# Arguments: +# dir - Name of the directory in which to create the index. +# args - Any number of additional arguments, each giving +# a glob pattern that matches the names of one or +# more shared libraries or Tcl script files in +# dir. + +proc pkg_mkIndex {dir args} { + global errorCode errorInfo + if {[llength $args] == 0} { + return -code error "wrong # args: should be\ + \"pkg_mkIndex dir pattern ?pattern ...?\""; + } + append index "# Tcl package index file, version 1.0\n" + append index "# This file is generated by the \"pkg_mkIndex\" command\n" + append index "# and sourced either when an application starts up or\n" + append index "# by a \"package unknown\" script. It invokes the\n" + append index "# \"package ifneeded\" command to set up package-related\n" + append index "# information so that packages will be loaded automatically\n" + append index "# in response to \"package require\" commands. When this\n" + append index "# script is sourced, the variable \$dir must contain the\n" + append index "# full path name of this file's directory.\n" + set oldDir [pwd] + cd $dir + foreach file [eval glob $args] { + # For each file, figure out what commands and packages it provides. + # To do this, create a child interpreter, load the file into the + # interpreter, and get a list of the new commands and packages + # that are defined. Define an empty "package unknown" script so + # that there are no recursive package inclusions. + + set c [interp create] + + # If Tk is loaded in the parent interpreter, load it into the + # child also, in case the extension depends on it. + + foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + $c eval {set argv {-geometry +0+0}} + load [lindex $pkg 0] Tk $c + break + } + } + $c eval [list set file $file] + if [catch { + $c eval { + proc dummy args {} + rename package package-orig + proc package {what args} { + switch -- $what { + require { return ; # ignore transitive requires } + default { eval package-orig {$what} $args } + } + } + proc pkgGetAllNamespaces {{root {}}} { + set list $root + foreach ns [namespace children $root] { + eval lappend list [pkgGetAllNamespaces $ns] + } + return $list + } + package unknown dummy + set origCmds [info commands] + set dir "" ;# in case file is pkgIndex.tcl + set pkgs "" + + # Try to load the file if it has the shared library extension, + # otherwise source it. It's important not to try to load + # files that aren't shared libraries, because on some systems + # (like SunOS) the loader will abort the whole application + # when it gets an error. + + if {[string compare [file extension $file] \ + [info sharedlibextension]] == 0} { + + # The "file join ." command below is necessary. Without + # it, if the file name has no \'s and we're on UNIX, the + # load command will invoke the LD_LIBRARY_PATH search + # mechanism, which could cause the wrong file to be used. + + load [file join . $file] + set type load + } else { + source $file + set type source + } + foreach ns [pkgGetAllNamespaces] { + namespace import ${ns}::* + } + foreach i [info commands] { + set cmds($i) 1 + } + foreach i $origCmds { + catch {unset cmds($i)} + + } + foreach i [array names cmds] { + # reverse engineer which namespace a command comes from + set absolute [namespace origin $i] + if {[string compare ::$i $absolute] != 0} { + set cmds($absolute) 1 + unset cmds($i) + } + } + foreach i [package names] { + if {([string compare [package provide $i] ""] != 0) + && ([string compare $i Tcl] != 0) + && ([string compare $i Tk] != 0)} { + lappend pkgs [list $i [package provide $i]] + } + } + } + } msg] { + tclLog "error while loading or sourcing $file: $msg" + } + foreach pkg [$c eval set pkgs] { + lappend files($pkg) [list $file [$c eval set type] \ + [lsort [$c eval array names cmds]]] + } + interp delete $c + } + foreach pkg [lsort [array names files]] { + append index "\npackage ifneeded $pkg\ + \[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\ + [list $files($pkg)]\]" + } + set f [open pkgIndex.tcl w] + puts $f $index + close $f + cd $oldDir +} + +# tclPkgSetup -- +# This is a utility procedure use by pkgIndex.tcl files. It is invoked +# as part of a "package ifneeded" script. It calls "package provide" +# to indicate that a package is available, then sets entries in the +# auto_index array so that the package's files will be auto-loaded when +# the commands are used. +# +# Arguments: +# dir - Directory containing all the files for this package. +# pkg - Name of the package (no version number). +# version - Version number for the package, such as 2.1.3. +# files - List of files that constitute the package. Each +# element is a sub-list with three elements. The first +# is the name of a file relative to $dir, the second is +# "load" or "source", indicating whether the file is a +# loadable binary or a script to source, and the third +# is a list of commands defined by this file. + +proc tclPkgSetup {dir pkg version files} { + global auto_index + + package provide $pkg $version + foreach fileInfo $files { + set f [lindex $fileInfo 0] + set type [lindex $fileInfo 1] + foreach cmd [lindex $fileInfo 2] { + if {$type == "load"} { + set auto_index($cmd) [list load [file join $dir $f] $pkg] + } else { + set auto_index($cmd) [list source [file join $dir $f]] + } + } + } +} + +# tclMacPkgSearch -- +# The procedure is used on the Macintosh to search a given directory for files +# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the +# interpreter to setup the package database. + +proc tclMacPkgSearch {dir} { + foreach x [glob -nocomplain [file join $dir *.shlb]] { + if [file isfile $x] { + set res [resource open $x] + foreach y [resource list TEXT $res] { + if {$y == "pkgIndex"} {source -rsrc pkgIndex} + } + catch {resource close $res} + } + } +} + +# tclPkgUnknown -- +# This procedure provides the default for the "package unknown" function. +# It is invoked when a package that's needed can't be found. It scans +# the auto_path directories and their immediate children looking for +# pkgIndex.tcl files and sources any such files that are found to setup +# the package database. (On the Macintosh we also search for pkgIndex +# TEXT resources in all files.) +# +# Arguments: +# name - Name of desired package. Not used. +# version - Version of desired package. Not used. +# exact - Either "-exact" or omitted. Not used. + +proc tclPkgUnknown {name version {exact {}}} { + global auto_path tcl_platform env + + if ![info exists auto_path] { + return + } + for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + # we can't use glob in safe interps, so enclose the following + # in a catch statement + catch { + foreach file [glob -nocomplain [file join [lindex $auto_path $i] \ + * pkgIndex.tcl]] { + set dir [file dirname $file] + if [catch {source $file} msg] { + tclLog "error reading package index file $file: $msg" + } + } + } + set dir [lindex $auto_path $i] + set file [file join $dir pkgIndex.tcl] + # safe interps usually don't have "file readable", nor stderr channel + if {[interp issafe] || [file readable $file]} { + if {[catch {source $file} msg] && ![interp issafe]} { + tclLog "error reading package index file $file: $msg" + } + } + # On the Macintosh we also look in the resource fork + # of shared libraries + # We can't use tclMacPkgSearch in safe interps because it uses glob + if {(![interp issafe]) && ($tcl_platform(platform) == "macintosh")} { + set dir [lindex $auto_path $i] + tclMacPkgSearch $dir + foreach x [glob -nocomplain [file join $dir *]] { + if [file isdirectory $x] { + set dir $x + tclMacPkgSearch $dir + } + } + } + } +} diff --git a/library/ldAout.tcl b/library/ldAout.tcl new file mode 100644 index 0000000..7914508 --- /dev/null +++ b/library/ldAout.tcl @@ -0,0 +1,240 @@ +# ldAout.tcl -- +# +# This "tclldAout" procedure in this script acts as a replacement +# for the "ld" command when linking an object file that will be +# loaded dynamically into Tcl or Tk using pseudo-static linking. +# +# Parameters: +# The arguments to the script are the command line options for +# an "ld" command. +# +# Results: +# The "ld" command is parsed, and the "-o" option determines the +# module name. ".a" and ".o" options are accumulated. +# The input archives and object files are examined with the "nm" +# command to determine whether the modules initialization +# entry and safe initialization entry are present. A trivial +# C function that locates the entries is composed, compiled, and +# its .o file placed before all others in the command; then +# "ld" is executed to bind the objects together. +# +# SCCS: @(#) ldAout.tcl 1.12 96/11/30 17:11:02 +# +# Copyright (c) 1995, by General Electric Company. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# This work was supported in part by the ARPA Manufacturing Automation +# and Design Engineering (MADE) Initiative through ARPA contract +# F33615-94-C-4400. + +proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} { + global env + global argv + + if {$cc==""} { + set cc $env(CC) + } + + # if only two parameters are supplied there is assumed that the + # only shlib_suffix is missing. This parameter is anyway available + # as "info sharedlibextension" too, so there is no need to transfer + # 3 parameters to the function tclLdAout. For compatibility, this + # function now accepts both 2 and 3 parameters. + + if {$shlib_suffix==""} { + set shlib_cflags $env(SHLIB_CFLAGS) + } else { + if {$shlib_cflags=="none"} { + set shlib_cflags $shlib_suffix + } + } + + # seenDotO is nonzero if a .o or .a file has been seen + + set seenDotO 0 + + # minusO is nonzero if the last command line argument was "-o". + + set minusO 0 + + # head has command line arguments up to but not including the first + # .o or .a file. tail has the rest of the arguments. + + set head {} + set tail {} + + # nmCommand is the "nm" command that lists global symbols from the + # object files. + + set nmCommand {|nm -g} + + # entryProtos is the table of _Init and _SafeInit prototypes found in the + # module. + + set entryProtos {} + + # entryPoints is the table of _Init and _SafeInit entries found in the + # module. + + set entryPoints {} + + # libraries is the list of -L and -l flags to the linker. + + set libraries {} + set libdirs {} + + # Process command line arguments + + foreach a $argv { + if {!$minusO && [regexp {\.[ao]$} $a]} { + set seenDotO 1 + lappend nmCommand $a + } + if {$minusO} { + set outputFile $a + set minusO 0 + } elseif {![string compare $a -o]} { + set minusO 1 + } + if [regexp {^-[lL]} $a] { + lappend libraries $a + if [regexp {^-L} $a] { + lappend libdirs [string range $a 2 end] + } + } elseif {$seenDotO} { + lappend tail $a + } else { + lappend head $a + } + } + lappend libdirs /lib /usr/lib + + # MIPS -- If there are corresponding G0 libraries, replace the + # ordinary ones with the G0 ones. + + set libs {} + foreach lib $libraries { + if [regexp {^-l} $lib] { + set lname [string range $lib 2 end] + foreach dir $libdirs { + if [file exists [file join $dir lib${lname}_G0.a]] { + set lname ${lname}_G0 + break + } + } + lappend libs -l$lname + } else { + lappend libs $lib + } + } + set libraries $libs + + # Extract the module name from the "-o" option + + if {![info exists outputFile]} { + error "-o option must be supplied to link a Tcl load module" + } + set m [file tail $outputFile] + if [regexp {\.a$} $outputFile] { + set shlib_suffix .a + } else { + set shlib_suffix "" + } + if [regexp {\..*$} $outputFile match] { + set l [expr [string length $m] - [string length $match]] + } else { + error "Output file does not appear to have a suffix" + } + set modName [string tolower [string range $m 0 [expr $l-1]]] + if [regexp {^lib} $modName] { + set modName [string range $modName 3 end] + } + if [regexp {[0-9\.]*(_g0)?$} $modName match] { + set modName [string range $modName 0 [expr [string length $modName]-[string length $match]-1]] + } + set modName "[string toupper [string index $modName 0]][string range $modName 1 end]" + + # Catalog initialization entry points found in the module + + set f [open $nmCommand r] + while {[gets $f l] >= 0} { + if [regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol] { + if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} { + set s $symbol + } + append entryProtos {extern int } $symbol { (); } \n + append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n + } + } + close $f + + if {$entryPoints==""} { + error "No entry point found in objects" + } + + # Compose a C function that resolves the initialization entry points and + # embeds the required libraries in the object code. + + set C {#include <string.h>} + append C \n + append C {char TclLoadLibraries_} $modName { [] =} \n + append C { "@LIBS: } $libraries {";} \n + append C $entryProtos + append C {static struct } \{ \n + append C { char * name;} \n + append C { int (*value)();} \n + append C \} {dictionary [] = } \{ \n + append C $entryPoints + append C { 0, 0 } \n \} \; \n + append C {typedef struct Tcl_Interp Tcl_Interp;} \n + append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n + append C {Tcl_PackageInitProc *} \n + append C TclLoadDictionary_ $modName { (symbol)} \n + append C { char * symbol;} \n + append C {{ + int i; + for (i = 0; dictionary [i] . name != 0; ++i) { + if (!strcmp (symbol, dictionary [i] . name)) { + return dictionary [i].value; + } + } + return 0; +}} \n + + # Write the C module and compile it + + set cFile tcl$modName.c + set f [open $cFile w] + puts -nonewline $f $C + close $f + set ccCommand "$cc -c $shlib_cflags $cFile" + puts stderr $ccCommand + eval exec $ccCommand + + # Now compose and execute the ld command that packages the module + + if {$shlib_suffix == ".a"} { + set ldCommand "ar cr $outputFile" + regsub { -o} $tail {} tail + } else { + set ldCommand ld + foreach item $head { + lappend ldCommand $item + } + } + lappend ldCommand tcl$modName.o + foreach item $tail { + lappend ldCommand $item + } + puts stderr $ldCommand + eval exec $ldCommand + if {$shlib_suffix == ".a"} { + exec ranlib $outputFile + } + + # Clean up working files + + exec /bin/rm $cFile [file rootname $cFile].o +} diff --git a/library/opt0.1/optparse.tcl b/library/opt0.1/optparse.tcl new file mode 100644 index 0000000..12135da --- /dev/null +++ b/library/opt0.1/optparse.tcl @@ -0,0 +1,1094 @@ +# optparse.tcl -- +# +# (Private) option parsing package +# +# This might be documented and exported in 8.1 +# and some function hopefully moved to the C core for +# efficiency, if there is enough demand. (mail! ;-) +# +# Author: Laurent Demailly - Laurent.Demailly@sun.com - dl@mail.box.eu.org +# +# Credits: +# this is a complete 'over kill' rewrite by me, from a version +# written initially with Brent Welch, itself initially +# based on work with Steve Uhler. Thanks them ! +# +# SCCS: @(#) optparse.tcl 1.13 97/08/21 11:50:42 + +package provide opt 0.2 + +namespace eval ::tcl { + + # Exported APIs + namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ + OptProc OptProcArgGiven OptParse \ + Lassign Lvarpop Lvarset Lvarincr Lfirst \ + 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 [Lfirst $program] >= 2 +# while +# llength [Lfirst $singleStep] == 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 [Lfirst $res]; + 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} { + Lfirst $lst; + } + # 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 {[Lfirst $item]=="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 [Lfirst $lst] 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} { + Lfirst $item + } + + # current state + proc OptCurState {descriptions} { + OptState [OptCurDesc $descriptions]; + } + + ####### + # Arguments manipulation + + # Returns the argument that has to be processed now + proc OptCurrentArg {lst} { + Lfirst $lst; + } + # Advance to next argument + proc OptNextArg {argsName} { + uplevel [list Lvarpop $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]; + } + if {![Lempty $arguments]} { + return -code error [OptTooManyArgs $descriptions $arguments]; + } + } + + # 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")} { + 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; + + # 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 [Lfirst $indexLst]] [Lrest $indexLst]; +} +# 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 [Lfirst $indexLst]; + 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 [Lrest $indexLst] $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 [Lfirst $indexLst]; + set targetList [lindex $list $idx]; + # reduce refcount on targetList + Lvarset1nc list $idx {}; + # recursively replace in targetList + Lvarincr targetList [Lrest $indexLst] $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; +} +# Returns the first element of a list +proc ::tcl::Lfirst {list} { + lindex $list 0 +} +# Returns the rest of the list minus first element +proc ::tcl::Lrest {list} { + lrange $list 1 end +} +# Removes the first element of a list +proc ::tcl::Lvarpop {listName} { + upvar $listName list; + set list [lrange $list 1 end]; +} +# Same but returns the removed element +proc ::tcl::Lvarpop2 {listName} { + upvar $listName list; + set el [Lfirst $list]; + 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.1/pkgIndex.tcl b/library/opt0.1/pkgIndex.tcl new file mode 100644 index 0000000..7a7ad90 --- /dev/null +++ b/library/opt0.1/pkgIndex.tcl @@ -0,0 +1,7 @@ +# Tcl package index file, version 1.0 +# This file is NOT generated by the "pkg_mkIndex" command +# because if someone just did "package require opt", let's just load +# the package now, so they can readily use it +# and even "namespace import tcl::*" ... +# (tclPkgSetup just makes things slow and do not work so well with namespaces) +package ifneeded opt 0.2 [list source [file join $dir optparse.tcl]] diff --git a/library/parray.tcl b/library/parray.tcl new file mode 100644 index 0000000..430e7ff --- /dev/null +++ b/library/parray.tcl @@ -0,0 +1,29 @@ +# parray: +# Print the contents of a global array on stdout. +# +# SCCS: @(#) parray.tcl 1.9 96/02/16 08:56:44 +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc parray {a {pattern *}} { + upvar 1 $a array + if ![array exists array] { + error "\"$a\" isn't an array" + } + set maxl 0 + foreach name [lsort [array names array $pattern]] { + if {[string length $name] > $maxl} { + set maxl [string length $name] + } + } + set maxl [expr {$maxl + [string length $a] + 2}] + foreach name [lsort [array names array $pattern]] { + set nameString [format %s(%s) $a $name] + puts stdout [format "%-*s = %s" $maxl $nameString $array($name)] + } +} diff --git a/library/safe.tcl b/library/safe.tcl new file mode 100644 index 0000000..9b93523 --- /dev/null +++ b/library/safe.tcl @@ -0,0 +1,893 @@ +# safe.tcl -- +# +# This file provide a safe loading/sourcing mechanism for safe interpreters. +# It implements a virtual path mecanism to hide the real pathnames from the +# slave. It runs in a master interpreter and sets up data structure and +# aliases that will be invoked when used from a slave interpreter. +# +# See the safe.n man page for details. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) safe.tcl 1.26 97/08/21 11:57:20 + +# +# The implementation is based on namespaces. These naming conventions +# are followed: +# Private procs starts with uppercase. +# Public procs are exported and starts with lowercase +# + +# Needed utilities package +package require opt 0.2; + +# Create the safe namespace +namespace eval ::safe { + + # Exported API: + namespace export interpCreate interpInit interpConfigure interpDelete \ + interpAddToAccessPath interpFindInAccessPath \ + setLogCmd ; + +# Proto/dummy declarations for auto_mkIndex +proc ::safe::interpCreate {} {} +proc ::safe::interpInit {} {} +proc ::safe::interpConfigure {} {} + + + #### + # + # Setup the arguments parsing + # + #### + + # Share the descriptions + set temp [::tcl::OptKeyRegister { + {-accessPath -list {} "access path for the slave"} + {-noStatics "prevent loading of statically linked pkgs"} + {-statics true "loading of statically linked pkgs"} + {-nestedLoadOk "allow nested loading"} + {-nested false "nested loading"} + {-deleteHook -script {} "delete hook"} + }] + + # create case (slave is optional) + ::tcl::OptKeyRegister { + {?slave? -name {} "name of the slave (optional)"} + } ::safe::interpCreate ; + # adding the flags sub programs to the command program + # (relying on Opt's internal implementation details) + lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp); + + # init and configure (slave is needed) + ::tcl::OptKeyRegister { + {slave -name {} "name of the slave"} + } ::safe::interpIC; + # adding the flags sub programs to the command program + # (relying on Opt's internal implementation details) + lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp); + # temp not needed anymore + ::tcl::OptKeyDelete $temp; + + + # Helper function to resolve the dual way of specifying staticsok + # (either by -noStatics or -statics 0) + proc InterpStatics {} { + foreach v {Args statics noStatics} { + upvar $v $v + } + set flag [::tcl::OptProcArgGiven -noStatics]; + if {$flag && ($noStatics == $statics) + && ([::tcl::OptProcArgGiven -statics])} { + return -code error\ + "conflicting values given for -statics and -noStatics"; + } + if {$flag} { + return [expr {!$noStatics}]; + } else { + return $statics + } + } + + # Helper function to resolve the dual way of specifying nested loading + # (either by -nestedLoadOk or -nested 1) + proc InterpNested {} { + foreach v {Args nested nestedLoadOk} { + upvar $v $v + } + set flag [::tcl::OptProcArgGiven -nestedLoadOk]; + # note that the test here is the opposite of the "InterpStatics" + # one (it is not -noNested... because of the wanted default value) + if {$flag && ($nestedLoadOk != $nested) + && ([::tcl::OptProcArgGiven -nested])} { + return -code error\ + "conflicting values given for -nested and -nestedLoadOk"; + } + if {$flag} { + # another difference with "InterpStatics" + return $nestedLoadOk + } else { + return $nested + } + } + + #### + # + # API entry points that needs argument parsing : + # + #### + + + # Interface/entry point function and front end for "Create" + proc interpCreate {args} { + set Args [::tcl::OptKeyParse ::safe::interpCreate $args] + InterpCreate $slave $accessPath \ + [InterpStatics] [InterpNested] $deleteHook; + } + + proc interpInit {args} { + set Args [::tcl::OptKeyParse ::safe::interpIC $args] + if {![::interp exists $slave]} { + return -code error \ + "\"$slave\" is not an interpreter"; + } + InterpInit $slave $accessPath \ + [InterpStatics] [InterpNested] $deleteHook; + } + + proc CheckInterp {slave} { + if {![IsInterp $slave]} { + return -code error \ + "\"$slave\" is not an interpreter managed by ::safe::" ; + } + } + + # Interface/entry point function and front end for "Configure" + # This code is awfully pedestrian because it would need + # more coupling and support between the way we store the + # configuration values in safe::interp's and the Opt package + # Obviously we would like an OptConfigure + # to avoid duplicating all this code everywhere. -> TODO + # (the app should share or access easily the program/value + # stored by opt) + # This is even more complicated by the boolean flags with no values + # that we had the bad idea to support for the sake of user simplicity + # in create/init but which makes life hard in configure... + # So this will be hopefully written and some integrated with opt1.0 + # (hopefully for tcl8.1 ?) + proc interpConfigure {args} { + switch [llength $args] { + 1 { + # If we have exactly 1 argument + # the semantic is to return all the current configuration + # We still call OptKeyParse though we know that "slave" + # is our given argument because it also checks + # for the "-help" option. + set Args [::tcl::OptKeyParse ::safe::interpIC $args]; + CheckInterp $slave; + set res {} + lappend res [list -accessPath [Set [PathListName $slave]]] + lappend res [list -statics [Set [StaticsOkName $slave]]] + lappend res [list -nested [Set [NestedOkName $slave]]] + lappend res [list -deleteHook [Set [DeleteHookName $slave]]] + join $res + } + 2 { + # If we have exactly 2 arguments + # the semantic is a "configure get" + ::tcl::Lassign $args slave arg; + # get the flag sub program (we 'know' about Opt's internal + # representation of data) + set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2] + set hits [::tcl::OptHits desc $arg]; + if {$hits > 1} { + return -code error [::tcl::OptAmbigous $desc $arg] + } elseif {$hits == 0} { + return -code error [::tcl::OptFlagUsage $desc $arg] + } + CheckInterp $slave; + set item [::tcl::OptCurDesc $desc]; + set name [::tcl::OptName $item]; + switch -exact -- $name { + -accessPath { + return [list -accessPath [Set [PathListName $slave]]] + } + -statics { + return [list -statics [Set [StaticsOkName $slave]]] + } + -nested { + return [list -nested [Set [NestedOkName $slave]]] + } + -deleteHook { + return [list -deleteHook [Set [DeleteHookName $slave]]] + } + -noStatics { + # it is most probably a set in fact + # but we would need then to jump to the set part + # and it is not *sure* that it is a set action + # that the user want, so force it to use the + # unambigous -statics ?value? instead: + return -code error\ + "ambigous query (get or set -noStatics ?)\ + use -statics instead"; + } + -nestedLoadOk { + return -code error\ + "ambigous query (get or set -nestedLoadOk ?)\ + use -nested instead"; + } + default { + return -code error "unknown flag $name (bug)"; + } + } + } + default { + # Otherwise we want to parse the arguments like init and create + # did + set Args [::tcl::OptKeyParse ::safe::interpIC $args]; + CheckInterp $slave; + # Get the current (and not the default) values of + # whatever has not been given: + if {![::tcl::OptProcArgGiven -accessPath]} { + set doreset 1 + set accessPath [Set [PathListName $slave]] + } else { + set doreset 0 + } + if { (![::tcl::OptProcArgGiven -statics]) + && (![::tcl::OptProcArgGiven -noStatics]) } { + set statics [Set [StaticsOkName $slave]] + } else { + set statics [InterpStatics] + } + if { ([::tcl::OptProcArgGiven -nested]) + || ([::tcl::OptProcArgGiven -nestedLoadOk]) } { + set nested [InterpNested] + } else { + set nested [Set [NestedOkName $slave]] + } + if {![::tcl::OptProcArgGiven -deleteHook]} { + set deleteHook [Set [DeleteHookName $slave]] + } + # we can now reconfigure : + InterpSetConfig $slave $accessPath \ + $statics $nested $deleteHook; + # auto_reset the slave (to completly synch the new access_path) + if {$doreset} { + if {[catch {::interp eval $slave {auto_reset}} msg]} { + Log $slave "auto_reset failed: $msg"; + } else { + Log $slave "successful auto_reset" NOTICE; + } + } + } + } + } + + + #### + # + # Functions that actually implements the exported APIs + # + #### + + + # + # safe::InterpCreate : doing the real job + # + # This procedure creates a safe slave and initializes it with the + # safe base aliases. + # NB: slave name must be simple alphanumeric string, no spaces, + # no (), no {},... {because the state array is stored as part of the name} + # + # Returns the slave name. + # + # Optional Arguments : + # + slave name : if empty, generated name will be used + # + access_path: path list controlling where load/source can occur, + # if empty: the master auto_path will be used. + # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) + # if 1 :static packages are ok. + # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub) + # if 1 : multiple levels are ok. + + # use the full name and no indent so auto_mkIndex can find us + proc ::safe::InterpCreate { + slave + access_path + staticsok + nestedok + deletehook + } { + # Create the slave. + if {[string compare "" $slave]} { + ::interp create -safe $slave; + } else { + # empty argument: generate slave name + set slave [::interp create -safe]; + } + Log $slave "Created" NOTICE; + + # Initialize it. (returns slave name) + InterpInit $slave $access_path $staticsok $nestedok $deletehook; + } + + + # + # InterpSetConfig (was setAccessPath) : + # Sets up slave virtual auto_path and corresponding structure + # within the master. Also sets the tcl_library in the slave + # to be the first directory in the path. + # Nb: If you change the path after the slave has been initialized + # you probably need to call "auto_reset" in the slave in order that it + # gets the right auto_index() array values. + + proc ::safe::InterpSetConfig {slave access_path staticsok\ + nestedok deletehook} { + + # determine and store the access path if empty + if {[string match "" $access_path]} { + set access_path [uplevel #0 set auto_path]; + # Make sure that tcl_library is in auto_path + # and at the first position (needed by setAccessPath) + set where [lsearch -exact $access_path [info library]]; + if {$where == -1} { + # not found, add it. + set access_path [concat [list [info library]] $access_path]; + Log $slave "tcl_library was not in auto_path,\ + added it to slave's access_path" NOTICE; + } elseif {$where != 0} { + # not first, move it first + set access_path [concat [list [info library]]\ + [lreplace $access_path $where $where]]; + Log $slave "tcl_libray was not in first in auto_path,\ + moved it to front of slave's access_path" NOTICE; + + } + + # Add 1st level sub dirs (will searched by auto loading from tcl + # code in the slave using glob and thus fail, so we add them + # here so by default it works the same). + set access_path [AddSubDirs $access_path]; + } + + Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ + nestedok=$nestedok deletehook=($deletehook)" NOTICE; + + # clear old autopath if it existed + set nname [PathNumberName $slave]; + if {[Exists $nname]} { + set n [Set $nname]; + for {set i 0} {$i<$n} {incr i} { + Unset [PathToken $i $slave]; + } + } + + # build new one + set slave_auto_path {} + set i 0; + foreach dir $access_path { + Set [PathToken $i $slave] $dir; + lappend slave_auto_path "\$[PathToken $i]"; + incr i; + } + Set $nname $i; + Set [PathListName $slave] $access_path; + Set [VirtualPathListName $slave] $slave_auto_path; + + Set [StaticsOkName $slave] $staticsok + Set [NestedOkName $slave] $nestedok + Set [DeleteHookName $slave] $deletehook + + SyncAccessPath $slave; + } + + # + # + # FindInAccessPath: + # Search for a real directory and returns its virtual Id + # (including the "$") +proc ::safe::interpFindInAccessPath {slave path} { + set access_path [GetAccessPath $slave]; + set where [lsearch -exact $access_path $path]; + if {$where == -1} { + return -code error "$path not found in access path $access_path"; + } + return "\$[PathToken $where]"; + } + + # + # addToAccessPath: + # add (if needed) a real directory to access path + # and return its virtual token (including the "$"). +proc ::safe::interpAddToAccessPath {slave path} { + # first check if the directory is already in there + if {![catch {interpFindInAccessPath $slave $path} res]} { + return $res; + } + # new one, add it: + set nname [PathNumberName $slave]; + set n [Set $nname]; + Set [PathToken $n $slave] $path; + + set token "\$[PathToken $n]"; + + Lappend [VirtualPathListName $slave] $token; + Lappend [PathListName $slave] $path; + Set $nname [expr $n+1]; + + SyncAccessPath $slave; + + return $token; + } + + # This procedure applies the initializations to an already existing + # interpreter. It is useful when you want to install the safe base + # aliases into a preexisting safe interpreter. + proc ::safe::InterpInit { + slave + access_path + staticsok + nestedok + deletehook + } { + + # Configure will generate an access_path when access_path is + # empty. + InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook; + + # These aliases let the slave load files to define new commands + + # NB we need to add [namespace current], aliases are always + # absolute paths. + ::interp alias $slave source {} [namespace current]::AliasSource $slave + ::interp alias $slave load {} [namespace current]::AliasLoad $slave + + # This alias lets the slave have access to a subset of the 'file' + # command functionality. + + AliasSubset $slave file file dir.* join root.* ext.* tail \ + path.* split + + # This alias interposes on the 'exit' command and cleanly terminates + # the slave. + + ::interp alias $slave exit {} [namespace current]::interpDelete $slave + + # The allowed slave variables already have been set + # by Tcl_MakeSafe(3) + + + # Source init.tcl into the slave, to get auto_load and other + # procedures defined: + + # We don't try to use the -rsrc on the mac because it would get + # confusing if you would want to customize init.tcl + # for a given set of safe slaves, on all the platforms + # you just need to give a specific access_path and + # the mac should be no exception. As there is no + # obvious full "safe ressources" design nor implementation + # for the mac, safe interps there will just don't + # have that ability. (A specific app can still reenable + # that using custom aliases if they want to). + # It would also make the security analysis and the Safe Tcl security + # model platform dependant and thus more error prone. + + if {[catch {::interp eval $slave\ + {source [file join $tcl_library init.tcl]}}\ + msg]} { + Log $slave "can't source init.tcl ($msg)"; + error "can't source init.tcl into slave $slave ($msg)" + } + + return $slave + } + + + # Add (only if needed, avoid duplicates) 1 level of + # sub directories to an existing path list. + # Also removes non directories from the returned list. + proc AddSubDirs {pathList} { + set res {} + foreach dir $pathList { + if {[file isdirectory $dir]} { + # check that we don't have it yet as a children + # of a previous dir + if {[lsearch -exact $res $dir]<0} { + lappend res $dir; + } + foreach sub [glob -nocomplain -- [file join $dir *]] { + if { ([file isdirectory $sub]) + && ([lsearch -exact $res $sub]<0) } { + # new sub dir, add it ! + lappend res $sub; + } + } + } + } + return $res; + } + + # This procedure deletes a safe slave managed by Safe Tcl and + # cleans up associated state: + +proc ::safe::interpDelete {slave} { + + Log $slave "About to delete" NOTICE; + + # If the slave has a cleanup hook registered, call it. + # check the existance because we might be called to delete an interp + # which has not been registered with us at all + set hookname [DeleteHookName $slave]; + if {[Exists $hookname]} { + set hook [Set $hookname]; + if {![::tcl::Lempty $hook]} { + # remove the hook now, otherwise if the hook + # calls us somehow, we'll loop + Unset $hookname; + if {[catch {eval $hook $slave} err]} { + Log $slave "Delete hook error ($err)"; + } + } + } + + # Discard the global array of state associated with the slave, and + # delete the interpreter. + + set statename [InterpStateName $slave]; + if {[Exists $statename]} { + Unset $statename; + } + + # if we have been called twice, the interp might have been deleted + # already + if {[::interp exists $slave]} { + ::interp delete $slave; + Log $slave "Deleted" NOTICE; + } + + return + } + + # Set (or get) the loging mecanism + +proc ::safe::setLogCmd {args} { + variable Log; + if {[llength $args] == 0} { + return $Log; + } else { + if {[llength $args] == 1} { + set Log [lindex $args 0]; + } else { + set Log $args + } + } +} + + # internal variable + variable Log {} + + # ------------------- END OF PUBLIC METHODS ------------ + + + # + # sets the slave auto_path to the master recorded value. + # also sets tcl_library to the first token of the virtual path. + # + proc SyncAccessPath {slave} { + set slave_auto_path [Set [VirtualPathListName $slave]]; + ::interp eval $slave [list set auto_path $slave_auto_path]; + Log $slave \ + "auto_path in $slave has been set to $slave_auto_path"\ + NOTICE; + ::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]; + } + + # base name for storing all the slave states + # the array variable name for slave foo is thus "Sfoo" + # and for sub slave {foo bar} "Sfoo bar" (spaces are handled + # ok everywhere (or should)) + # We add the S prefix to avoid that a slave interp called "Log" + # would smash our "Log" variable. + proc InterpStateName {slave} { + return "S$slave"; + } + + # Check that the given slave is "one of us" + proc IsInterp {slave} { + expr { ([Exists [InterpStateName $slave]]) + && ([::interp exists $slave])} + } + + # returns the virtual token for directory number N + # if the slave argument is given, + # it will return the corresponding master global variable name + proc PathToken {n {slave ""}} { + if {[string compare "" $slave]} { + return "[InterpStateName $slave](access_path,$n)"; + } else { + # We need to have a ":" in the token string so + # [file join] on the mac won't turn it into a relative + # path. + return "p(:$n:)"; + } + } + # returns the variable name of the complete path list + proc PathListName {slave} { + return "[InterpStateName $slave](access_path)"; + } + # returns the variable name of the complete path list + proc VirtualPathListName {slave} { + return "[InterpStateName $slave](access_path_slave)"; + } + # returns the variable name of the number of items + proc PathNumberName {slave} { + return "[InterpStateName $slave](access_path,n)"; + } + # returns the staticsok flag var name + proc StaticsOkName {slave} { + return "[InterpStateName $slave](staticsok)"; + } + # returns the nestedok flag var name + proc NestedOkName {slave} { + return "[InterpStateName $slave](nestedok)"; + } + # Run some code at the namespace toplevel + proc Toplevel {args} { + namespace eval [namespace current] $args; + } + # set/get values + proc Set {args} { + eval Toplevel set $args; + } + # lappend on toplevel vars + proc Lappend {args} { + eval Toplevel lappend $args; + } + # unset a var/token (currently just an global level eval) + proc Unset {args} { + eval Toplevel unset $args; + } + # test existance + proc Exists {varname} { + Toplevel info exists $varname; + } + # short cut for access path getting + proc GetAccessPath {slave} { + Set [PathListName $slave] + } + # short cut for statics ok flag getting + proc StaticsOk {slave} { + Set [StaticsOkName $slave] + } + # short cut for getting the multiples interps sub loading ok flag + proc NestedOk {slave} { + Set [NestedOkName $slave] + } + # interp deletion storing hook name + proc DeleteHookName {slave} { + return [InterpStateName $slave](cleanupHook) + } + + # + # translate virtual path into real path + # + proc TranslatePath {slave path} { + # somehow strip the namespaces 'functionality' out (the danger + # is that we would strip valid macintosh "../" queries... : + if {[regexp {(::)|(\.\.)} $path]} { + error "invalid characters in path $path"; + } + set n [expr [Set [PathNumberName $slave]]-1]; + for {} {$n>=0} {incr n -1} { + # fill the token virtual names with their real value + set [PathToken $n] [Set [PathToken $n $slave]]; + } + # replaces the token by their value + subst -nobackslashes -nocommands $path; + } + + + # Log eventually log an error + # to enable error logging, set Log to {puts stderr} for instance + proc Log {slave msg {type ERROR}} { + variable Log; + if {[info exists Log] && [llength $Log]} { + eval $Log [list "$type for slave $slave : $msg"]; + } + } + + + # file name control (limit access to files/ressources that should be + # a valid tcl source file) + proc CheckFileName {slave file} { + # limit what can be sourced to .tcl + # and forbid files with more than 1 dot and + # longer than 14 chars + set ftail [file tail $file]; + if {[string length $ftail]>14} { + error "$ftail: filename too long"; + } + if {[regexp {\..*\.} $ftail]} { + error "$ftail: more than one dot is forbidden"; + } + if {[string compare $ftail "tclIndex"] && \ + [string compare [string tolower [file extension $ftail]]\ + ".tcl"]} { + error "$ftail: must be a *.tcl or tclIndex"; + } + + if {![file exists $file]} { + # don't tell the file path + error "no such file or directory"; + } + + if {![file readable $file]} { + # don't tell the file path + error "not readable"; + } + + } + + + # AliasSource is the target of the "source" alias in safe interpreters. + + proc AliasSource {slave args} { + + set argc [llength $args]; + # Allow only "source filename" + # (and not mac specific -rsrc for instance - see comment in ::init + # for current rationale) + if {$argc != 1} { + set msg "wrong # args: should be \"source fileName\"" + Log $slave "$msg ($args)"; + return -code error $msg; + } + set file [lindex $args 0] + + # get the real path from the virtual one. + if {[catch {set file [TranslatePath $slave $file]} msg]} { + Log $slave $msg; + return -code error "permission denied" + } + + # check that the path is in the access path of that slave + if {[catch {FileInAccessPath $slave $file} msg]} { + Log $slave $msg; + return -code error "permission denied" + } + + # do the checks on the filename : + if {[catch {CheckFileName $slave $file} msg]} { + Log $slave "$file:$msg"; + return -code error $msg; + } + + # passed all the tests , lets source it: + if {[catch {::interp invokehidden $slave source $file} msg]} { + Log $slave $msg; + return -code error "script error"; + } + return $msg + } + + # AliasLoad is the target of the "load" alias in safe interpreters. + + proc AliasLoad {slave file args} { + + set argc [llength $args]; + if {$argc > 2} { + set msg "load error: too many arguments"; + Log $slave "$msg ($argc) {$file $args}"; + return -code error $msg; + } + + # package name (can be empty if file is not). + set package [lindex $args 0]; + + # Determine where to load. load use a relative interp path + # and {} means self, so we can directly and safely use passed arg. + set target [lindex $args 1]; + if {[string length $target]} { + # we will try to load into a sub sub interp + # check that we want to authorize that. + if {![NestedOk $slave]} { + Log $slave "loading to a sub interp (nestedok)\ + disabled (trying to load $package to $target)"; + return -code error "permission denied (nested load)"; + } + + } + + # Determine what kind of load is requested + if {[string length $file] == 0} { + # static package loading + if {[string length $package] == 0} { + set msg "load error: empty filename and no package name"; + Log $slave $msg; + return -code error $msg; + } + if {![StaticsOk $slave]} { + Log $slave "static packages loading disabled\ + (trying to load $package to $target)"; + return -code error "permission denied (static package)"; + } + } else { + # file loading + + # get the real path from the virtual one. + if {[catch {set file [TranslatePath $slave $file]} msg]} { + Log $slave $msg; + return -code error "permission denied" + } + + # check the translated path + if {[catch {FileInAccessPath $slave $file} msg]} { + Log $slave $msg; + return -code error "permission denied (path)" + } + } + + if {[catch {::interp invokehidden\ + $slave load $file $package $target} msg]} { + Log $slave $msg; + return -code error $msg + } + + return $msg + } + + # FileInAccessPath raises an error if the file is not found in + # the list of directories contained in the (master side recorded) slave's + # access path. + + # the security here relies on "file dirname" answering the proper + # result.... needs checking ? + proc FileInAccessPath {slave file} { + + set access_path [GetAccessPath $slave]; + + if {[file isdirectory $file]} { + error "\"$file\": is a directory" + } + set parent [file dirname $file] + if {[lsearch -exact $access_path $parent] == -1} { + error "\"$file\": not in access_path"; + } + } + + # This procedure enables access from a safe interpreter to only a subset of + # the subcommands of a command: + + proc Subset {slave command okpat args} { + set subcommand [lindex $args 0] + if {[regexp $okpat $subcommand]} { + return [eval {$command $subcommand} [lrange $args 1 end]] + } + set msg "not allowed to invoke subcommand $subcommand of $command"; + Log $slave $msg; + error $msg; + } + + # This procedure installs an alias in a slave that invokes "safesubset" + # in the master to execute allowed subcommands. It precomputes the pattern + # of allowed subcommands; you can use wildcards in the pattern if you wish + # to allow subcommand abbreviation. + # + # Syntax is: AliasSubset slave alias target subcommand1 subcommand2... + + proc AliasSubset {slave alias target args} { + set pat ^(; set sep "" + foreach sub $args { + append pat $sep$sub + set sep | + } + append pat )\$ + ::interp alias $slave $alias {}\ + [namespace current]::Subset $slave $target $pat + } + +} diff --git a/library/tclIndex b/library/tclIndex new file mode 100644 index 0000000..e923ec9 --- /dev/null +++ b/library/tclIndex @@ -0,0 +1,30 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(auto_execok) [list source [file join $dir init.tcl]] +set auto_index(auto_reset) [list source [file join $dir init.tcl]] +set auto_index(auto_mkindex) [list source [file join $dir init.tcl]] +set auto_index(pkg_mkIndex) [list source [file join $dir init.tcl]] +set auto_index(tclPkgSetup) [list source [file join $dir init.tcl]] +set auto_index(tclMacPkgSearch) [list source [file join $dir init.tcl]] +set auto_index(tclPkgUnknown) [list source [file join $dir init.tcl]] +set auto_index(parray) [list source [file join $dir parray.tcl]] +set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]] +set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]] +set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]] +set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]] +set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]] +set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]] +set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]] +set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]] +set auto_index(history) [list source [file join $dir history.tcl]] diff --git a/library/word.tcl b/library/word.tcl new file mode 100644 index 0000000..64639f2 --- /dev/null +++ b/library/word.tcl @@ -0,0 +1,135 @@ +# word.tcl -- +# +# This file defines various procedures for computing word boundaries +# in strings. This file is primarily needed so Tk text and entry +# widgets behave properly for different platforms. +# +# Copyright (c) 1996 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) word.tcl 1.2 96/11/20 14:07:22 +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# The following variables are used to determine which characters are +# interpreted as white space. + +if {$tcl_platform(platform) == "windows"} { + # Windows style - any but space, tab, or newline + set tcl_wordchars "\[^ \t\n\]" + set tcl_nonwordchars "\[ \t\n\]" +} else { + # Motif style - any number, letter, or underscore + set tcl_wordchars {[a-zA-Z0-9_]} + set tcl_nonwordchars {[^a-zA-Z0-9_]} +} + +# tcl_wordBreakAfter -- +# +# This procedure returns the index of the first word boundary +# after the starting point in the given string, or -1 if there +# are no more boundaries in the given string. The index returned refers +# to the first character of the pair that comprises a boundary. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_wordBreakAfter {str start} { + global tcl_nonwordchars tcl_wordchars + set str [string range $str $start end] + if [regexp -indices "$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars" $str result] { + return [expr [lindex $result 1] + $start] + } + return -1 +} + +# tcl_wordBreakBefore -- +# +# This procedure returns the index of the first word boundary +# before the starting point in the given string, or -1 if there +# are no more boundaries in the given string. The index returned +# refers to the second character of the pair that comprises a boundary. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_wordBreakBefore {str start} { + global tcl_nonwordchars tcl_wordchars + if {[string compare $start end] == 0} { + set start [string length $str] + } + if [regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result] { + return [lindex $result 1] + } + return -1 +} + +# tcl_endOfWord -- +# +# This procedure returns the index of the first end-of-word location +# after a starting index in the given string. An end-of-word location +# is defined to be the first whitespace character following the first +# non-whitespace character after the starting point. Returns -1 if +# there are no more words after the starting point. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_endOfWord {str start} { + global tcl_nonwordchars tcl_wordchars + if [regexp -indices "$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars" \ + [string range $str $start end] result] { + return [expr [lindex $result 1] + $start] + } + return -1 +} + +# tcl_startOfNextWord -- +# +# This procedure returns the index of the first start-of-word location +# after a starting index in the given string. A start-of-word +# location is defined to be a non-whitespace character following a +# whitespace character. Returns -1 if there are no more start-of-word +# locations after the starting point. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_startOfNextWord {str start} { + global tcl_nonwordchars tcl_wordchars + if [regexp -indices "$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars" \ + [string range $str $start end] result] { + return [expr [lindex $result 1] + $start] + } + return -1 +} + +# tcl_startOfPreviousWord -- +# +# This procedure returns the index of the first start-of-word location +# before a starting index in the given string. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_startOfPreviousWord {str start} { + global tcl_nonwordchars tcl_wordchars + if {[string compare $start end] == 0} { + set start [string length $str] + } + if [regexp -indices \ + "$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \ + [string range $str 0 [expr $start - 1]] result word] { + return [lindex $word 0] + } + return -1 +} |