Inspired by a comp.lang.tcl articel [http://groups.google.com/group/comp.lang.tcl/browse_frm/thread/afd1750b79017a7d/b0d0acd899130bc1?hl=en#b0d0acd899130bc1], I rethought my older way of '''AtExit''' and here it is in a tcl 8.5 version:

======
 namespace eval ::atExit {
     variable scripts;
     variable state;
     variable stopOnError;
     variable mode;

     set scripts     [list];
     set state       1;
     set stopOnError 0;
     set mode        "normal"

     proc register {args} {
         if {[llength $args] == 0} {
             error "wrong # args: should be \"atExit register command ?arg arg ...?\"";
         }

         variable scripts;

         if {[info complete $args] == 0} {
             error "invalid exit script \"$args\"";
         }

         lappend scripts $args;

         if {{enter ::atExit::enter} ni [trace info execution exit]} {
             trace add execution exit enter ::atExit::enter;
         }

         return [format {atExit%x} [llength $scripts]];
     }

     proc unregister {args} {
         if {[llength $args] == 0} {
             error "wrong # args: should be \"atExit unregister token ?token ...?\"";
         }

         variable scripts;

         foreach token $args {
             if {[scan $token {atExit%x} index] != 1} {
                 error "invalid atExit script token \"$token\"";
             }

             set scripts [lreplace $scripts $index-1 $index-1];
         }

         if {[llength $scripts] == 0} {
             trace remove execution exit enter ::atExit::enter;
         }

         return;
     }

     proc scripts {} {
         variable scripts;

         return $scripts;
     }

     proc state {{newState NaV}} {
         variable state;

         if {$newState ne "NaV"} {
             if {[string is boolean -strict $newState] == 1} {
                 set state   [string is true $newState];
             } elseif {$newState in {disabled normal}} {
                 set state   [expr {$newState eq "normal" ? 1 : 0}];
             } else {
                 error "expected a valid boolean value, but got \"$newState\"";
             }
         }

         return $state;
     }

     proc stoponerror {{newState "NaV"}} {
         variable stopOnError;

         if {$newState ne "NaV"} {
             if {[string is boolean -strict $newState] == 1} {
                 set stopOnError [string is true $newState];
             } elseif {$newState in {disabled normal}} {
                 set stopOnError [expr {$newState eq "normal" ? 1 : 0}];
             } else {
                 error "expected a valid boolean value, but got \"$newState\"";
             }
         }

         return $stopOnError;
     }

     proc mode {{newMode "NaV"}} {
         variable mode;

         if {$newMode ne "NaV"} {
             if {$newMode in {fifu normal}} {
                 set mode    "normal";
             } elseif {$newMode in {lafu reversed}} {
                 set mode    "reversed";
             } else {
                 error "bad evaluation mode \"$newMode\": must be fifu, lafu, normal, or reversed";
             }
         }

         return $mode;
     }

     proc enter {args} {
         variable state;
         variable scripts;
         variable stopOnError;
         variable mode;

         if {$state == 0} {
             return;
         }
         
         foreach script [expr {$mode eq "normal" ? $scripts : [lreverse $scripts]}] {
             set rc  [catch {uplevel #0 $script;} reason];

             if {$rc == 1} {
                 if {$stopOnError == 1} {
                     error $reason $::errorInfo $::errorCode;
                 } elseif {[string length $reason] > 0} {
                     puts stderr $reason;
                 }
             } elseif {$rc == 3} {
                 if {[string length $reason] > 0} {
                     puts stderr $reason;
                 }

                 break;
             }
         }

         return;
     }

     namespace export -clear register unregister scripts state stoponerror mode;
     namespace ensemble create;
 }
 
 if {0} {
     proc test1 {} {
         puts [info level 0];
         gets stdin;
     }
 
     proc test2 {} {
         puts [info level 0];
         gets stdin;
         error "test2 error";
     }
 
     proc test3 {} {
         puts [info level 0];
         gets stdin;
         return -code break "test3 break";
     }
 
     atExit register test1;
     atExit register test2;
     atExit register test3;
     atExit stoponerror 0;
 
     # normal use case
     #
     exit;
 
     # stop-on-error use case
     #   => the error caused by test2 lets exit stop and return
     #
     atExit stoponerror 1;
 
     exit;
 
     # reversed use case:
     #   => test3 will evaluated at first
     #   => the break causes to ignore test2 and test2
     #
     atExit mode reversed;
     atExit stoponerror 1;
 
     exit;
 } 
======

----
[LV] 2008-Jan-17
Just an observation - every statement above ends in a ; which the interpreter will of course recognize, but which isn't required. But you probably already knew that...

[male] 2008-Jan-17
... yes, I know this!

I'm just too stupid to write C(++) without forgetting semicolons after writing tcl code without. So I use them consequently in tcl and C++.

<<categories>> Package | Dev. Tools