[26059] branches/dp2mp-move/base/src
source_changes at macosforge.org
source_changes at macosforge.org
Sun Jun 10 23:30:00 PDT 2007
Revision: 26059
http://trac.macosforge.org/projects/macports/changeset/26059
Author: jmpp at macports.org
Date: 2007-06-10 23:30:00 -0700 (Sun, 10 Jun 2007)
Log Message:
-----------
Manually merging Eridius' r25979.
Modified Paths:
--------------
branches/dp2mp-move/base/src/macports1.0/Makefile
branches/dp2mp-move/base/src/macports1.0/macports.tcl
branches/dp2mp-move/base/src/port1.0/portutil.tcl
branches/dp2mp-move/base/src/port1.0/tests/portutil.tcl
Added Paths:
-----------
branches/dp2mp-move/base/src/macports1.0/macports_util.tcl
Modified: branches/dp2mp-move/base/src/macports1.0/Makefile
===================================================================
--- branches/dp2mp-move/base/src/macports1.0/Makefile 2007-06-11 06:18:21 UTC (rev 26058)
+++ branches/dp2mp-move/base/src/macports1.0/Makefile 2007-06-11 06:30:00 UTC (rev 26059)
@@ -1,5 +1,5 @@
-SRCS= macports.tcl macports_dlist.tcl macports_autoconf.tcl \
- macports_index.tcl macports_fastload.tcl
+SRCS= macports.tcl macports_dlist.tcl macports_util.tcl \
+ macports_autoconf.tcl macports_index.tcl macports_fastload.tcl
OBJS= macports.o portconf.o session.o util.o
SHLIB_NAME= MacPorts${SHLIB_SUFFIX}
Modified: branches/dp2mp-move/base/src/macports1.0/macports.tcl
===================================================================
--- branches/dp2mp-move/base/src/macports1.0/macports.tcl 2007-06-11 06:18:21 UTC (rev 26058)
+++ branches/dp2mp-move/base/src/macports1.0/macports.tcl 2007-06-11 06:30:00 UTC (rev 26059)
@@ -34,6 +34,7 @@
package provide macports 1.0
package require macports_dlist 1.0
package require macports_index 1.0
+package require macports_util 1.0
namespace eval macports {
namespace export bootstrap_options user_options portinterp_options open_mports ui_priorities
Added: branches/dp2mp-move/base/src/macports1.0/macports_util.tcl
===================================================================
--- branches/dp2mp-move/base/src/macports1.0/macports_util.tcl (rev 0)
+++ branches/dp2mp-move/base/src/macports1.0/macports_util.tcl 2007-06-11 06:30:00 UTC (rev 26059)
@@ -0,0 +1,333 @@
+# macports.tcl
+# $Id$
+#
+# Copyright (c) 2007 Kevin Ballard <eridius at macports.org>
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+
+package provide macports_util 1.0
+
+# Provide some global utilities
+
+namespace eval macports_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]
+ }
+ }
+ }]
+ }
+}
+
+###################
+# 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 {}}]
+ }
+ return $item
+}
+macports_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}]
+ }
+}
+macports_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}]
+}
+macports_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}]
+ }
+}
+macports_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]
+}
+macports_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
+ }
+}
Property changes on: branches/dp2mp-move/base/src/macports1.0/macports_util.tcl
___________________________________________________________________
Name: svn:keywords
+ Id
Name: svn:eol-style
+ native
Modified: branches/dp2mp-move/base/src/port1.0/portutil.tcl
===================================================================
--- branches/dp2mp-move/base/src/port1.0/portutil.tcl 2007-06-11 06:18:21 UTC (rev 26058)
+++ branches/dp2mp-move/base/src/port1.0/portutil.tcl 2007-06-11 06:30:00 UTC (rev 26059)
@@ -35,6 +35,7 @@
package provide portutil 1.0
package require Pextlib 1.0
package require macports_dlist 1.0
+package require macports_util 1.0
package require msgcat
package require porttrace 1.0
Modified: branches/dp2mp-move/base/src/port1.0/tests/portutil.tcl
===================================================================
--- branches/dp2mp-move/base/src/port1.0/tests/portutil.tcl 2007-06-11 06:18:21 UTC (rev 26058)
+++ branches/dp2mp-move/base/src/port1.0/tests/portutil.tcl 2007-06-11 06:30:00 UTC (rev 26059)
@@ -206,22 +206,6 @@
}
}
-# try-finally block
-# Usage: try { script1 } finally { script2 }
-proc try {script1 finally script2} {
- if {$finally ne "finally"} {
- error "Usage: try { script1 } finally { script2 }"
- }
- if {[set fail [catch {uplevel $script1} result]]} {
- set savedInfo $::errorInfo
- set savedCode $::errorCode
- }
- uplevel $script2
- if {$fail} {
- return -code $fail -errorinfo $savedInfo -errorcode $savedCode $result
- }
-}
-
# run all tests
foreach proc [info procs test_*] {
$proc
-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://lists.macosforge.org/pipermail/macports-changes/attachments/20070610/db98e580/attachment.html
More information about the macports-changes
mailing list