archie/tcl-dp/library/dp_atexit.tcl
2024-05-27 16:13:40 +02:00

203 lines
5.4 KiB
Tcl

#
# dp_atexit -- command to install a Tcl callback to be invoked when
# -- the exit command is evalutated.
#
# exit -- command to exit process, after all callbacks installed by
# -- the dp_atexit command have been invoked.
#
#
# This module is structured as a sequence of "helper" functions and
# a single "dispatch" function that just calls the helpers.
set dp_atexit_inited 0
#######################################################################
#
# dp_atexit_appendUnique --
#
# Helper function to append callback to end of the callbacks list if
# it's not already there.
#
proc dp_atexit_appendUnique args {
global dp_atexit_callbacks;
if {[llength $args] != 1} {
error {wrong # args : should be "dp_atexit appendUnique callback"};
}
# append callback to end of the callbacks list.
set callback [lindex $args 0];
if {[lsearch $dp_atexit_callbacks $callback] == -1} {
lappend dp_atexit_callbacks $callback;
}
}
#######################################################################
#
# dp_atexit_append --
#
# Helper function to append callback to end of the callbacks list
#
proc dp_atexit_append args {
global dp_atexit_callbacks;
if {[llength $args] != 1} {
error {wrong # args : should be "dp_atexit appendUnique callback"};
}
set callback [lindex $args 0];
lappend dp_atexit_callbacks $callback;
}
#######################################################################
#
# dp_atexit_prepend --
#
# Helper function to prepend callback to front of the callbacks list.
#
proc dp_atexit_prepend args {
global dp_atexit_callbacks;
if {[llength $args] != 1} {
error {wrong # args : should be "dp_atexit prepend callback"};
}
set callback [lindex $args 0];
set dp_atexit_callbacks "\{$callback\} $dp_atexit_callbacks";
}
#######################################################################
#
# dp_atexit_insert --
#
# Helper function to insert callback before the "before" callback in the
# callbacks list
#
proc dp_atexit_insert args {
global dp_atexit_callbacks;
if {[llength $args] != 2} {
error {wrong # args : should be "dp_atexit insert before callback"};
}
set before [lindex $args 0];
set callback [lindex $args 1];
set l {};
foreach c $dp_atexit_callbacks {
if {[string compare $before $c] == 0} {
lappend l $callback;
}
lappend l $c;
}
set dp_atexit_callbacks $l;
}
#######################################################################
#
# dp_atexit_delete --
#
# Helper function to delete callback from the callbacks list.
#
proc dp_atexit_delete args {
global dp_atexit_callbacks;
if {[llength $args] != 1} {
error {wrong # args : should be "dp_atexit delete callback"};
}
set callback [lindex $args 0];
set l {};
foreach c $dp_atexit_callbacks {
if {[string compare $callback $c] != 0} {
lappend l $c;
}
}
set dp_atexit_callbacks $l;
}
#######################################################################
#
# dp_atexit_clear --
#
# Helper function to clear callbacks list
#
proc dp_atexit_clear args {
global dp_atexit_callbacks;
if {[llength $args] != 0} {
error {wrong # args : should be "dp_atexit clear"};
}
set dp_atexit_callbacks {};
}
#######################################################################
#
# dp_atexit --
#
# "option" may be appendUnique, append, prepend, insert, delete,
# clear, set, or list.
# "args" depends on the option specified.
#
# The global variable dp_atexit_callbacks is where we store the
# list of installed dp_atexit callbacks.
#
proc dp_atexit {{option list} args} {
global dp_atexit_inited;
global dp_atexit_callbacks;
# Hide real exit command and init the global variable
if {!$dp_atexit_inited} {
incr dp_atexit_inited
rename exit dp_atexit_really_exit
dp_atexit_install_exit
set dp_atexit_callbacks {}
}
case $option in {
set { set dp_atexit_callbacks $args; }
appendUnique { eval dp_atexit_appendUnique $args }
append { eval dp_atexit_append $args }
prepend { eval dp_atexit_prepend $args }
insert { eval dp_atexit_insert $args }
delete { eval dp_atexit_delete $args }
clear { eval dp_atexit_clear $args }
list {return $dp_atexit_callbacks}
default {
error {options: append, appendUnique, prepend, insert, delete,
clear, set, or list};
}
}
return $dp_atexit_callbacks;
}
#######################################################################
#
# dp_atexit_install_exit -- Wrapper to install exit command that first
# invokes all callbacks installed by the dp_atexit command before doing
# real exit.
#
proc dp_atexit_install_exit {} {
uplevel #0 {proc exit {{code 0}} {
global dp_atexit_callbacks;
while {1} {
# Every iteration, we rescan dp_atexit_callbacks, in case
# some callback modifies it.
if {[catch {set dp_atexit_callbacks} callbacks]} {
break;
}
if {[llength $callbacks] <= 0} {
break;
}
set callback [lindex $callbacks 0];
set dp_atexit_callbacks [lrange $callbacks 1 end];
catch {uplevel #0 $callback};
}
catch {unset dp_atexit_callbacks};
catch {dp_atexit_really_exit $code};
}
}
}