# FILE: procs.tcl # # A collection of Tcl procedures (not Oc_Classes) which are part of the # Oc extension # # Need to split this into files likely to load together # Returns the absolute, direct pathname of its argument proc Oc_DirectPathname { pathname } { global Oc_DirectPathnameCache set canCdTo [file dirname $pathname] set rest [file tail $pathname] switch -exact -- $rest { . - .. { set canCdTo [file join $canCdTo $rest] set rest "" } } if {[string match absolute [file pathtype $canCdTo]]} { set index $canCdTo } else { set index [file join [pwd] $canCdTo] } if {[info exists Oc_DirectPathnameCache($index)]} { return [file join $Oc_DirectPathnameCache($index) $rest] } if {[catch {set savedir [pwd]} msg]} { return -code error "Can't determine pathname for\n\t$pathname:\n\t$msg" } # Try to [cd] to where we can [pwd] while {[catch {cd $canCdTo}]} { switch -exact -- [file tail $canCdTo] { "" { # $canCdTo is the root directory, and we can't cd to it. # This means we know the direct pathname, even though we # can't cd to it or any of its ancestors. set Oc_DirectPathnameCache($index) $canCdTo ;# = '/' return [file join $Oc_DirectPathnameCache($index) $rest] } . { # Do nothing. Leave $rest unchanged } .. { # NOMAC: Assuming '..' means 'parent directory' # Don't want to shift '..' onto $rest. # Make recursive call instead. set Oc_DirectPathnameCache($index) [file dirname \ [Oc_DirectPathname [file dirname $canCdTo]]] return [file join $Oc_DirectPathnameCache($index) $rest] } default { ;# Shift one path component from $canCdTo to $rest set rest [file join [file tail $canCdTo] $rest] } } set canCdTo [file dirname $canCdTo] set index [file dirname $index] } # We've successfully changed the working directory to $canCdTo # Try to use [pwd] to get the direct pathname of the working directory catch {set Oc_DirectPathnameCache($index) [pwd]} # Shouldn't be a problem with a [cd] back to the original working directory cd $savedir if {![info exists Oc_DirectPathnameCache($index)]} { # Strange case where we could [cd] into $canCdTo, but [pwd] failed. # Try a recursive call to resolve matters. set Oc_DirectPathnameCache($index) [Oc_DirectPathname $canCdTo] } return [file join $Oc_DirectPathnameCache($index) $rest] } # Routine to completely resolve file links # Raises an error if pathname is not a link, or # if the link cannot be resolved proc Oc_ResolveLink { pathname } { if {[catch {file type $pathname} ftype]} { if {![file exists $pathname]} { return -code error "File $pathname does not exist" } return -code error $ftype } if {![string match "link" $ftype]} { return -code error "$pathname is not a link" } if {![file exists $pathname]} { # This should catch loops and hanging links return -code error "Link $pathname cannot be resolved." } set workname $pathname set arr($workname) 1 for {set depth 0} {$depth<20} {incr depth} { set tmpname [file readlink $workname] set ptype [file pathtype $tmpname] switch -exact -- $ptype { absolute { set workname $tmpname } relative { set workname [file join [file dirname $workname] $tmpname] } default { return -code error "Unsupported pathtype: $ptype" } } if {![string match "link" [file type $workname]]} { return $workname } if {[info exists arr($workname)]} { return -code error \ "Link $pathname cannot be resolved: Loop detected" } set arr($workname) 1 } return -code error "Link $pathname cannot be resolved: > $depth levels" } # The next proc duplicates the logic in the # oommf/config/names/cygtel.tcl file. ;proc Oc_IsCygwinPlatform {} { global tcl_platform env if {![regexp -nocase -- windows $tcl_platform(platform)]} { return 0 } if {![string match intel $tcl_platform(machine)]} { return 0 } if {[info exists env(OSTYPE)] && [string match cygwin* [string tolower $env(OSTYPE)]]} { return 1 } if {[string match cyg* [file tail [info nameofexecutable]]]} { return 1 } if {[info exists env(TERM)] && ([string match cygwin* [string tolower $env(TERM)]] || [string match xterm [string tolower $env(TERM)]])} { return 1 } return 0 } proc Oc_MakePortHeader {varinfo outfile} { # Eventually make calls to objects representing local configuration. puts "Updating [file join [pwd] $outfile] ..." global tcl_platform # See if we can tell what platform we are on set config [Oc_Config RunPlatform] set systemtype unknown ;# For local use if {![info exists tcl_platform(platform)]} { set systemtype unix ;# Can't tell, so assume unix } else { if {[string compare $tcl_platform(platform) "unix"] == 0} { set systemtype unix } elseif {[string compare $tcl_platform(platform) "windows"] == 0} { if {[Oc_IsCygwinPlatform]} { # Building under the cygwin toolkit set systemtype unix } else { set systemtype windows } } elseif {[string compare $tcl_platform(platform) "macintosh"] == 0} { set systemtype macintosh } } # Run varinfo and parse output set varinfo_flags {} if {![catch { $config GetValue program_compiler_c++_property_strict_atan2 }]} { # Property already set (probably from cache file). Keep # this value and disable atan2 test in varinfo. lappend varinfo_flags "--skip-atan2" } if {[catch {eval exec $varinfo $varinfo_flags 2>@ stderr} varlist]} { # error running varinfo, probably killed by atan2 test. # Try again, disabling that test $config SetValue program_compiler_c++_property_strict_atan2 1 lappend varinfo_flags --skip-atan2 if {[catch {eval exec $varinfo $varinfo_flags 2>@ stderr} varlist]} { set msg "Error running $varinfo $varinfo_flags:\n$varlist" error $msg $msg } } foreach vartype {char short int long float double} { set varorder($vartype) -1 ;# Safety regexp "$vartype is *(\[0-9\]*) bytes wide *Byte order: *(\[0-9\]*)" \ $varlist tempmatch varsize($vartype) varorder($vartype) } set varsize(pointer) -1 regexp {void \* is *([0-9]*)} $varlist tempmatch varsize(pointer) foreach varwidth {FLT DBL} { regexp "\n${varwidth}_EPSILON: (\[^\n\]+)" \ $varlist tempmatch vareps($varwidth) regexp "\nSQRT_${varwidth}_EPSILON: (\[^\n\]+)" \ $varlist tempmatch vareps(SQRT_$varwidth) } regexp "\nCUBE_ROOT_DBL_EPSILON: (\[^\n\]+)" \ $varlist tempmatch vareps(CUBE_ROOT_DBL) if {[catch { $config GetValue program_compiler_c++_property_strict_atan2 }]} { # Config value program_compiler_c++_property_strict_atan2 # has not been set, so make use of varinfo test. # Initialize atan2_value to NaN (Not-a-Number). If varinfo # has reported on atan2(0,0), and if the value is in the range # [-Pi,Pi], then set program_compiler_c++_property_strict_atan # false, which allows OOMMF code to make direct calls to the # system math library atan2 function. Otherwise, see that # Oc_Atan2 gets wrapped around atan2 calls to protect against # the (0,0) input case. set atan2_value "NaN" regexp -- "\nReturn value from atan2\\(0,0\\): *(.*\[^\n\])" \ $varlist tempmatch atan2_value set atan2_value [string trim $atan2_value] if {![catch {expr $atan2_value>-3.15 && $atan2_value<3.15} result] \ && $result} { # Looks like (0,0) is in the domain of atan2 $config SetValue program_compiler_c++_property_strict_atan2 0 } else { # atan2(0,0) probably returns NaN. In any case, enable # special handling of (0,0) for atan2 $config SetValue program_compiler_c++_property_strict_atan2 1 } } # Dump header info set porth \ {/* FILE: ocport.h -*-Mode: c++-*- * * Machine specific #define's and typedef's, generated by [Oc_MakePortHeader] * */ #ifndef _OC_PORT #define _OC_PORT #include #include #include #define MEMBLOCKSIZE 4096 /* Natural system memory blocksize. Shouldn't */ /* affect program correctness, but may affect performance. */ } # Does compiler not support C++ exceptions? if {[catch { $config GetValue program_compiler_c++_property_no_exceptions } _] || !$_} { append porth { // See Stroustrup, Section 16.1.3. #include // The base class std::exception and the // standard exception std::bad_exception #include // The standard exception std::bad_alloc #include // The standard exceptions std::bad_cast // and std::bad_typeid #define OC_THROW(x) throw x } } else { append porth { #define NO_EXCEPTIONS #define OC_THROW(x) Tcl_Panic(x) } } append porth { /* End includes */} append porth " #define CONFIG_TCL_MAJOR_VERSION [$config GetValue TCL_MAJOR_VERSION] #define CONFIG_TCL_MINOR_VERSION [$config GetValue TCL_MINOR_VERSION] #define CONFIG_TK_MAJOR_VERSION [$config GetValue TK_MAJOR_VERSION] #define CONFIG_TK_MINOR_VERSION [$config GetValue TK_MINOR_VERSION]" if {[catch {set tclpl [$config GetValue TCL_PATCH_LEVEL]}]} { regsub {^[0-9]+\.[0-9]+} [info patchlevel] {} tclpl } append porth " #define CONFIG_TCL_PATCH_LEVEL \"[$config GetValue TCL_VERSION]$tclpl\"" if {[catch {set tkpl [$config GetValue TK_PATCH_LEVEL]}]} { # Assume Tcl and Tk patch levels are in sync # Otherwise would need Tk loaded to access $tk_patchLevel regsub {^[0-9]+\.[0-9]+} [info patchlevel] {} tkpl } append porth " #define CONFIG_TK_PATCH_LEVEL \"[$config GetValue TK_VERSION]$tkpl\"" proc PL2LS {pl} { switch -- [string index $pl 0] { a {return [list 0 [string range $pl 1 end]]} b {return [list 1 [string range $pl 1 end]]} p - . {return [list 2 [string range $pl 1 end]]} "" {return [list 2 0]} default {return -code error "Bad patchLevel value: $pl"} } } foreach {tclrl tclrs} [PL2LS $tclpl] {break} foreach {tkrl tkrs} [PL2LS $tkpl] {break} rename PL2LS {} append porth " #define CONFIG_TCL_RELEASE_LEVEL $tclrl #define CONFIG_TCL_RELEASE_SERIAL $tclrs #define CONFIG_TK_RELEASE_LEVEL $tkrl #define CONFIG_TK_RELEASE_SERIAL $tkrs\n" catch {append porth "#define CONFIG_TCL_LIBRARY\ [$config GetValue TCL_LIBRARY]\n"} # Does compiler support the 'using namespace std' directive? if {[catch { $config GetValue program_compiler_c++_property_no_std_namespace } _] || !$_} { append porth \ "#define OC_USE_STD_NAMESPACE using namespace std; typedef std::exception EXCEPTION\n" } else { append porth \ "#define OC_USE_STD_NAMESPACE typedef exception EXCEPTION\n" } # Does compiler have strict atan2 function? if {![catch { $config GetValue program_compiler_c++_property_strict_atan2 } _] && $_} { append porth " /* Substitute domain checked atan2 */ #define atan2(y,x) Oc_Atan2((y),(x))\n" } # Does compiler have non-ansi sprintf that returns pointer instead # of string length? if {![catch { $config GetValue program_compiler_c++_property_nonansi_sprintf } _] && $_} { # Provide wrapper append porth { /* Wrapper to make sprintf ansi-compliant */ #define OC_SPRINTF_WRAP(x) strlen(x) } } else { # Dummy wrapper append porth { /* Dummy wrapper for ansi-compliant sprintf */ #define OC_SPRINTF_WRAP(x) (x) } } # Fill in missing function prototypes foreach func [$config Features program_compiler_c++_prototype_supply_*] { set proto [$config GetValue $func] if {![regexp ";\[ \n\]*$" $proto]} { append proto ";" ;# Append trailing semi-colon } append porth "$proto\n" } # Write universal (I hope!) typedef's append porth { /* Variable type declarations. The '****#m' */ /* types are at *least* '#' bytes wide. */ typedef int BOOL; typedef unsigned char BYTE; typedef char CHAR; /* typedef signed char SCHAR; */ /** signed type not supported by HP C++ compiler **/ typedef unsigned char UCHAR; } # Write float typedef's append porth "\n" if { $varsize(float) != $varsize(double) } { append porth "typedef float REAL$varsize(float);\n" } append porth "typedef double REAL$varsize(double);\n" if { $varsize(float) >= 4 } { append porth "typedef float REAL4m;\n" } if { $varsize(float) >= 8 } { append porth "typedef float REAL8m;\n" } elseif { $varsize(double) >= 8 } { append porth "typedef double REAL8m;\n" } if {[catch {$config GetValue program_compiler_c++_typedef_realwide} \ widetype]} { set widetype "REAL8m" } append porth [format \ "typedef %-18s REALWIDE; /* Widest native float */\n" \ $widetype] append porth \ "#define REAL4_EPSILON $vareps(FLT) #define SQRT_REAL4_EPSILON $vareps(SQRT_FLT) #define REAL8_EPSILON $vareps(DBL) #define SQRT_REAL8_EPSILON $vareps(SQRT_DBL) #define CUBE_ROOT_REAL8_EPSILON $vareps(CUBE_ROOT_DBL)\n\n" # May add "long double" support in the future # Write integer typedef's if { $varsize(short) < $varsize(int) } { append porth "typedef short INT$varsize(short);\n" append porth "typedef unsigned short UINT$varsize(short);\n" } append porth "typedef int INT$varsize(int);\n" append porth "typedef unsigned int UINT$varsize(int);\n" if { $varsize(long) > $varsize(int) } { append porth "typedef long INT$varsize(long);\n" append porth "typedef unsigned long UINT$varsize(long);\n" } foreach msize { 2 4 8 16 } { if { $varsize(int) >= $msize } { # Use type "int" if possible, as this is likely # to be the preferred machine word size append porth "typedef int INT${msize}m;\n" append porth "typedef unsigned int UINT${msize}m;\n" } elseif { $varsize(long) >=$msize } { # Otherwise, fall back on long type append porth "typedef long INT${msize}m;\n" append porth "typedef unsigned long UINT${msize}m;\n" } # In the future, may add support for "long long" integral type } # Pointers append porth "\n#define POINTERWIDTH $varsize(pointer)\n" # Byte order. For now just use 4-byte wide ordering foreach vartype { int long short float double } { if { $varsize($vartype) == 4 } { append porth "#define BYTEORDER $varorder($vartype)\n" break } } # Machine platform types append porth { /* System type info */ #define UNIX 1 #define WINDOWS 2 #define MACINTOSH 3 } # Note: Local variable "systemtype" is set at top of this proc if {[string compare $systemtype "unix"] == 0} { append porth "#define SYSTEM_TYPE UNIX\n" } elseif {[string compare $systemtype "windows"] == 0} { append porth "#define SYSTEM_TYPE WINDOWS\n" } elseif {[string compare $systemtype "macintosh"] == 0} { append porth "#define SYSTEM_TYPE MACINTOSH\n" } set OS [string tolower [string trim $tcl_platform(os)]] set OSVERSION [string tolower [string trim $tcl_platform(osVersion)]] set OSMAJOR $OSVERSION regexp {([^.]*).*} $OSVERSION match OSMAJOR # Random number generator protoypes # Should later replace this with an Autoconf-style determination. if {[string match sunos $OS] && $OSMAJOR >= 5} { append porth { /* Random number generator. Replace with your own if you don't like */ /* random(). Prototypes for random() and srandom() appear to be */ /* missing from the Solaris system header files (though they are in the */ /* runtime library). If you don't have random(), you can use rand() */ /* instead, but be wary of some older, badly broken versions of rand(). */ extern "C" { /* If you get error messages about multiple inconsistent definitions */ /* of random or srandom, just yank out this prototype block. */ long random(void); void srandom(unsigned int seed); } #define OMF_SRANDOM(seed) srandom(seed) #define OMF_RANDOM() random() #define OMF_RANDOM_MAX 0x7FFFFFFF /* Is this system dependent? */ } } elseif {[string match sunos $OS] && $OSMAJOR < 5} { append porth { /* Random number generator --special case for sunbow (SunOS 4.1.3). */ #define OMF_SRANDOM(seed) srand(seed) #define OMF_RANDOM() rand() #define OMF_RANDOM_MAX 0x7FFF } } elseif {[string match windows $systemtype]} { append porth { /* Random number generator. Replace with your own if */ /* if you don't like rand(). */ #define OMF_SRANDOM(seed) srand(seed) #define OMF_RANDOM() rand() #define OMF_RANDOM_MAX RAND_MAX } } elseif {[string match aix $OS]} { append porth { /* Random number generator. Replace with your own if */ /* if you don't like rand(). */ #define OMF_SRANDOM(seed) srand(seed) #define OMF_RANDOM() rand() #define OMF_RANDOM_MAX RAND_MAX } } elseif {[string match hp-ux $OS]} { append porth { /* Random number generator. Replace with your own if */ /* if you don't like rand(). */ #define OMF_SRANDOM(seed) srand(seed) #define OMF_RANDOM() rand() #define OMF_RANDOM_MAX RAND_MAX } } else { append porth { /* Random number generator. Replace with your own if */ /* you don't like random(). */ #define OMF_SRANDOM(seed) srandom(seed) #define OMF_RANDOM() random() #define OMF_RANDOM_MAX 0x7FFFFFFF /* Is this system dependent? */ } } if {[string match sunos $OS] && $OSMAJOR < 5} { append porth { /* Signal handler prototype, to work around some non-ANSI header files */ extern "C" { /* typedef void(*omf_sighandler)(int); */ /* ANSI version */ typedef void(*omf_sighandler)(int, ...); /* Not ANSI */ } } } else { append porth { /* Signal handler prototype, to work around some non-ANSI header files */ extern "C" { typedef void(*omf_sighandler)(int); /* ANSI version */ /* typedef void(*omf_sighandler)(int, ...); */ /* Not ANSI */ } } } # Windows vs. Unix-isms if {[string compare $systemtype unix] == 0} { append porth { /* For unix */ #include #include #include #include /* Child process cleanup */ /* NICE_DEFAULT is the value passed to nice() inside */ /* MakeNice(). */ #define NICE_DEFAULT 9 /* If your system doesn't have nice, uncomment the next line, or put */ /* in a suitable replacement macro (using, perhaps, setpriority()?). */ /*#define nice(x) 0 */ /* Directory path separator; Unix uses '/', DOS uses '\'. */ /* Rumor has it that the Mac uses ':'. */ #define DIRSEPCHAR '/' #define DIRSEPSTR "/" #define PATHSPLITSTR ":" } } if {[string compare $systemtype windows] == 0} { append porth { /* For Windows */ #define rint(x) ((x)>=0 ? double(int(x+0.5)) : double(int(x-0.5))) /* NICE_DEFAULT is the priority level passed to SetPriorityClass() */ /* inside MakeNice(). */ #define NICE_DEFAULT IDLE_PRIORITY_CLASS /* getpid() prototype */ #include /* Windows header file. NB: This defines a lot of stuff we */ /* don't need or really want, like macros min(x,y) and max(x,y). */ #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN /* Directory path separator; Unix uses '/', DOS uses '\'. */ /* Rumor has it that the Mac uses ':'. */ #define DIRSEPCHAR '\\' #define DIRSEPSTR "\\" #define PATHSPLITSTR ";" } } # Dump trailer append porth "#endif /* _OC_PORT_H */" # Open output file if { [string compare $outfile stdout] == 0 } { set fileid stdout } else { if {[catch {open $outfile w} fileid]} { puts stderr \ "Unable to open machine header file $outfile for writing" return 0 } } puts $fileid $porth if { [string compare $outfile stdout] != 0 } { close $fileid } } proc Oc_MakeTclIndex {dir args} { puts "Updating [file join [pwd] $dir tclIndex] ..." eval [list auto_mkindex $dir] $args global errorCode errorInfo set oldDir [pwd] cd $dir set dir [pwd] append index "# The following lines were appended to this file by the\n" append index "# command 'Oc_MakeTclIndex' called by pimake . They\n" append index "# provide entries in the auto_index array to support the\n" append index "# auto-loading of Oc_Classes.\n\n" if {$args == ""} { set args *.tcl } foreach file [eval glob $args] { set f "" set error [catch { set f [open $file] while {[gets $f line] >= 0} { if {[regexp {^Oc_Class[ ]+([^ ]*)} $line match className]} { append index "set [list auto_index($className)]" # Should this be at global scope? append index " \[list uplevel #0 \[list source \[file join \$dir [list $file]\]\]\]\n" } } close $f } msg] if {$error} { set code $errorCode set info $errorInfo catch {close $f} cd $oldDir error $msg $info $code } } set f "" set error [catch { set f [open tclIndex a] puts -nonewline $f $index close $f cd $oldDir } msg] if {$error} { set code $errorCode set info $errorInfo catch {close $f} cd $oldDir error $msg $info $code } } # Tk bindings are susceptible to reentrancy problems. For example, # suppose a user double clicks on a single click binding. Two # single clicks events get entered into the event loop. Now, if # during the processing of the binding on the first click, the # event loop were to be re-entered, then this would cause a second # call to the binding (from the second click) before the first call # has finished processing. In particular, one should be aware that # anytime the binding proc accesses a global variable, that global # variable may have a trace on it, and that trace may make an update, # tkwait, or similar request...against the better interests of the # binding proc. # To protect against reentrancy, use the following proc, # OMF_ThreadSafe. You will probably want to use a unique "thread_id" # for each protected code segment. Ideally, "script" should just be # a proc call, in which case the name of the proc is a good choice for # the thread_id. (Note: The "wait" retry time is in milliseconds.) # Sample usage: # # button $w.wFDokbtn -text "OK" \ # -command "OMF_ThreadSafe OMD_FDokcmd,$w \{OMF_FDokcmd $w\}" # # Here I want to protect against reentrancy from the same window, $w, # so I append that as an additional identifier on thread_id. # # NOTE 1: The script is executed at global scope # NOTE 2: In the current implementation, order of processing of delayed # calls may not be preserved. proc Oc_ThreadSafe { thread_id script {wait 500}} { global omfThreadLock errorInfo errorCode if { [info exists omfThreadLock($thread_id)] \ && $omfThreadLock($thread_id)==1 } { # Thread locked. Put script on shelf and try again later after $wait [list Oc_ThreadSafe $thread_id $script] } else { # Otherwise, process the script now set omfThreadLock($thread_id) 1 set errcode [catch { uplevel #0 $script } errmsg] set omfThreadLock($thread_id) 0 if { $errcode != 0 } { error $errmsg $errorInfo $errorCode } } } # Some event bindings, in particular mouse drag events, can generate a # nearly continuous stream of events in response to user input. If the # handler for these events is slow, then these events can pile up in the # event loop. It is often the case in this situation that all # intermediate events can be ignored, and only the last one processed. # This proc takes a standard bind command, and puts a wrapper around it # to implement this behavior. The returned string can be directly bound # to an event. NOTE: This routine does not protect against re-entrancy # on $cmd. If $cmd services the event loop, then there is the # possibility of event re-ordering. In this circumstance, use # Oc_SafeSkipWrap instead. set _oc_skipwrap(count) 0 proc Oc_SkipWrap { cmd {wait 3}} { global _oc_skipwrap ;# Wrapper state set id $_oc_skipwrap(count) ;# Elt to hold pending event id incr _oc_skipwrap(count) set _oc_skipwrap($id) {} ;# Initialize set newcmd [format { global _oc_skipwrap after cancel $_oc_skipwrap(%s) set _oc_skipwrap(%s) [after %s {%s}] } $id $id $wait $cmd] ;# Create wrapped command return $newcmd } # Oc_SafeSkipWrap is a version of Oc_SkipWrap that puts a # semaphore-style lock around the wrapped command. Before a command is # executed, a check is made to see if a lock is set. If so, the command # goes back onto the event queue. If not, the lock is set, the command # is run, and then the lock is unset. Three points: 1) It is important # that the command run to completion. If it should fail, then the lock # would never be reset and all future commands on this binding would be # locked out. Because of this, it is not a bad idea to wrap $cmd up # inside a 'catch'. 2) The locking mechanism protects $cmd from # reentrancy from _this_ binding. For example, say $cmd is a call to # proc foo. This lock is placed outside of foo, so even if the lock is # set as a result of this binding, that does not lock out calls to foo # from a different event binding. If you need absolute reentrancy # protection, use Oc_ThreadSafe. 3) Because only 1 event is queued up at # a time (unprocessed events are thrown away when a new one is # generated), event order _is_ preserved on execution. set _oc_safeskipwrap(count) 0 proc Oc_SafeSkipWrap { cmd {wait 3}} { global _oc_safeskipwrap ;# Wrapper state set id $_oc_safeskipwrap(count) ;# Elt to hold pending event id incr _oc_safeskipwrap(count) set _oc_safeskipwrap($id) {} ;# Initialize set _oc_safeskipwrap(lock$id) {} set newcmd [format { global _oc_safeskipwrap after cancel $_oc_safeskipwrap(%s) set _oc_safeskipwrap(%s) \ [after %s {Oc_SafeSkipLock %s {%s} %s}] } $id $id $wait $id $cmd $wait] ;# Create wrapped command return $newcmd } proc Oc_SafeSkipLock { id cmd wait } { # Processes ripened events global _oc_safeskipwrap switch {} $_oc_safeskipwrap(lock$id) { set _oc_safeskipwrap(lock$id) 1 eval $cmd set _oc_safeskipwrap(lock$id) {} } default { set _oc_safeskipwrap($id) \ [after $wait "Oc_SafeSkipLock $id \{$cmd\} $wait"] } } proc Oc_OpenUniqueFile {args} { array set opts { -pfx "" -sfx "" -sep1 "" -sep2 "" -start 0 } array set opts $args foreach var {pfx sfx sep1 sep2 start} { set $var $opts(-$var) } if {[file isdirectory $pfx]} { append pfx / set sep1 "" } set fn $pfx$sfx set code [catch {open $fn {CREAT EXCL RDWR}} handle] if {$code == 0} { return [list $handle $fn 0] } set N 3 ;# number of digits in serial number. Edit this ;# if you need a larger range of unique file names set i [expr {$N+1}] set max 1 while {[incr i -1]} { append max 0 } if {$start >= $max} { set start 0 } set i $start set serial [format %0${N}d $i] set fn $pfx$sep1$serial$sep2$sfx while {[set code [catch {open $fn {CREAT EXCL RDWR}} handle]]} { incr i if {$i >= $max} { set i 0 } if {$i == $start} { set msg "Can't open unique file name matching: $pfx$sep1" incr max -1 regsub -all 9 $max ? max append msg $max$sep2$sfx error $msg $msg } set serial [format %0${N}d $i] set fn $pfx$sep1$serial$sep2$sfx } return [list $handle $fn [incr i]] } proc Oc_TempName { {baseprefix {_}} {suffix {}} {basedir {}} } { if {[string match {} $basedir]} { Oc_TempFile New f -stem $baseprefix -extension $suffix } else { Oc_TempFile New f -stem $baseprefix -extension $suffix \ -directory $basedir } set retval [$f AbsoluteName] $f Claim $f Delete return $retval } proc Oc_StackTrace {} { set history {} for {set n [expr {[info level]-1}]} {$n>0} {incr n -1} { append history "LEVEL $n: [info level $n]\n\n" } return $history } # The rest of the procs in this file are only defined # conditionally based on whether or not the commands # defined in the C portion of the Oc extension are available. # However, the usual indenting rules are not followed because # we want all these procs to start in the first column so # they will have entries in tclIndex. if {[llength [info commands Oc_IgnoreSignal]]} { proc Oc_IgnoreInteractiveSignals {} { catch {Oc_IgnoreSignal 2} ;# Ctrl-C generates SIGINT catch {Oc_IgnoreSignal 3} ;# Ctrl-\ generates SIGQUIT catch {Oc_IgnoreSignal 18} ;# Ctrl-Z generates SIGTSTP catch {Oc_IgnoreSignal 20} ;# Invoke automatic child reaping. This ## may not work on all platforms. # Unix list: # 1) SIGHUP 2) SIGINT 3) SIGQUIT 4) SIGILL # 5) SIGTRAP 6) SIGIOT 7) SIGEMT 8) SIGFPE # 9) SIGKILL 10) SIGBUS 11) SIGSEGV 12) SIGSYS # 13) SIGPIPE 14) SIGALRM 15) SIGTERM 16) SIGURG # 17) SIGSTOP 18) SIGTSTP 19) SIGCONT 20) SIGCHLD # 21) SIGTTIN 22) SIGTTOU 23) SIGIO 24) SIGXCPU # 25) SIGXFSZ 26) SIGVTALRM 27) SIGPROF 28) SIGWINCH # 29) SIGPWR 30) SIGUSR1 31) SIGUSR2 # Under Windows, only the following subset is apparently available: # SIGINT, SIGILL, SIGFPE, SIGSEGV, SIGTERM, SIGBREAK, SIGABRT # NOTE: The number<->name matching may be system dependent. It # would be better to pick these values up from /usr/signal.h } proc Oc_IgnoreTermLoss {} { # Try to ignore the loss of controlling tty. catch {Oc_IgnoreSignal 1} ;# Closing tty's generate SIGHUP catch {Oc_IgnoreSignal 13} ;# Broken pipe catch {Oc_IgnoreSignal 21} ;# Tty input for background process catch {Oc_IgnoreSignal 22} ;# Tty onput for background process # Unix list: # 1) SIGHUP 2) SIGINT 3) SIGQUIT 4) SIGILL # 5) SIGTRAP 6) SIGIOT 7) SIGEMT 8) SIGFPE # 9) SIGKILL 10) SIGBUS 11) SIGSEGV 12) SIGSYS # 13) SIGPIPE 14) SIGALRM 15) SIGTERM 16) SIGURG # 17) SIGSTOP 18) SIGTSTP 19) SIGCONT 20) SIGCHLD # 21) SIGTTIN 22) SIGTTOU 23) SIGIO 24) SIGXCPU # 25) SIGXFSZ 26) SIGVTALRM 27) SIGPROF 28) SIGWINCH # 29) SIGPWR 30) SIGUSR1 31) SIGUSR2 # Under Windows, only the following subset is apparently available: # SIGINT, SIGILL, SIGFPE, SIGSEGV, SIGTERM, SIGBREAK, SIGABRT # NOTE: The number<->name matching may be system dependent. It # would be better to pick these values up from /usr/signal.h } } if {![llength [info commands Oc_SetPanicHeader]]} { proc Oc_SetPanicHeader {msg} {} }