source: trunk/base/src/macports1.0/macports_util.tcl @ 134837

Last change on this file since 134837 was 134837, checked in by jmr@…, 5 years ago

replace eval with {*} in the last few applicable places

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 12.7 KB
Line 
1# macports.tcl
2# $Id: macports_util.tcl 134837 2015-04-08 14:51:23Z jmr@macports.org $
3#
4# Copyright (c) 2007 Kevin Ballard <eridius@macports.org>
5# All rights reserved.
6#
7# Redistribution and use in source and binary forms, with or without
8# modification, are permitted provided that the following conditions
9# are met:
10# 1. Redistributions of source code must retain the above copyright
11#    notice, this list of conditions and the following disclaimer.
12# 2. Redistributions in binary form must reproduce the above copyright
13#    notice, this list of conditions and the following disclaimer in the
14#    documentation and/or other materials provided with the distribution.
15# 3. Neither the name of The MacPorts Project nor the names of its contributors
16#    may be used to endorse or promote products derived from this software
17#    without specific prior written permission.
18#
19# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
20# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
21# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
23# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
24# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
25# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
27# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
28# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
29# POSSIBILITY OF SUCH DAMAGE.
30#
31
32package provide macports_util 1.0
33
34# Provide some global utilities
35
36namespace eval macports_util {
37    ###################
38    # Private methods #
39    ###################
40    proc method_wrap {name} {
41        variable argdefault
42   
43        set name [list $name]
44        # reconstruct the args list
45        set args [uplevel 1 [subst -nocommands {info args $name}]]
46        set arglist {}
47        foreach arg $args {
48            set argname [list $arg]
49            if {[uplevel 1 [subst -nocommands {info default $name $argname argdefault}]]} {
50                lappend arglist [list $arg $argdefault]
51            } else {
52                lappend arglist $arg
53            }
54        }
55        # modify the proc
56        set arglist [list $arglist]
57        set body [uplevel 1 [subst -nocommands {info body $name}]]
58        uplevel 1 [subst -nocommands {
59            proc $name $arglist {
60                if {[set err [catch {$body} result]] && [set err] != 2} {
61                    if {[set err] == 1} {
62                        return -code [set err] -errorcode [set ::errorCode] [set result]
63                    } else {
64                        return -code [set err] [set result]
65                    }
66                } else {
67                    return [set result]
68                }
69            }
70        }]
71    }
72}
73
74###################
75# List management #
76###################
77# It would be nice to have these written in C
78# That way we could avoid duplicating lists if they're not shared
79# but oh well
80
81# ldindex varName ?index...?
82# Removes the index'th list element from varName and returns it
83# If multiple indexes are provided, each one is a subindex into the
84# list element specified by the previous index
85# If no indexes are provided, deletes the entire list and returns it
86# If varName does not exists an exception is raised
87proc ldindex {varName args} {
88    set varName [list $varName]
89    if {[llength $args] > 0} {
90        set idx [lindex $args 0]
91        set size [uplevel 1 [subst -nocommands {llength [set $varName]}]]
92        set badrange? 0
93        if {[string is integer -strict $idx]} {
94            if {$idx < 0 || $idx >= $size} {
95                set badrange? 1
96            }
97        } elseif {$idx eq "end"} {
98            if {$size == 0} {
99                set badrange? 1
100            }
101        } elseif {[string match "end-*" $idx] && [string is integer -strict [string range $idx 4 end]]} {
102            set i [expr {$size - 1 - [string range $idx 4 end]}]
103            if {$i < 0 || $i >= $size} {
104                set badrange? 1
105            }
106        } else {
107            error "bad index \"$idx\": must be integer or end?-integer?"
108        }
109        if {${badrange?}} {
110            error "list index out of range"
111        }
112   
113        if {[llength $args] > 1} {
114            set list [uplevel 1 [subst -nocommands {lindex [set $varName] $idx}]]
115            set item [ldindex list {*}[lrange $args 1 end]]
116            uplevel 1 [subst {lset $varName $idx [list $list]}]
117        } else {
118            set item [uplevel 1 [subst -nocommands {lindex [set $varName] $idx}]]
119            uplevel 1 [subst -nocommands {set $varName [lreplace [set $varName] $idx $idx]}]
120        }
121    } else {
122        set item [uplevel 1 [subst {set $varName}]]
123        uplevel 1 [subst {set $varName {}}]
124    }
125    return $item
126}
127macports_util::method_wrap ldindex
128
129# lpop varName
130# Removes the last list element from a variable
131# If varName is an empty list an empty string is returned
132proc lpop {varName} {
133    set varName [list $varName]
134    set size [uplevel 1 [subst -nocommands {llength [set $varName]}]]
135    if {$size != 0} {
136        uplevel 1 [subst -nocommands {ldindex $varName end}]
137    }
138}
139macports_util::method_wrap lpop
140
141# lpush varName ?value ...?
142# Appends list elements onto a variable
143# If varName does not exist then it is created
144# really just an alias for lappend
145proc lpush {varName args} {
146    set varName [list $varName]
147    uplevel 1 [subst -nocommands {lappend $varName $args}]
148}
149macports_util::method_wrap lpush
150
151# lshift varName
152# Removes the first list element from a variable
153# If varName is an empty list an empty string is returned
154proc lshift {varName} {
155    set varName [list $varName]
156    set size [uplevel 1 [subst -nocommands {llength [set $varName]}]]
157    if {$size != 0} {
158        uplevel 1 [subst -nocommands {ldindex $varName 0}]
159    }
160}
161macports_util::method_wrap lshift
162
163# lunshift varName ?value ...?
164# Prepends list elements onto a variable
165# If varName does not exist then it is created
166proc lunshift {varName args} {
167    set varName [list $varName]
168    uplevel 1 [subst -nocommands {
169        if {![info exists $varName]} {
170            set $varName {}
171        }
172    }]
173    set value [concat $args [uplevel 1 set $varName]]
174    uplevel 1 set $varName [list $value]
175}
176macports_util::method_wrap lunshift
177
178################################
179# try/catch exception handling #
180################################
181# modelled after TIP #89 <http://www.tcl.tk/cgi-bin/tct/tip/89>
182
183if {![namespace exists ::_trycatch]} {
184    namespace eval ::_trycatch {
185        variable catchStack {}
186    }
187}
188
189# throw ?type? ?message? ?info?
190# Works like error, but arguments are reordered to encourage use of types
191# If called with no arguments in a catch block, re-throws the caught exception
192proc throw {args} {
193    if {[llength $args] == 0} {
194        # re-throw
195        if {[llength $::_trycatch::catchStack] == 0} {
196            return -code error "error: throw with no parameters outside of a catch"
197        } else {
198            set errorNode [lpop ::_trycatch::catchStack]
199            set errCode [lindex $errorNode 0]
200            set errMsg  [lindex $errorNode 1]
201            set errInfo [lindex $errorNode 2]
202            return -code error -errorinfo $errInfo -errorcode $errCode $errMsg
203        }
204    } elseif {[llength $args] > 3} {
205        return -code error "wrong # args: should be \"throw ?type? ?message? ?info?\""
206    } else {
207        set errCode [lindex $args 0]
208        if {[llength $args] > 1} {
209            set errMsg  [lindex $args 1]
210        } else {
211            set errMsg "error: $errCode"
212        }
213        if {[llength $args] > 2} {
214            set errInfo [lindex $args 2]
215        } else {
216            set errInfo $errMsg
217        }
218        return -code error -errorinfo $errInfo -errorcode $errCode $errMsg
219    }
220}
221
222# try body ?catch {type_list ?ecvar? ?msgvar? ?infovar?} body ...? ?finally body?
223# implementation of try as specified in TIP #89
224proc try {args} {
225    # validate and interpret the arguments
226    set catchList {}
227    if {[llength $args] == 0} {
228        return -code error "wrong # args: \
229            should be \"try body ?catch {type-list ?ecvar? ?msgvar? ?infovar?} body ...? ?finally body?\""
230    }
231    set body [lshift args]
232    while {[llength $args] > 0} {
233        set arg [lshift args]
234        switch $arg {
235            catch {
236                set elem [lshift args]
237                if {[llength $args] == 0 || [llength $elem] > 4} {
238                    return -code error "invalid syntax in catch clause: \
239                        should be \"catch {type-list ?ecvar? ?msgvar? ?infovar?} body\""
240                } elseif {[llength [lindex $elem 0 0]] == 0} {
241                    return -code error "invalid syntax in catch clause: type-list must contain at least one type"
242                }
243                lpush catchList $elem [lshift args]
244            }
245            finally {
246                if {[llength $args] == 0} {
247                    return -code error "invalid syntax in finally clause: should be \"finally body\""
248                } elseif {[llength $args] > 1} {
249                    return -code error "trailing args after finally clause"
250                }
251                set finallyBody [lshift args]
252            }
253            default {
254                return -code error "invalid syntax: \
255                    should be \"try body ?catch {type-list ?ecvar? ?msgvar? ?infovar?} body ...? ?finally body?\""
256            }
257        }
258    }
259
260    # at this point, we've processed all args
261    if {[set err [catch {uplevel 1 $body} result]] == 1} {
262        set savedErrorCode $::errorCode
263        set savedErrorInfo $::errorInfo
264        # rip out the last "invoked from within" - we want to hide our internals
265        set savedErrorInfo [regsub -linestop {(\n    \(.*\))?\n    invoked from within\n"uplevel 1 \$body"\Z} \
266                            $savedErrorInfo ""]
267        # add to the throw stack
268        lpush ::_trycatch::catchStack [list $savedErrorCode $result $savedErrorInfo]
269        # call the first matching catch block
270        foreach {elem catchBody} $catchList {
271            set typeList [lshift elem]
272            set match? 1
273            set typeList [lrange $typeList 0 [expr {[llength $savedErrorCode] - 1}]]
274            set codeList [lrange $savedErrorCode 0 [expr {[llength $typeList] - 1}]]
275            foreach type $typeList code $codeList {
276                if {![string match $type $code]} {
277                    set match? 0
278                    break
279                }
280            }
281            if {${match?}} {
282                # found a block
283                if {[set ecvar [lshift elem]] ne ""} {
284                    uplevel 1 set [list $ecvar] [list $savedErrorCode]
285                }
286                if {[set msgvar [lshift elem]] ne ""} {
287                    uplevel 1 set [list $msgvar] [list $result]
288                }
289                if {[set infovar [lshift elem]] ne ""} {
290                    uplevel 1 set [list $infovar] [list $savedErrorInfo]
291                }
292                if {[set err [catch {uplevel 1 $catchBody} result]] == 1} {
293                    # error in the catch block, save it
294                    set savedErrorCode $::errorCode
295                    set savedErrorInfo $::errorInfo
296                    # rip out the last "invoked from within" - we want to hide our internals
297                    set savedErrorInfo [regsub -linestop \
298                                        {(\n    \(.*\))?\n    invoked from within\n"uplevel 1 \$catchBody"\Z} \
299                                        $savedErrorInfo ""]
300                    # also rip out an "invoked from within" for throw
301                    set savedErrorInfo [regsub -linestop \
302                                        {\n    invoked from within\n"throw"\Z} $savedErrorInfo ""]
303                }
304                break
305            }
306        }
307        # remove from the throw stack
308        lpop ::_trycatch::catchStack
309    }
310    # execute finally block
311    if {[info exists finallyBody]} {
312        # catch errors here so we can strip our uplevel
313        set savedErr $err
314        set savedResult $result
315        if {[set err [catch {uplevel 1 $finallyBody} result]] == 1} {
316            set savedErrorCode $::errorCode
317            set savedErrorInfo $::errorInfo
318            # rip out the last "invoked from within" - we want to hide our internals
319            set savedErrorInfo [regsub -linestop \
320                                {(\n    \(.*\))?\n    invoked from within\n"uplevel 1 \$finallyBody"\Z} \
321                                $savedErrorInfo ""]
322        } elseif {$err == 0} {
323            set err $savedErr
324            set result $savedResult
325        }
326    }
327    # aaaand return
328    if {$err == 1} {
329        return -code $err -errorinfo $savedErrorInfo -errorcode $savedErrorCode $result
330    } else {
331        return -code $err $result
332    }
333}
Note: See TracBrowser for help on using the repository browser.