scripts/try.tcl

   1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
   2
   3 package require Tcl 8.5
   4
   5 proc tlc::try {code args} { #<<<
   6         upvar _tlc_try_standard_actions std_actions
   7         if {[info exists std_actions]} {
   8                 set actions             [dict merge $std_actions $args]
   9         } else {
  10                 set actions             $args
  11         }
  12         if {[set ecode [catch {uplevel $code} errmsg options]]} {
  13                 if {$ecode != 1} {
  14                         dict incr options -level 1
  15                         return -options $options $errmsg
  16                 }
  17                 if {[dict exists $actions onerr]} {
  18                         set handlers    [string map {STDMSG {log error "\nUnexpected error: $errmsg\n$::errorInfo"}} [dict get $actions onerr]]
  19                         if {![dict exists $handlers default]} {
  20                                 dict set handlers default {
  21                                         dict incr options -level 1
  22                                         return -options $options $errmsg
  23                                 }
  24                         }
  25                         if {[set hcode [catch {
  26                                 uplevel [list set errmsg        $errmsg]
  27                                 uplevel [list set options       $options]
  28                                 uplevel [list switch -- [lindex $::errorCode 0] $handlers]
  29                         } herrmsg options]]} {
  30                                 dict incr options -level 1
  31                                 return -options $options $herrmsg
  32                         }
  33                 }
  34
  35                 if {[dict exists $actions aftererr]} {
  36                         if {[set ecode [catch {uplevel [dict get $actions aftererr]} errmsg options]]} {
  37                                 dict incr options -level 1
  38                                 return -options $options $errmsg
  39                         }
  40                 }
  41         } else {
  42                 if {[dict exists $actions onok]} {
  43                         if {[set ecode [catch {uplevel [dict get $actions onok]} errmsg options]]} {
  44                                 dict incr options -level 1
  45                                 return -options $options $errmsg
  46                         }
  47                 }
  48         }
  49
  50         if {[dict exists $actions after]} {
  51                 if {[set ecode [catch {uplevel [dict get $actions after]} errmsg options]]} {
  52                         dict incr options -level 1
  53                         return -options $options $errmsg
  54                 }
  55         }
  56 }
  57
  58 #>>>
  59 proc tlc::try_set_standard_actions {args} { #<<<
  60         upvar _tlc_try_standard_actions std_actions
  61         set std_actions [dict merge $std_actions $args]
  62 }
  63
  64 #>>>