diff options
Diffstat (limited to 'library/init.tcl')
| -rw-r--r-- | library/init.tcl | 184 |
1 files changed, 1 insertions, 183 deletions
diff --git a/library/init.tcl b/library/init.tcl index 3ec3079..6ca4873 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -3,7 +3,7 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# RCS: @(#) $Id: init.tcl,v 1.120 2009/01/16 20:44:25 dgp Exp $ +# RCS: @(#) $Id: init.tcl,v 1.121 2009/03/09 09:12:39 dkf Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -113,188 +113,6 @@ namespace eval tcl { } } -# TIP #329: [try] -# This is a *temporary* implementation, to be replaced with one in C and -# bytecode at a later date before 8.6.0 -namespace eval ::tcl::control { - # These are not local, since this allows us to [uplevel] a [catch] rather - # than [catch] the [uplevel]ing of something, resulting in a cleaner - # -errorinfo: - variable em {} - variable opts {} - - variable magicCodes { ok 0 error 1 return 2 break 3 continue 4 } - - namespace export try - - # ::tcl::control::try -- - # - # Advanced error handling construct. - # - # Arguments: - # See try(n) for details - proc try {args} { - variable magicCodes - - # ----- Parse arguments ----- - - set trybody [lindex $args 0] - set finallybody {} - set handlers [list] - set i 1 - - while {$i < [llength $args]} { - switch -- [lindex $args $i] { - "on" { - incr i - set code [lindex $args $i] - if {[dict exists $magicCodes $code]} { - set code [dict get $magicCodes $code] - } elseif {![string is integer -strict $code]} { - set msgPart [join [dict keys $magicCodes] {", "}] - error "bad code '[lindex $args $i]': must be\ - integer or \"$msgPart\"" - } - lappend handlers [lrange $args $i $i] \ - [format %d $code] {} {*}[lrange $args $i+1 $i+2] - incr i 3 - } - "trap" { - incr i - if {![string is list [lindex $args $i]]} { - error "bad prefix '[lindex $args $i]':\ - must be a list" - } - lappend handlers [lrange $args $i $i] 1 \ - {*}[lrange $args $i $i+2] - incr i 3 - } - "finally" { - incr i - set finallybody [lindex $args $i] - incr i - break - } - default { - error "bad handler '[lindex $args $i]': must be\ - \"on code varlist body\", or\ - \"trap prefix varlist body\"" - } - } - } - - if {($i != [llength $args]) || ([lindex $handlers end] eq "-")} { - error "wrong # args: should be\ - \"try body ?handler ...? ?finally body?\"" - } - - # ----- Execute 'try' body ----- - - variable em - variable opts - set EMVAR [namespace which -variable em] - set OPTVAR [namespace which -variable opts] - set code [uplevel 1 [list ::catch $trybody $EMVAR $OPTVAR]] - - if {$code == 1} { - set line [dict get $opts -errorline] - dict append opts -errorinfo \ - "\n (\"[lindex [info level 0] 0]\" body line $line)" - } - - # Keep track of the original error message & options - set _em $em - set _opts $opts - - # ----- Find and execute handler ----- - - set errorcode {} - if {[dict exists $opts -errorcode]} { - set errorcode [dict get $opts -errorcode] - } - set found false - foreach {descrip oncode pattern varlist body} $handlers { - if {!$found} { - if { - ($code != $oncode) || ([lrange $pattern 0 end] ne - [lrange $errorcode 0 [llength $pattern]-1] ) - } then { - continue - } - } - set found true - if {$body eq "-"} { - continue - } - - # Handler found ... - - # Assign trybody results into variables - lassign $varlist resultsVarName optionsVarName - if {[llength $varlist] >= 1} { - upvar 1 $resultsVarName resultsvar - set resultsvar $em - } - if {[llength $varlist] >= 2} { - upvar 1 $optionsVarName optsvar - set optsvar $opts - } - - # Execute the handler - set code [uplevel 1 [list ::catch $body $EMVAR $OPTVAR]] - - if {$code == 1} { - set line [dict get $opts -errorline] - dict append opts -errorinfo \ - "\n (\"[lindex [info level 0] 0] ... $descrip\"\ - body line $line)" - # On error chain to original outcome - dict set opts -during $_opts - } - - # Handler result replaces the original result (whether success or - # failure); capture context of original exception for reference. - set _em $em - set _opts $opts - - # Handler has been executed - stop looking for more - break - } - - # No catch handler found -- error falls through to caller - # OR catch handler executed -- result falls through to caller - - # ----- If we have a finally block then execute it ----- - - if {$finallybody ne {}} { - set code [uplevel 1 [list ::catch $finallybody $EMVAR $OPTVAR]] - - # Finally result takes precedence except on success - - if {$code == 1} { - set line [dict get $opts -errorline] - dict append opts -errorinfo \ - "\n (\"[lindex [info level 0] 0] ... finally\"\ - body line $line)" - # On error chain to original outcome - dict set opts -during $_opts - } - if {$code != 0} { - set _em $em - set _opts $opts - } - - # Otherwise our result is not affected - } - - # Propagate the error or the result of the executed catch body to the - # caller. - dict incr _opts -level - return -options $_opts $_em - } -} -namespace import ::tcl::control::try - # Windows specific end of initialization if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { |