[26034] trunk/base
source_changes at macosforge.org
source_changes at macosforge.org
Sat Jun 9 15:05:24 PDT 2007
Revision: 26034
http://trac.macosforge.org/projects/macports/changeset/26034
Author: eridius at macports.org
Date: 2007-06-09 15:05:24 -0700 (Sat, 09 Jun 2007)
Log Message:
-----------
Add global methods lpop, lpush, lshift, lunshift, and ldelete. Expand implementation of try to match the specification in TIP #89. Add throw command. This is all documented in portfile.7
Modified Paths:
--------------
trunk/base/ChangeLog
trunk/base/doc/portfile.7
trunk/base/src/darwinports1.0/darwinports_util.tcl
Added Paths:
-----------
trunk/base/src/darwinports1.0/test_util.tcl
Modified: trunk/base/ChangeLog
===================================================================
--- trunk/base/ChangeLog 2007-06-09 20:54:46 UTC (rev 26033)
+++ trunk/base/ChangeLog 2007-06-09 22:05:24 UTC (rev 26034)
@@ -6,7 +6,15 @@
(unreleased)
- - Handles encodings properly now. All Portfiles and .conf files are assumed
+ - Add global methods lpush, lpop, lshift, and lunshift. Works similar to
+ lappend (in fact lpush is just lappend) and do what they sound like.
+ Also add ldindex. Works like lindex, but deletes the element from the list.
+ Documented in portfile.7 (eridius r26034).
+
+ - Add global methods try and throw. Implemented based on the specification
+ in TIP #89. Documented in portfile.7 (eridius r26034).
+
+ - Handle encodings properly now. All Portfiles and .conf files are assumed
to be utf-8, and reading them or calling portindex(1) should now work
the same on all locales (ticket #11978, eridius r25975).
Modified: trunk/base/doc/portfile.7
===================================================================
--- trunk/base/doc/portfile.7 2007-06-09 20:54:46 UTC (rev 26033)
+++ trunk/base/doc/portfile.7 2007-06-09 22:05:24 UTC (rev 26034)
@@ -1694,6 +1694,131 @@
using
.Cm sudo
with the provided password.
+.It Xo
+.Ic lpush
+.Ar varName
+.Op Ar value \&...
+.Xc
+Treats the variable given by
+.Ar varName
+as a list and appends each of the
+.Ar value
+arguments to that list as a separate element. If
+.Ar varName
+doesn't exist, it is created as a list with elements
+given by the
+.Ar value
+arguments.
+Really just an alias for
+.Xr lappend n .
+.It Ic lpop Ar varName
+Removes the last element from the list given by
+.Ar varName
+and returns it. If there are no elements in the list,
+the empty string is returned. If
+.Ar varName
+doesn't exist, an exception is raised.
+.It Xo
+.Ic lunshift
+.Ar varName
+.Op Ar value \&...
+.Xc
+Treats the variable given by
+.Ar varName
+as a list and prepends each of the
+.Ar value
+arguments to that list as a separate element. If
+.Ar varName
+doesn't exist, it is created as a list with elements
+given by the
+.Ar value
+arguments.
+.It Ic lshift Ar varName
+Removes the first element from the list given by
+.Ar varName
+and returns it. If there are no elements in the list,
+the empty string is returned. If
+.Ar varName
+doesn't exist, an exception is raised.
+.It Xo
+.Ic ldindex
+.Ar varName
+.Op Ar index \&...
+.Xc
+Treats the variable given by
+.Ar varName
+as a list and removes the element pointed to by the sequence of
+.Ar index
+arguments and returns it. If no
+.Ar index
+arguments are provided,
+.Ar varName
+is set to the empty string and the entire former value is returned.
+Has the same usage semantics as
+.Xr lindex n .
+.It Xo
+.Ic try
+.Ar body
+.Oo
+.Nm catch Nm {
+.Ar type-list
+.Op Ar ecvar
+.Op Ar msgvar
+.Op Ar infovar
+.Nm }
+.Ar body Ar \&...
+.Oc
+.Op Nm finally Ar body
+.Xc
+Implements a try-catch-finally block as defined in TIP #89.
+.br
+.Sy Example:
+Basic try-finally construct.
+.Bd -literal -offset indent -compact
+try {
+ set fd [open $file r]
+ # do stuff here
+} finally {
+ close $fd
+}
+.Ed
+.Sy Example:
+Basic try-catch construct
+.Bd -literal -offset indent -compact
+try {
+ set result [expr $num / $div]
+} catch {{ARITH DIVZERO}} {
+ set result -1
+}
+.Ed
+.Sy Example:
+Basic try with multiple catches construct
+.Bd -literal -offset indent -compact
+try {
+ set fd [open $file r]
+ # do stuff here
+} catch {{POSIX ENOENT} {} msgvar} {
+ puts stderr $msgvar
+} catch {*} {
+ puts stderr "An error occurred while processing the file"
+ close $fd
+ throw
+}
+.Ed
+.It Xo
+.Ic throw
+.Op Ar type
+.Op Ar message
+.Op Ar info
+.Xc
+Throws an exception. If given arguments, works just like
+.Ic error
+.Ar message
+.Ar info
+.Ar type .
+If called with no arguments from within a
+.Ic catch
+block, re-throws the caught exception.
.El
.Pp
.Bl -tag -width lc -compact
Modified: trunk/base/src/darwinports1.0/darwinports_util.tcl
===================================================================
--- trunk/base/src/darwinports1.0/darwinports_util.tcl 2007-06-09 20:54:46 UTC (rev 26033)
+++ trunk/base/src/darwinports1.0/darwinports_util.tcl 2007-06-09 22:05:24 UTC (rev 26034)
@@ -33,18 +33,301 @@
# Provide some global utilities
-# try-finally block
-# Usage: try { script1 } finally { script2 }
-proc try {script1 finally script2} {
- if {$finally ne "finally"} {
- error "Usage: try { script1 } finally { script2 }"
+namespace eval darwinports_util {
+ ###################
+ # Private methods #
+ ###################
+ proc method_wrap {name} {
+ variable argdefault
+
+ set name [list $name]
+ # reconstruct the args list
+ set args [uplevel 1 [subst -nocommands {info args $name}]]
+ set arglist {}
+ foreach arg $args {
+ set argname [list $arg]
+ if {[uplevel 1 [subst -nocommands {info default $name $argname argdefault}]]} {
+ lappend arglist [list $arg $argdefault]
+ } else {
+ lappend arglist $arg
+ }
+ }
+ # modify the proc
+ set arglist [list $arglist]
+ set body [uplevel 1 [subst -nocommands {info body $name}]]
+ uplevel 1 [subst -nocommands {
+ proc $name $arglist {
+ if {[set err [catch {$body} result]] && [set err] != 2} {
+ if {[set err] == 1} {
+ return -code [set err] -errorcode [set ::errorCode] [set result]
+ } else {
+ return -code [set err] [set result]
+ }
+ } else {
+ return [set result]
+ }
+ }
+ }]
}
- if {[set fail [catch {uplevel $script1} result]]} {
- set savedInfo $::errorInfo
- set savedCode $::errorCode
+}
+
+###################
+# List management #
+###################
+# It would be nice to have these written in C
+# That way we could avoid duplicating lists if they're not shared
+# but oh well
+
+# ldindex varName ?index...?
+# Removes the index'th list element from varName and returns it
+# If multiple indexes are provided, each one is a subindex into the
+# list element specified by the previous index
+# If no indexes are provided, deletes the entire list and returns it
+# If varName does not exists an exception is raised
+proc ldindex {varName args} {
+ set varName [list $varName]
+ if {[llength $args] > 0} {
+ set idx [lindex $args 0]
+ set size [uplevel 1 [subst -nocommands {llength [set $varName]}]]
+ set badrange? 0
+ if {[string is integer -strict $idx]} {
+ if {$idx < 0 || $idx >= $size} {
+ set badrange? 1
+ }
+ } elseif {$idx eq "end"} {
+ if {$size == 0} {
+ set badrange? 1
+ }
+ } elseif {[string match end-* $idx] && [string is integer -strict [string range $idx 4 end]]} {
+ set i [expr $size - 1 - [string range $idx 4 end]]
+ if {$i < 0 || $i >= $size} {
+ set badrange? 1
+ }
+ } else {
+ error "bad index \"$idx\": must be integer or end?-integer?"
+ }
+ if {${badrange?}} {
+ error "list index out of range"
+ }
+
+ if {[llength $args] > 1} {
+ set list [uplevel 1 [subst -nocommands {lindex [set $varName] $idx}]]
+ set item [eval ldindex list [lrange $args 1 end]]
+ uplevel 1 [subst {lset $varName $idx [list $list]}]
+ } else {
+ set item [uplevel 1 [subst -nocommands {lindex [set $varName] $idx}]]
+ uplevel 1 [subst -nocommands {set $varName [lreplace [set $varName] $idx $idx]}]
+ }
+ } else {
+ set item [uplevel 1 [subst {set $varName}]]
+ uplevel 1 [subst {set $varName {}}]
}
- uplevel $script2
- if {$fail} {
- return -code $fail -errorinfo $savedInfo -errorcode $savedCode $result
+ return $item
+}
+darwinports_util::method_wrap ldindex
+
+# lpop varName
+# Removes the last list element from a variable
+# If varName is an empty list an empty string is returned
+proc lpop {varName} {
+ set varName [list $varName]
+ set size [uplevel 1 [subst -nocommands {llength [set $varName]}]]
+ if {$size != 0} {
+ uplevel 1 [subst -nocommands {ldindex $varName end}]
}
}
+darwinports_util::method_wrap lpop
+
+# lpush varName ?value ...?
+# Appends list elements onto a variable
+# If varName does not exist then it is created
+# really just an alias for lappend
+proc lpush {varName args} {
+ set varName [list $varName]
+ uplevel 1 [subst -nocommands {lappend $varName $args}]
+}
+darwinports_util::method_wrap lpush
+
+# lshift varName
+# Removes the first list element from a variable
+# If varName is an empty list an empty string is returned
+proc lshift {varName} {
+ set varName [list $varName]
+ set size [uplevel 1 [subst -nocommands {llength [set $varName]}]]
+ if {$size != 0} {
+ uplevel 1 [subst -nocommands {ldindex $varName 0}]
+ }
+}
+darwinports_util::method_wrap lshift
+
+# lunshift varName ?value ...?
+# Prepends list elements onto a variable
+# If varName does not exist then it is created
+proc lunshift {varName args} {
+ set varName [list $varName]
+ uplevel 1 [subst -nocommands {
+ if {![info exists $varName]} {
+ set $varName {}
+ }
+ }]
+ set value [concat $args [uplevel 1 set $varName]]
+ uplevel 1 set $varName [list $value]
+}
+darwinports_util::method_wrap lunshift
+
+################################
+# try/catch exception handling #
+################################
+# modelled after TIP #89 <http://www.tcl.tk/cgi-bin/tct/tip/89>
+
+if {![namespace exists ::_trycatch]} {
+ namespace eval ::_trycatch {
+ variable catchStack {}
+ }
+}
+
+# throw ?type? ?message? ?info?
+# Works like error, but arguments are reordered to encourage use of types
+# If called with no arguments in a catch block, re-throws the caught exception
+proc throw {args} {
+ if {[llength $args] == 0} {
+ # re-throw
+ if {[llength $::_trycatch::catchStack] == 0} {
+ return -code error "error: throw with no parameters outside of a catch"
+ } else {
+ set errorNode [lpop ::_trycatch::catchStack]
+ set errCode [lindex $errorNode 0]
+ set errMsg [lindex $errorNode 1]
+ set errInfo [lindex $errorNode 2]
+ return -code error -errorinfo $errInfo -errorcode $errCode $errMsg
+ }
+ } elseif {[llength $args] > 3} {
+ return -code error "wrong # args: should be \"throw ?type? ?message? ?info?\""
+ } else {
+ set errCode [lindex $args 0]
+ if {[llength $args] > 1} {
+ set errMsg [lindex $args 1]
+ } else {
+ set errMsg "error: $errCode"
+ }
+ if {[llength $args] > 2} {
+ set errInfo [lindex $args 2]
+ } else {
+ set errInfo $errMsg
+ }
+ return -code error -errorinfo $errInfo -errorcode $errCode $errMsg
+ }
+}
+
+# try body ?catch {type_list ?ecvar? ?msgvar? ?infovar?} body ...? ?finally body?
+# implementation of try as specified in TIP #89
+proc try {args} {
+ # validate and interpret the arguments
+ set catchList {}
+ if {[llength $args] == 0} {
+ return -code error "wrong # args: \
+ should be \"try body ?catch {type-list ?ecvar? ?msgvar? ?infovar?} body ...? ?finally body?\""
+ }
+ set body [lshift args]
+ while {[llength $args] > 0} {
+ set arg [lshift args]
+ switch $arg {
+ catch {
+ set elem [lshift args]
+ if {[llength $args] == 0 || [llength $elem] > 4} {
+ return -code error "invalid syntax in catch clause: \
+ should be \"catch {type-list ?ecvar? ?msgvar? ?infovar?} body\""
+ } elseif {[llength [lindex $elem 0 0]] == 0} {
+ return -code error "invalid syntax in catch clause: type-list must contain at least one type"
+ }
+ lpush catchList $elem [lshift args]
+ }
+ finally {
+ if {[llength $args] == 0} {
+ return -code error "invalid syntax in finally clause: should be \"finally body\""
+ } elseif {[llength $args] > 1} {
+ return -code error "trailing args after finally clause"
+ }
+ set finallyBody [lshift args]
+ }
+ default {
+ return -code error "invalid syntax: \
+ should be \"try body ?catch {type-list ?ecvar? ?msgvar? ?infovar?} body ...? ?finally body?\""
+ }
+ }
+ }
+
+ # at this point, we've processed all args
+ if {[set err [catch {uplevel 1 $body} result]] == 1} {
+ set savedErrorCode $::errorCode
+ set savedErrorInfo $::errorInfo
+ # rip out the last "invoked from within" - we want to hide our internals
+ set savedErrorInfo [regsub -linestop {(\n \(.*\))?\n invoked from within\n"uplevel 1 \$body"\Z} \
+ $savedErrorInfo ""]
+ # add to the throw stack
+ lpush ::_trycatch::catchStack [list $savedErrorCode $result $savedErrorInfo]
+ # call the first matching catch block
+ foreach {elem catchBody} $catchList {
+ set typeList [lshift elem]
+ set match? 1
+ set typeList [lrange $typeList 0 [expr [llength $savedErrorCode] - 1]]
+ set codeList [lrange $savedErrorCode 0 [expr [llength $typeList] - 1]]
+ foreach type $typeList code $codeList {
+ if {![string match $type $code]} {
+ set match? 0
+ break
+ }
+ }
+ if {${match?}} {
+ # found a block
+ if {[set ecvar [lshift elem]] ne ""} {
+ uplevel 1 set [list $ecvar] [list $savedErrorCode]
+ }
+ if {[set msgvar [lshift elem]] ne ""} {
+ uplevel 1 set [list $msgvar] [list $result]
+ }
+ if {[set infovar [lshift elem]] ne ""} {
+ uplevel 1 set [list $infovar] [list $savedErrorInfo]
+ }
+ if {[set err [catch {uplevel 1 $catchBody} result]] == 1} {
+ # error in the catch block, save it
+ set savedErrorCode $::errorCode
+ set savedErrorInfo $::errorInfo
+ # rip out the last "invoked from within" - we want to hide our internals
+ set savedErrorInfo [regsub -linestop \
+ {(\n \(.*\))?\n invoked from within\n"uplevel 1 \$catchBody"\Z} \
+ $savedErrorInfo ""]
+ # also rip out an "invoked from within" for throw
+ set savedErrorInfo [regsub -linestop \
+ {\n invoked from within\n"throw"\Z} $savedErrorInfo ""]
+ }
+ break
+ }
+ }
+ # remove from the throw stack
+ lpop ::_trycatch::catchStack
+ }
+ # execute finally block
+ if {[info exists finallyBody]} {
+ # catch errors here so we can strip our uplevel
+ set savedErr $err
+ set savedResult $result
+ if {[set err [catch {uplevel 1 $finallyBody} result]] == 1} {
+ set savedErrorCode $::errorCode
+ set savedErrorInfo $::errorInfo
+ # rip out the last "invoked from within" - we want to hide our internals
+ set savedErrorInfo [regsub -linestop \
+ {(\n \(.*\))?\n invoked from within\n"uplevel 1 \$finallyBody"\Z} \
+ $savedErrorInfo ""]
+ } elseif {$err == 0} {
+ set err $savedErr
+ set result $savedResult
+ }
+ }
+ # aaaand return
+ if {$err == 1} {
+ return -code $err -errorinfo $savedErrorInfo -errorcode $savedErrorCode $result
+ } else {
+ return -code $err $result
+ }
+}
Added: trunk/base/src/darwinports1.0/test_util.tcl
===================================================================
--- trunk/base/src/darwinports1.0/test_util.tcl (rev 0)
+++ trunk/base/src/darwinports1.0/test_util.tcl 2007-06-09 22:05:24 UTC (rev 26034)
@@ -0,0 +1,468 @@
+# test_util.tcl
+# $Id$
+#
+# Comprehensive test file for darwinports_util.tcl
+# Written by Kevin Ballard <eridius at macports.org>
+
+source ./darwinports_util.tcl
+
+array set options {t 0 w 0}
+
+set ::traceNest ""
+set ::traceSquelch 0
+set ::traceSquelchNest ""
+proc dotrace {args} {
+ global traceNest options
+ flush stdout
+ set command [lindex $args 0]
+ if {$options(w) > 0} {
+ # trim command to 1 line
+ if {[llength [set lines [split $command "\n"]]] > 1} {
+ set command "[lindex $lines 0] [ansi fg-blue]...[ansi reset]"
+ }
+ }
+ set op [lindex $args end]
+ switch $op {
+ enter { append traceNest "#" }
+ enterstep { append traceNest "+" }
+ }
+ switch $op {
+ enter {
+ puts stderr "[ansi fg-yellow inverse]$traceNest>[ansi reset] $command"
+ set ::traceSquelch 0
+ }
+ enterstep {
+ if {!$::traceSquelch} {
+ puts stderr "[ansi fg-yellow]$traceNest>[ansi reset] $command"
+ if {[llength [info procs [lindex [split $command] 0]]] > 0} {
+ # it's a proc, lets start squelching
+ set ::traceSquelch 1
+ set ::traceSquelchNest $::traceNest
+ }
+ }
+ }
+ leave -
+ leavestep {
+ if {$op eq "leavestep" && $::traceSquelch && $::traceNest eq $::traceSquelchNest} {
+ set ::traceSquelch 0
+ }
+ if {$op eq "leave" || !$::traceSquelch} {
+ set code [lindex $args 1]
+ set result [lindex $args 2]
+ if {$options(w) > 0} {
+ # trim result just like command
+ if {[llength [set lines [split $result "\n"]]] > 1} {
+ set result "[lindex $lines 0] [ansi fg-blue]...[ansi reset]"
+ }
+ }
+ if {$op eq "leave"} {
+ set prefix "[ansi fg-blue inverse]$traceNest"
+ } else {
+ set prefix "[ansi fg-blue]$traceNest"
+ }
+ if {$code != 0} {
+ puts stderr "$prefix =\[$code\]>[ansi reset] $result"
+ } else {
+ puts stderr "$prefix =>[ansi reset] $result"
+ }
+ }
+ }
+ }
+ switch $op {
+ leave -
+ leavestep {
+ set traceNest [string range $traceNest 0 end-1]
+ }
+ }
+}
+while {[llength $argv] > 0} {
+ set arg [lshift argv]
+ if {$arg eq "--"} {
+ break
+ } elseif {[string match -* $arg]} {
+ set arg [string range $arg 1 end]
+ while {[string length $arg] > 0} {
+ set opt [string index $arg 0]
+ set arg [string range $arg 1 end]
+ switch $opt {
+ t { incr options(t) }
+ w { incr options(w) }
+ default {
+ error "Unknown option: -$opt"
+ }
+ }
+ }
+ } else {
+ lunshift argv $arg
+ break
+ }
+}
+if {$options(t) > 0} {
+ set ops {enter leave}
+ if {$options(t) > 1} {
+ lappend ops enterstep leavestep
+ }
+ if {[llength $argv] > 0} {
+ set list $argv
+ if {[set idx [lsearch -exact $list *]] != -1} {
+ set list [eval lreplace [list $list] $idx $idx [namespace eval darwinports_util { namespace export }]]
+ }
+ } else {
+ set list [namespace eval darwinports_util { namespace export }]
+ }
+ foreach arg $list {
+ trace add execution $arg $ops dotrace
+ }
+}
+
+proc init {name value} {
+ set name [list $name]
+ set value [list $value]
+ uplevel 1 [subst -nocommands {
+ set $name $value
+ set $name-bak [set $name]
+ }]
+}
+
+proc restore {name} {
+ set name [list $name]
+ uplevel 1 [subst -nocommands {
+ if {[info exists $name-bak]} {
+ set $name [set $name-bak]
+ } else {
+ unset $name
+ }
+ }]
+}
+
+array set kStateToAnsiTable {
+ error fg-magenta
+ expected fg-cyan
+ correct fg-green
+ wrong fg-red
+}
+
+array set kAnsiTable {
+ reset 0
+
+ bold 1
+ dim 2
+ underline 4
+ blink 5
+ inverse 7
+ hidden 8
+
+ fg-black 30
+ fg-red 31
+ fg-green 32
+ fg-yellow 33
+ fg-blue 34
+ fg-magenta 35
+ fg-cyan 36
+ fg-white 37
+ fg-default 39
+
+ bg-black 40
+ bg-red 41
+ bg-green 42
+ bg-yellow 43
+ bg-blue 44
+ bg-magenta 45
+ bg-cyan 46
+ bg-white 47
+ bg-default 49
+}
+
+proc ansi {args} {
+ global kAnsiTable
+ if {[llength $args] == 0} {
+ error "wrong # args: should be \"ansi code ...\""
+ }
+ set colors {}
+ foreach code $args {
+ lappend colors $kAnsiTable($code)
+ }
+ return "\033\[[join $colors ";"]m"
+}
+
+proc state {code} {
+ global kStateToAnsiTable
+ return [ansi $kStateToAnsiTable($code)]
+}
+
+proc line {cmd expected args} {
+ uplevel 1 [list block $cmd $cmd $expected] $args
+}
+
+proc block {name cmd expected args} {
+ if {[set err [catch {uplevel 1 $cmd} value]]} {
+ set savedErrorInfo $::errorInfo
+ set savedErrorCode $::errorCode
+ if {$expected eq "-error" && $err == 1} {
+ if {[llength $args] > 0} {
+ set errCode [lindex $args 0]
+ if {$errCode == $savedErrorCode} {
+ if {[llength $args] > 1} {
+ set errMsg [lindex $args 1]
+ if {$errMsg == $value} {
+ set code expected
+ } else {
+ set code error
+ }
+ } else {
+ set code expected
+ }
+ } else {
+ set code error
+ }
+ } else {
+ set code expected
+ }
+ } elseif {$expected eq "-return" && $err == 2} {
+ if {[llength $args] > 0} {
+ set errMsg [lindex $args 0]
+ if {$errMsg == $value} {
+ set code expected
+ } else {
+ set code error
+ }
+ } else {
+ set code expected
+ }
+ } elseif {$expected eq "-break" && $err == 3} {
+ set code expected
+ } else {
+ set code error
+ }
+ } elseif {$value == $expected} {
+ set code correct
+ } else {
+ set code wrong
+ }
+ if {$code eq "error"} {
+ append value "\n$savedErrorInfo"
+ }
+ puts "[state $code]$name =[if {$err != 0} {format \[$err\]}]> $value[ansi reset]"
+}
+
+proc var {name expected} {
+ set exists [uplevel 1 info exists [list $name]]
+ if {!$exists} {
+ set value "does not exist"
+ if {$expected eq "-unset"} {
+ set code expected
+ } else {
+ set code error
+ }
+ } else {
+ set value [uplevel 1 set [list $name]]
+ if {$value == $expected} {
+ set code correct
+ } else {
+ set code wrong
+ }
+ }
+ puts "[state $code]$name: $value[ansi reset]"
+}
+
+if {[set err [catch {
+ namespace eval test {
+ namespace eval vars {}
+ init vars::ary(one) {1 2 {3 4}}
+ init vars::ary(zero) {1 {2 3 {"4 5" 6} 7} 8 9}
+
+ var vars::ary(zero) {1 {2 3 {"4 5" 6} 7} 8 9}
+ line {ldindex vars::ary(zero) 1 2 0} {4 5}
+ var vars::ary(zero) {1 {2 3 6 7} 8 9}
+ line {ldindex vars::ary(zero) 1 1 0} 3
+ var vars::ary(zero) {1 {2 {} 6 7} 8 9}
+ line {ldindex vars::ary(zero) 1 2} 6
+ var vars::ary(zero) {1 {2 {} 7} 8 9}
+ line {ldindex vars::ary(zero) 1} {2 {} 7}
+ var vars::ary(zero) {1 8 9}
+ line {ldindex vars::ary(zero)} {1 8 9}
+ var vars::ary(zero) {}
+
+ var vars::ary(one) {1 2 {3 4}}
+ line {lpop vars::ary(one)} {3 4}
+ var vars::ary(one) {1 2}
+ line {lpop vars::ary(one)} 2
+ var vars::ary(one) 1
+ line {lpop vars::ary(one)} 1
+ var vars::ary(one) {}
+ line {lpop vars::ary(one)} {}
+ var vars::ary(one) {}
+
+ line {lpop vars::foo} -error NONE {can't read "vars::foo": no such variable}
+
+ restore vars::ary(one)
+ var vars::ary(one) {1 2 {3 4}}
+ line {lshift vars::ary(one)} 1
+ var vars::ary(one) {2 {3 4}}
+ line {lshift vars::ary(one)} 2
+ var vars::ary(one) {{3 4}}
+ line {lshift vars::ary(one)} {3 4}
+ var vars::ary(one) {}
+ line {lshift vars::ary(one)} {}
+ var vars::ary(one) {}
+
+ line {lshift vars::foo} -error NONE {can't read "vars::foo": no such variable}
+
+ var vars::ary(two) -unset
+ line {lpush vars::ary(two) 1} 1
+ var vars::ary(two) 1
+ line {lpush vars::ary(two) 2 3 4 5} {1 2 3 4 5}
+ var vars::ary(two) {1 2 3 4 5}
+ line {lpush vars::ary(two) "this is a test"} {1 2 3 4 5 {this is a test}}
+ var vars::ary(two) {1 2 3 4 5 {this is a test}}
+ line {lpop vars::ary(two)} {this is a test}
+ var vars::ary(two) {1 2 3 4 5}
+
+ line {lpush "foo bar" 3} {3}
+ var {foo bar} 3
+
+ restore vars::ary(two)
+ var vars::ary(two) -unset
+ line {lunshift vars::ary(two) 5} 5
+ var vars::ary(two) 5
+ line {lunshift vars::ary(two) 4} {4 5}
+ var vars::ary(two) {4 5}
+ line {lunshift vars::ary(two) 1 2 3} {1 2 3 4 5}
+ var vars::ary(two) {1 2 3 4 5}
+ line {lunshift vars::ary(two) "this is a test"} {{this is a test} 1 2 3 4 5}
+ var vars::ary(two) {{this is a test} 1 2 3 4 5}
+ line {lshift vars::ary(two)} {this is a test}
+ var vars::ary(two) {1 2 3 4 5}
+
+ # now test the try/throw stuff
+ line {throw} -error NONE {error: throw with no parameters outside of a catch}
+ line {throw 1 2 3 4} -error NONE {wrong # args: should be "throw ?type? ?message? ?info?"}
+ line {try {format 3} catch {} {}} -error NONE {invalid syntax in catch clause: type-list must contain at least one type}
+ line {try {format 3} finally {format 4} test} -error NONE {trailing args after finally clause}
+ block {basic try} {
+ try {
+ error "random error"
+ }
+ } -error NONE "random error"
+ block {try-finally} {
+ try {
+ error "try-finally error"
+ } finally {
+ set myVar "finally clause worked"
+ }
+ } -error NONE "try-finally error"
+ var myVar "finally clause worked"
+ block {try-finally-error} {
+ try {
+ error "try-finally error"
+ } finally {
+ error "finally error"
+ }
+ } -error NONE "finally error"
+ block {try-catch} {
+ try {
+ error "try-catch error"
+ } catch NONE {
+ format "catch clause worked"
+ }
+ } "catch clause worked"
+ block {try-catch-throw} {
+ try {
+ error "try-catch error"
+ } catch NONE {
+ set myVar "thrown"
+ throw
+ }
+ } -error NONE "try-catch error" ;# really should test errorInfo but that's messy
+ var myVar "thrown"
+ unset myVar
+ block {try-catch-finally} {
+ try {
+ error "try-catch-finally error"
+ } catch NONE {
+ set myVar "thrown"
+ throw
+ } finally {
+ lappend myVar "finally"
+ }
+ } -error NONE "try-catch-finally error"
+ var myVar "thrown finally"
+ block {try-catch-all} {
+ try {
+ error "this is a test"
+ } catch * {
+ format "catch-all worked"
+ }
+ } "catch-all worked"
+ block {try-catch-return} {
+ try {
+ error "this is a test"
+ } catch * {
+ return "catch-return worked"
+ }
+ } -return "catch-return worked"
+ block {try-catch-break} {
+ try {
+ error "this is a test"
+ } catch * {
+ break
+ }
+ } -break
+ block {try-catch-multiple} {
+ try {
+ error "this is a test"
+ } catch POSIX {
+ error "POSIX catch"
+ } catch * {
+ format "catch-all"
+ }
+ } "catch-all"
+ unset myVar
+ block {try-catch-multiple-finally} {
+ try {
+ error "this is a test"
+ } catch * {
+ lappend myVar "catch-all 1"
+ } catch * {
+ lappend myVar "catch-all 2"
+ } finally {
+ lappend myVar "finally"
+ }
+ } [list {catch-all 1}]
+ var myVar [list "catch-all 1" "finally"]
+ block {try-catch-types} {
+ try {
+ error "try-catch-types error" {} {MYERR arg1 arg2}
+ } catch POSIX {
+ error "POSIX catch"
+ } catch {{MY* arg*} code} {
+ format "caught code $code"
+ }
+ } "caught code MYERR arg1 arg2"
+ block {try-catch-vars} {
+ try {
+ error "random error"
+ } catch {* code msg info} {
+ set list {}
+ if {$code eq "NONE"} {
+ lappend list "code: correct"
+ }
+ if {$msg eq "random error"} {
+ lappend list "msg: correct"
+ }
+ if {[string match "random error\n*" $info]} {
+ lappend list "info: probably correct"
+ }
+ join $list ", "
+ }
+ } "code: correct, msg: correct, info: probably correct"
+
+ # ensure the stack is sound
+ var ::_trycatch::catchStack {}
+ }
+} result]]} {
+ puts ""
+ puts "error: $result"
+ puts "code: $err"
+ puts $::errorInfo
+}
Property changes on: trunk/base/src/darwinports1.0/test_util.tcl
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://lists.macosforge.org/pipermail/macports-changes/attachments/20070609/05257361/attachment.html
More information about the macports-changes
mailing list